remove type annotations as comments;
authorblanchet
Sat Apr 24 16:33:01 2010 +0200 (2010-04-24)
changeset 36385ff5f88702590
parent 36384 76d5fd5a45fb
child 36386 2132f15b366f
remove type annotations as comments;
Nitpick is now 1136 lines shorter
src/HOL/Tools/Nitpick/kodkod.ML
src/HOL/Tools/Nitpick/kodkod_sat.ML
src/HOL/Tools/Nitpick/minipick.ML
src/HOL/Tools/Nitpick/nitpick.ML
src/HOL/Tools/Nitpick/nitpick_hol.ML
src/HOL/Tools/Nitpick/nitpick_isar.ML
src/HOL/Tools/Nitpick/nitpick_kodkod.ML
src/HOL/Tools/Nitpick/nitpick_model.ML
src/HOL/Tools/Nitpick/nitpick_mono.ML
src/HOL/Tools/Nitpick/nitpick_nut.ML
src/HOL/Tools/Nitpick/nitpick_peephole.ML
src/HOL/Tools/Nitpick/nitpick_preproc.ML
src/HOL/Tools/Nitpick/nitpick_rep.ML
src/HOL/Tools/Nitpick/nitpick_scope.ML
src/HOL/Tools/Nitpick/nitpick_tests.ML
src/HOL/Tools/Nitpick/nitpick_util.ML
     1.1 --- a/src/HOL/Tools/Nitpick/kodkod.ML	Sat Apr 24 16:17:30 2010 +0200
     1.2 +++ b/src/HOL/Tools/Nitpick/kodkod.ML	Sat Apr 24 16:33:01 2010 +0200
     1.3 @@ -321,7 +321,6 @@
     1.4  
     1.5  (** Auxiliary functions on ML representation of Kodkod problems **)
     1.6  
     1.7 -(* 'a fold_expr_funcs -> formula -> 'a -> 'a *)
     1.8  fun fold_formula (F : 'a fold_expr_funcs) formula =
     1.9    case formula of
    1.10      All (ds, f) => fold (fold_decl F) ds #> fold_formula F f
    1.11 @@ -354,7 +353,6 @@
    1.12    | False => #formula_func F formula
    1.13    | True => #formula_func F formula
    1.14    | FormulaReg _ => #formula_func F formula
    1.15 -(* 'a fold_expr_funcs -> rel_expr -> 'a -> 'a *)
    1.16  and fold_rel_expr F rel_expr =
    1.17    case rel_expr of
    1.18      RelLet (bs, r) => fold (fold_expr_assign F) bs #> fold_rel_expr F r
    1.19 @@ -383,7 +381,6 @@
    1.20    | Rel _ => #rel_expr_func F rel_expr
    1.21    | Var _ => #rel_expr_func F rel_expr
    1.22    | RelReg _ => #rel_expr_func F rel_expr
    1.23 -(* 'a fold_expr_funcs -> int_expr -> 'a -> 'a *)
    1.24  and fold_int_expr F int_expr =
    1.25    case int_expr of
    1.26      Sum (ds, i) => fold (fold_decl F) ds #> fold_int_expr F i
    1.27 @@ -409,7 +406,6 @@
    1.28    | Signum i => fold_int_expr F i
    1.29    | Num _ => #int_expr_func F int_expr
    1.30    | IntReg _ => #int_expr_func F int_expr
    1.31 -(* 'a fold_expr_funcs -> decl -> 'a -> 'a *)
    1.32  and fold_decl F decl =
    1.33    case decl of
    1.34      DeclNo (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
    1.35 @@ -417,7 +413,6 @@
    1.36    | DeclOne (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
    1.37    | DeclSome (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
    1.38    | DeclSet (x, r) => fold_rel_expr F (Var x) #> fold_rel_expr F r
    1.39 -(* 'a fold_expr_funcs -> expr_assign -> 'a -> 'a *)
    1.40  and fold_expr_assign F assign =
    1.41    case assign of
    1.42      AssignFormulaReg (x, f) => fold_formula F (FormulaReg x) #> fold_formula F f
    1.43 @@ -429,9 +424,7 @@
    1.44    tuple_set_func: tuple_set -> 'a -> 'a
    1.45  }
    1.46  
    1.47 -(* 'a fold_tuple_funcs -> tuple -> 'a -> 'a *)
    1.48  fun fold_tuple (F : 'a fold_tuple_funcs) = #tuple_func F
    1.49 -(* 'a fold_tuple_funcs -> tuple_set -> 'a -> 'a *)
    1.50  fun fold_tuple_set F tuple_set =
    1.51    case tuple_set of
    1.52      TupleUnion (ts1, ts2) => fold_tuple_set F ts1 #> fold_tuple_set F ts2
    1.53 @@ -444,23 +437,18 @@
    1.54    | TupleArea (t1, t2) => fold_tuple F t1 #> fold_tuple F t2
    1.55    | TupleAtomSeq _ => #tuple_set_func F tuple_set
    1.56    | TupleSetReg _ => #tuple_set_func F tuple_set
    1.57 -(* 'a fold_tuple_funcs -> tuple_assign -> 'a -> 'a *)
    1.58  fun fold_tuple_assign F assign =
    1.59    case assign of
    1.60      AssignTuple (x, t) => fold_tuple F (TupleReg x) #> fold_tuple F t
    1.61    | AssignTupleSet (x, ts) =>
    1.62      fold_tuple_set F (TupleSetReg x) #> fold_tuple_set F ts
    1.63 -(* 'a fold_expr_funcs -> 'a fold_tuple_funcs -> bound -> 'a -> 'a *)
    1.64  fun fold_bound expr_F tuple_F (zs, tss) =
    1.65    fold (fold_rel_expr expr_F) (map (Rel o fst) zs)
    1.66    #> fold (fold_tuple_set tuple_F) tss
    1.67 -(* 'a fold_tuple_funcs -> int_bound -> 'a -> 'a *)
    1.68  fun fold_int_bound F (_, tss) = fold (fold_tuple_set F) tss
    1.69  
    1.70 -(* int -> int *)
    1.71  fun max_arity univ_card = floor (Math.ln 2147483647.0
    1.72                                   / Math.ln (Real.fromInt univ_card))
    1.73 -(* rel_expr -> int *)
    1.74  fun arity_of_rel_expr (RelLet (_, r)) = arity_of_rel_expr r
    1.75    | arity_of_rel_expr (RelIf (_, r1, _)) = arity_of_rel_expr r1
    1.76    | arity_of_rel_expr (Union (r1, _)) = arity_of_rel_expr r1
    1.77 @@ -487,23 +475,18 @@
    1.78    | arity_of_rel_expr (Rel (n, _)) = n
    1.79    | arity_of_rel_expr (Var (n, _)) = n
    1.80    | arity_of_rel_expr (RelReg (n, _)) = n
    1.81 -(* rel_expr -> rel_expr -> int *)
    1.82  and sum_arities_of_rel_exprs r1 r2 = arity_of_rel_expr r1 + arity_of_rel_expr r2
    1.83 -(* decl -> int *)
    1.84  and arity_of_decl (DeclNo ((n, _), _)) = n
    1.85    | arity_of_decl (DeclLone ((n, _), _)) = n
    1.86    | arity_of_decl (DeclOne ((n, _), _)) = n
    1.87    | arity_of_decl (DeclSome ((n, _), _)) = n
    1.88    | arity_of_decl (DeclSet ((n, _), _)) = n
    1.89  
    1.90 -(* problem -> bool *)
    1.91  fun is_problem_trivially_false ({formula = False, ...} : problem) = true
    1.92    | is_problem_trivially_false _ = false
    1.93  
    1.94 -(* string -> string list *)
    1.95  val chop_solver = take 2 o space_explode ","
    1.96  
    1.97 -(* setting list * setting list -> bool *)
    1.98  fun settings_equivalent ([], []) = true
    1.99    | settings_equivalent ((key1, value1) :: settings1,
   1.100                           (key2, value2) :: settings2) =
   1.101 @@ -513,7 +496,6 @@
   1.102      settings_equivalent (settings1, settings2)
   1.103    | settings_equivalent _ = false
   1.104  
   1.105 -(* problem * problem -> bool *)
   1.106  fun problems_equivalent (p1 : problem, p2 : problem) =
   1.107    #univ_card p1 = #univ_card p2 andalso
   1.108    #formula p1 = #formula p2 andalso
   1.109 @@ -525,16 +507,13 @@
   1.110  
   1.111  (** Serialization of problem **)
   1.112  
   1.113 -(* int -> string *)
   1.114  fun base_name j =
   1.115    if j < 0 then string_of_int (~j - 1) ^ "'" else string_of_int j
   1.116  
   1.117 -(* n_ary_index -> string -> string -> string -> string *)
   1.118  fun n_ary_name (1, j) prefix _ _ = prefix ^ base_name j
   1.119    | n_ary_name (2, j) _ prefix _ = prefix ^ base_name j
   1.120    | n_ary_name (n, j) _ _ prefix = prefix ^ string_of_int n ^ "_" ^ base_name j
   1.121  
   1.122 -(* int -> string *)
   1.123  fun atom_name j = "A" ^ base_name j
   1.124  fun atom_seq_name (k, 0) = "u" ^ base_name k
   1.125    | atom_seq_name (k, j0) = "u" ^ base_name k ^ "@" ^ base_name j0
   1.126 @@ -542,14 +521,12 @@
   1.127  fun rel_reg_name j = "$e" ^ base_name j
   1.128  fun int_reg_name j = "$i" ^ base_name j
   1.129  
   1.130 -(* n_ary_index -> string *)
   1.131  fun tuple_name x = n_ary_name x "A" "P" "T"
   1.132  fun rel_name x = n_ary_name x "s" "r" "m"
   1.133  fun var_name x = n_ary_name x "S" "R" "M"
   1.134  fun tuple_reg_name x = n_ary_name x "$A" "$P" "$T"
   1.135  fun tuple_set_reg_name x = n_ary_name x "$a" "$p" "$t"
   1.136  
   1.137 -(* string -> string *)
   1.138  fun inline_comment "" = ""
   1.139    | inline_comment comment =
   1.140      " /* " ^ translate_string (fn "\n" => " " | "*" => "* " | s => s) comment ^
   1.141 @@ -557,10 +534,8 @@
   1.142  fun block_comment "" = ""
   1.143    | block_comment comment = prefix_lines "// " comment ^ "\n"
   1.144  
   1.145 -(* (n_ary_index * string) -> string *)
   1.146  fun commented_rel_name (x, s) = rel_name x ^ inline_comment s
   1.147  
   1.148 -(* tuple -> string *)
   1.149  fun string_for_tuple (Tuple js) = "[" ^ commas (map atom_name js) ^ "]"
   1.150    | string_for_tuple (TupleIndex x) = tuple_name x
   1.151    | string_for_tuple (TupleReg x) = tuple_reg_name x
   1.152 @@ -571,7 +546,6 @@
   1.153  val prec_TupleProduct = 3
   1.154  val prec_TupleProject = 4
   1.155  
   1.156 -(* tuple_set -> int *)
   1.157  fun precedence_ts (TupleUnion _) = prec_TupleUnion
   1.158    | precedence_ts (TupleDifference _) = prec_TupleUnion
   1.159    | precedence_ts (TupleIntersect _) = prec_TupleIntersect
   1.160 @@ -579,10 +553,8 @@
   1.161    | precedence_ts (TupleProject _) = prec_TupleProject
   1.162    | precedence_ts _ = no_prec
   1.163  
   1.164 -(* tuple_set -> string *)
   1.165  fun string_for_tuple_set tuple_set =
   1.166    let
   1.167 -    (* tuple_set -> int -> string *)
   1.168      fun sub tuple_set outer_prec =
   1.169        let
   1.170          val prec = precedence_ts tuple_set
   1.171 @@ -608,19 +580,16 @@
   1.172        end
   1.173    in sub tuple_set 0 end
   1.174  
   1.175 -(* tuple_assign -> string *)
   1.176  fun string_for_tuple_assign (AssignTuple (x, t)) =
   1.177      tuple_reg_name x ^ " := " ^ string_for_tuple t ^ "\n"
   1.178    | string_for_tuple_assign (AssignTupleSet (x, ts)) =
   1.179      tuple_set_reg_name x ^ " := " ^ string_for_tuple_set ts ^ "\n"
   1.180  
   1.181 -(* bound -> string *)
   1.182  fun string_for_bound (zs, tss) =
   1.183    "bounds " ^ commas (map commented_rel_name zs) ^ ": " ^
   1.184    (if length tss = 1 then "" else "[") ^ commas (map string_for_tuple_set tss) ^
   1.185    (if length tss = 1 then "" else "]") ^ "\n"
   1.186  
   1.187 -(* int_bound -> string *)
   1.188  fun int_string_for_bound (opt_n, tss) =
   1.189    (case opt_n of
   1.190       SOME n => signed_string_of_int n ^ ": "
   1.191 @@ -645,7 +614,6 @@
   1.192  val prec_Join = 18
   1.193  val prec_BitNot = 19
   1.194  
   1.195 -(* formula -> int *)
   1.196  fun precedence_f (All _) = prec_All
   1.197    | precedence_f (Exist _) = prec_All
   1.198    | precedence_f (FormulaLet _) = prec_All
   1.199 @@ -671,7 +639,6 @@
   1.200    | precedence_f False = no_prec
   1.201    | precedence_f True = no_prec
   1.202    | precedence_f (FormulaReg _) = no_prec
   1.203 -(* rel_expr -> int *)
   1.204  and precedence_r (RelLet _) = prec_All
   1.205    | precedence_r (RelIf _) = prec_All
   1.206    | precedence_r (Union _) = prec_Add
   1.207 @@ -697,7 +664,6 @@
   1.208    | precedence_r (Rel _) = no_prec
   1.209    | precedence_r (Var _) = no_prec
   1.210    | precedence_r (RelReg _) = no_prec
   1.211 -(* int_expr -> int *)
   1.212  and precedence_i (Sum _) = prec_All
   1.213    | precedence_i (IntLet _) = prec_All
   1.214    | precedence_i (IntIf _) = prec_All
   1.215 @@ -721,14 +687,11 @@
   1.216    | precedence_i (Num _) = no_prec
   1.217    | precedence_i (IntReg _) = no_prec
   1.218  
   1.219 -(* (string -> unit) -> problem list -> unit *)
   1.220  fun write_problem_file out problems =
   1.221    let
   1.222 -    (* formula -> unit *)
   1.223      fun out_outmost_f (And (f1, f2)) =
   1.224          (out_outmost_f f1; out "\n   && "; out_outmost_f f2)
   1.225        | out_outmost_f f = out_f f prec_And
   1.226 -    (* formula -> int -> unit *)
   1.227      and out_f formula outer_prec =
   1.228        let
   1.229          val prec = precedence_f formula
   1.230 @@ -773,7 +736,6 @@
   1.231           | FormulaReg j => out (formula_reg_name j));
   1.232          (if need_parens then out ")" else ())
   1.233        end
   1.234 -    (* rel_expr -> int -> unit *)
   1.235      and out_r rel_expr outer_prec =
   1.236        let
   1.237          val prec = precedence_r rel_expr
   1.238 @@ -813,7 +775,6 @@
   1.239           | RelReg (_, j) => out (rel_reg_name j));
   1.240          (if need_parens then out ")" else ())
   1.241        end
   1.242 -    (* int_expr -> int -> unit *)
   1.243      and out_i int_expr outer_prec =
   1.244        let
   1.245          val prec = precedence_i int_expr
   1.246 @@ -848,11 +809,9 @@
   1.247           | IntReg j => out (int_reg_name j));
   1.248          (if need_parens then out ")" else ())
   1.249        end
   1.250 -    (* decl list -> unit *)
   1.251      and out_decls [] = ()
   1.252        | out_decls [d] = out_decl d
   1.253        | out_decls (d :: ds) = (out_decl d; out ", "; out_decls ds)
   1.254 -    (* decl -> unit *)
   1.255      and out_decl (DeclNo (x, r)) =
   1.256          (out (var_name x); out " : no "; out_r r 0)
   1.257        | out_decl (DeclLone (x, r)) =
   1.258 @@ -863,22 +822,18 @@
   1.259          (out (var_name x); out " : some "; out_r r 0)
   1.260        | out_decl (DeclSet (x, r)) =
   1.261          (out (var_name x); out " : set "; out_r r 0)
   1.262 -    (* assign_expr list -> unit *)
   1.263      and out_assigns [] = ()
   1.264        | out_assigns [b] = out_assign b
   1.265        | out_assigns (b :: bs) = (out_assign b; out ", "; out_assigns bs)
   1.266 -    (* assign_expr -> unit *)
   1.267      and out_assign (AssignFormulaReg (j, f)) =
   1.268          (out (formula_reg_name j); out " := "; out_f f 0)
   1.269        | out_assign (AssignRelReg ((_, j), r)) =
   1.270          (out (rel_reg_name j); out " := "; out_r r 0)
   1.271        | out_assign (AssignIntReg (j, i)) =
   1.272          (out (int_reg_name j); out " := "; out_i i 0)
   1.273 -    (* int_expr list -> unit *)
   1.274      and out_columns [] = ()
   1.275        | out_columns [i] = out_i i 0
   1.276        | out_columns (i :: is) = (out_i i 0; out ", "; out_columns is)
   1.277 -    (* problem -> unit *)
   1.278      and out_problem {comment, settings, univ_card, tuple_assigns, bounds,
   1.279                       int_bounds, expr_assigns, formula} =
   1.280          (out ("\n" ^ block_comment comment ^
   1.281 @@ -902,12 +857,10 @@
   1.282  
   1.283  (** Parsing of solution **)
   1.284  
   1.285 -(* string -> bool *)
   1.286  fun is_ident_char s =
   1.287    Symbol.is_ascii_letter s orelse Symbol.is_ascii_digit s orelse
   1.288    s = "_" orelse s = "'" orelse s = "$"
   1.289  
   1.290 -(* string list -> string list *)
   1.291  fun strip_blanks [] = []
   1.292    | strip_blanks (" " :: ss) = strip_blanks ss
   1.293    | strip_blanks [s1, " "] = [s1]
   1.294 @@ -918,29 +871,20 @@
   1.295        strip_blanks (s1 :: s2 :: ss)
   1.296    | strip_blanks (s :: ss) = s :: strip_blanks ss
   1.297  
   1.298 -(* (string list -> 'a * string list) -> string list -> 'a list * string list *)
   1.299  fun scan_non_empty_list scan = scan ::: Scan.repeat ($$ "," |-- scan)
   1.300  fun scan_list scan = scan_non_empty_list scan || Scan.succeed []
   1.301 -(* string list -> int * string list *)
   1.302  val scan_nat = Scan.repeat1 (Scan.one Symbol.is_ascii_digit)
   1.303                 >> (the o Int.fromString o space_implode "")
   1.304 -(*  string list -> (int * int) * string list *)
   1.305  val scan_rel_name = $$ "s" |-- scan_nat >> pair 1
   1.306                      || $$ "r" |-- scan_nat >> pair 2
   1.307                      || ($$ "m" |-- scan_nat --| $$ "_") -- scan_nat
   1.308 -(* string list -> int * string list *)
   1.309  val scan_atom = $$ "A" |-- scan_nat
   1.310 -(* string list -> int list * string list *)
   1.311  val scan_tuple = $$ "[" |-- scan_list scan_atom --| $$ "]"
   1.312 -(* string list -> int list list * string list *)
   1.313  val scan_tuple_set = $$ "[" |-- scan_list scan_tuple --| $$ "]"
   1.314 -(* string list -> ((int * int) * int list list) * string list *)
   1.315  val scan_assignment = (scan_rel_name --| $$ "=") -- scan_tuple_set
   1.316 -(* string list -> ((int * int) * int list list) list * string list *)
   1.317  val scan_instance = Scan.this_string "relations:" |--
   1.318                      $$ "{" |-- scan_list scan_assignment --| $$ "}"
   1.319  
   1.320 -(* string -> raw_bound list *)
   1.321  val parse_instance =
   1.322    fst o Scan.finite Symbol.stopper
   1.323              (Scan.error (!! (fn _ =>
   1.324 @@ -953,12 +897,10 @@
   1.325  val outcome_marker = "---OUTCOME---\n"
   1.326  val instance_marker = "---INSTANCE---\n"
   1.327  
   1.328 -(* string -> substring -> string *)
   1.329  fun read_section_body marker =
   1.330    Substring.string o fst o Substring.position "\n\n"
   1.331    o Substring.triml (size marker)
   1.332  
   1.333 -(* substring -> raw_bound list *)
   1.334  fun read_next_instance s =
   1.335    let val s = Substring.position instance_marker s |> snd in
   1.336      if Substring.isEmpty s then
   1.337 @@ -967,8 +909,6 @@
   1.338        read_section_body instance_marker s |> parse_instance
   1.339    end
   1.340  
   1.341 -(* int -> substring * (int * raw_bound list) list * int list
   1.342 -   -> substring * (int * raw_bound list) list * int list *)
   1.343  fun read_next_outcomes j (s, ps, js) =
   1.344    let val (s1, s2) = Substring.position outcome_marker s in
   1.345      if Substring.isEmpty s2 orelse
   1.346 @@ -990,8 +930,6 @@
   1.347        end
   1.348    end
   1.349  
   1.350 -(* substring * (int * raw_bound list) list * int list
   1.351 -   -> (int * raw_bound list) list * int list *)
   1.352  fun read_next_problems (s, ps, js) =
   1.353    let val s = Substring.position problem_marker s |> snd in
   1.354      if Substring.isEmpty s then
   1.355 @@ -1007,7 +945,6 @@
   1.356    handle Option.Option => raise SYNTAX ("Kodkod.read_next_problems",
   1.357                                          "expected number after \"PROBLEM\"")
   1.358  
   1.359 -(* Path.T -> bool * ((int * raw_bound list) list * int list) *)
   1.360  fun read_output_file path =
   1.361    (false, read_next_problems (Substring.full (File.read path), [], [])
   1.362            |>> rev ||> rev)
   1.363 @@ -1017,7 +954,6 @@
   1.364  
   1.365  val created_temp_dir = Unsynchronized.ref false
   1.366  
   1.367 -(* bool -> string * string *)
   1.368  fun serial_string_and_temporary_dir_for_overlord overlord =
   1.369    if overlord then
   1.370      ("", getenv "ISABELLE_HOME_USER")
   1.371 @@ -1032,14 +968,12 @@
   1.372     is partly due to the JVM and partly due to the ML "bash" function. *)
   1.373  val fudge_ms = 250
   1.374  
   1.375 -(* Time.time option -> int *)
   1.376  fun milliseconds_until_deadline deadline =
   1.377    case deadline of
   1.378      NONE => ~1
   1.379    | SOME time =>
   1.380      Int.max (0, Time.toMilliseconds (Time.- (time, Time.now ())) - fudge_ms)
   1.381  
   1.382 -(* bool -> Time.time option -> int -> int -> problem list -> outcome *)
   1.383  fun uncached_solve_any_problem overlord deadline max_threads max_solutions
   1.384                                 problems =
   1.385    let
   1.386 @@ -1051,7 +985,6 @@
   1.387                                          (0 upto length problems - 1 ~~ problems)
   1.388      val triv_js = filter_out (AList.defined (op =) indexed_problems)
   1.389                               (0 upto length problems - 1)
   1.390 -    (* int -> int *)
   1.391      val reindex = fst o nth indexed_problems
   1.392    in
   1.393      if null indexed_problems then
   1.394 @@ -1060,18 +993,15 @@
   1.395        let
   1.396          val (serial_str, temp_dir) =
   1.397            serial_string_and_temporary_dir_for_overlord overlord
   1.398 -        (* string -> Path.T *)
   1.399          fun path_for suf =
   1.400            Path.explode (temp_dir ^ "/kodkodi" ^ serial_str ^ "." ^ suf)
   1.401          val in_path = path_for "kki"
   1.402          val in_buf = Unsynchronized.ref Buffer.empty
   1.403 -        (* string -> unit *)
   1.404          fun out s = Unsynchronized.change in_buf (Buffer.add s)
   1.405          val out_path = path_for "out"
   1.406          val err_path = path_for "err"
   1.407          val _ = write_problem_file out (map snd indexed_problems)
   1.408          val _ = File.write_buffer in_path (!in_buf)
   1.409 -        (* unit -> unit *)
   1.410          fun remove_temporary_files () =
   1.411            if overlord then ()
   1.412            else List.app (K () o try File.rm) [in_path, out_path, err_path]
   1.413 @@ -1150,10 +1080,8 @@
   1.414    Synchronized.var "Kodkod.cached_outcome"
   1.415                     (NONE : ((int * problem list) * outcome) option)
   1.416  
   1.417 -(* bool -> Time.time option -> int -> int -> problem list -> outcome *)
   1.418  fun solve_any_problem overlord deadline max_threads max_solutions problems =
   1.419    let
   1.420 -    (* unit -> outcome *)
   1.421      fun do_solve () = uncached_solve_any_problem overlord deadline max_threads
   1.422                                                   max_solutions problems
   1.423    in
     2.1 --- a/src/HOL/Tools/Nitpick/kodkod_sat.ML	Sat Apr 24 16:17:30 2010 +0200
     2.2 +++ b/src/HOL/Tools/Nitpick/kodkod_sat.ML	Sat Apr 24 16:33:01 2010 +0200
     2.3 @@ -51,8 +51,6 @@
     2.4     ("HaifaSat", ExternalV2 (ToStdout, "HAIFASAT_HOME", "HaifaSat", ["-p", "1"],
     2.5                              "s SATISFIABLE", "v ", "s UNSATISFIABLE"))]
     2.6  
     2.7 -(* string -> sink -> string -> string -> string list -> string list
     2.8 -   -> (string * (unit -> string list)) option *)
     2.9  fun dynamic_entry_for_external name dev home exec args markers =
    2.10    case getenv home of
    2.11      "" => NONE
    2.12 @@ -74,8 +72,6 @@
    2.13                        if dev = ToFile then out_file else ""] @ markers @
    2.14                        (if dev = ToFile then [out_file] else []) @ args
    2.15                     end)
    2.16 -(* bool -> bool -> string * sat_solver_info
    2.17 -   -> (string * (unit -> string list)) option *)
    2.18  fun dynamic_entry_for_info incremental (name, Internal (Java, mode, ss)) =
    2.19      if incremental andalso mode = Batch then NONE else SOME (name, K ss)
    2.20    | dynamic_entry_for_info incremental (name, Internal (JNI, mode, ss)) =
    2.21 @@ -98,20 +94,15 @@
    2.22          (name, ExternalV2 (dev, home, exec, args, m1, m2, m3)) =
    2.23      dynamic_entry_for_external name dev home exec args [m1, m2, m3]
    2.24    | dynamic_entry_for_info true _ = NONE
    2.25 -(* bool -> (string * (unit -> string list)) list *)
    2.26  fun dynamic_list incremental =
    2.27    map_filter (dynamic_entry_for_info incremental) static_list
    2.28  
    2.29 -(* bool -> string list *)
    2.30  val configured_sat_solvers = map fst o dynamic_list
    2.31 -(* bool -> string *)
    2.32  val smart_sat_solver_name = fst o hd o dynamic_list
    2.33  
    2.34 -(* string -> string * string list *)
    2.35  fun sat_solver_spec name =
    2.36    let
    2.37      val dyn_list = dynamic_list false
    2.38 -    (* (string * 'a) list -> string *)
    2.39      fun enum_solvers solvers =
    2.40        commas (distinct (op =) (map (quote o fst) solvers))
    2.41    in
     3.1 --- a/src/HOL/Tools/Nitpick/minipick.ML	Sat Apr 24 16:17:30 2010 +0200
     3.2 +++ b/src/HOL/Tools/Nitpick/minipick.ML	Sat Apr 24 16:33:01 2010 +0200
     3.3 @@ -35,7 +35,6 @@
     3.4  
     3.5  datatype rep = SRep | RRep
     3.6  
     3.7 -(* Proof.context -> typ -> unit *)
     3.8  fun check_type ctxt (Type (@{type_name fun}, Ts)) =
     3.9      List.app (check_type ctxt) Ts
    3.10    | check_type ctxt (Type (@{type_name "*"}, Ts)) =
    3.11 @@ -46,7 +45,6 @@
    3.12    | check_type ctxt T =
    3.13      raise NOT_SUPPORTED ("type " ^ quote (Syntax.string_of_typ ctxt T))
    3.14  
    3.15 -(* rep -> (typ -> int) -> typ -> int list *)
    3.16  fun atom_schema_of SRep card (Type (@{type_name fun}, [T1, T2])) =
    3.17      replicate_list (card T1) (atom_schema_of SRep card T2)
    3.18    | atom_schema_of RRep card (Type (@{type_name fun}, [T1, @{typ bool}])) =
    3.19 @@ -56,42 +54,32 @@
    3.20    | atom_schema_of _ card (Type (@{type_name "*"}, Ts)) =
    3.21      maps (atom_schema_of SRep card) Ts
    3.22    | atom_schema_of _ card T = [card T]
    3.23 -(* rep -> (typ -> int) -> typ -> int *)
    3.24  val arity_of = length ooo atom_schema_of
    3.25  
    3.26 -(* (typ -> int) -> typ list -> int -> int *)
    3.27  fun index_for_bound_var _ [_] 0 = 0
    3.28    | index_for_bound_var card (_ :: Ts) 0 =
    3.29      index_for_bound_var card Ts 0 + arity_of SRep card (hd Ts)
    3.30    | index_for_bound_var card Ts n = index_for_bound_var card (tl Ts) (n - 1)
    3.31 -(* (typ -> int) -> rep -> typ list -> int -> rel_expr list *)
    3.32  fun vars_for_bound_var card R Ts j =
    3.33    map (curry Var 1) (index_seq (index_for_bound_var card Ts j)
    3.34                                 (arity_of R card (nth Ts j)))
    3.35 -(* (typ -> int) -> rep -> typ list -> int -> rel_expr *)
    3.36  val rel_expr_for_bound_var = foldl1 Product oooo vars_for_bound_var
    3.37 -(* rep -> (typ -> int) -> typ list -> typ -> decl list *)
    3.38  fun decls_for R card Ts T =
    3.39    map2 (curry DeclOne o pair 1)
    3.40         (index_seq (index_for_bound_var card (T :: Ts) 0)
    3.41                    (arity_of R card (nth (T :: Ts) 0)))
    3.42         (map (AtomSeq o rpair 0) (atom_schema_of R card T))
    3.43  
    3.44 -(* int list -> rel_expr *)
    3.45  val atom_product = foldl1 Product o map Atom
    3.46  
    3.47  val false_atom = Atom 0
    3.48  val true_atom = Atom 1
    3.49  
    3.50 -(* rel_expr -> formula *)
    3.51  fun formula_from_atom r = RelEq (r, true_atom)
    3.52 -(* formula -> rel_expr *)
    3.53  fun atom_from_formula f = RelIf (f, true_atom, false_atom)
    3.54  
    3.55 -(* Proof.context -> (typ -> int) -> styp list -> term -> formula *)
    3.56  fun kodkod_formula_from_term ctxt card frees =
    3.57    let
    3.58 -    (* typ -> rel_expr -> rel_expr *)
    3.59      fun R_rep_from_S_rep (T as Type (@{type_name fun}, [T1, @{typ bool}])) r =
    3.60          let
    3.61            val jss = atom_schema_of SRep card T1 |> map (rpair 0)
    3.62 @@ -117,13 +105,11 @@
    3.63            |> foldl1 Union
    3.64          end
    3.65        | R_rep_from_S_rep _ r = r
    3.66 -    (* typ list -> typ -> rel_expr -> rel_expr *)
    3.67      fun S_rep_from_R_rep Ts (T as Type (@{type_name fun}, _)) r =
    3.68          Comprehension (decls_for SRep card Ts T,
    3.69              RelEq (R_rep_from_S_rep T
    3.70                         (rel_expr_for_bound_var card SRep (T :: Ts) 0), r))
    3.71        | S_rep_from_R_rep _ _ r = r
    3.72 -    (* typ list -> term -> formula *)
    3.73      fun to_F Ts t =
    3.74        (case t of
    3.75           @{const Not} $ t1 => Not (to_F Ts t1)
    3.76 @@ -154,28 +140,26 @@
    3.77         | Const (s, _) => raise NOT_SUPPORTED ("constant " ^ quote s)
    3.78         | _ => raise TERM ("Minipick.kodkod_formula_from_term.to_F", [t]))
    3.79        handle SAME () => formula_from_atom (to_R_rep Ts t)
    3.80 -    (* typ list -> term -> rel_expr *)
    3.81      and to_S_rep Ts t =
    3.82 -        case t of
    3.83 -          Const (@{const_name Pair}, _) $ t1 $ t2 =>
    3.84 -          Product (to_S_rep Ts t1, to_S_rep Ts t2)
    3.85 -        | Const (@{const_name Pair}, _) $ _ => to_S_rep Ts (eta_expand Ts t 1)
    3.86 -        | Const (@{const_name Pair}, _) => to_S_rep Ts (eta_expand Ts t 2)
    3.87 -        | Const (@{const_name fst}, _) $ t1 =>
    3.88 -          let val fst_arity = arity_of SRep card (fastype_of1 (Ts, t)) in
    3.89 -            Project (to_S_rep Ts t1, num_seq 0 fst_arity)
    3.90 -          end
    3.91 -        | Const (@{const_name fst}, _) => to_S_rep Ts (eta_expand Ts t 1)
    3.92 -        | Const (@{const_name snd}, _) $ t1 =>
    3.93 -          let
    3.94 -            val pair_arity = arity_of SRep card (fastype_of1 (Ts, t1))
    3.95 -            val snd_arity = arity_of SRep card (fastype_of1 (Ts, t))
    3.96 -            val fst_arity = pair_arity - snd_arity
    3.97 -          in Project (to_S_rep Ts t1, num_seq fst_arity snd_arity) end
    3.98 -        | Const (@{const_name snd}, _) => to_S_rep Ts (eta_expand Ts t 1)
    3.99 -        | Bound j => rel_expr_for_bound_var card SRep Ts j
   3.100 -        | _ => S_rep_from_R_rep Ts (fastype_of1 (Ts, t)) (to_R_rep Ts t)
   3.101 -    (* term -> rel_expr *)
   3.102 +      case t of
   3.103 +        Const (@{const_name Pair}, _) $ t1 $ t2 =>
   3.104 +        Product (to_S_rep Ts t1, to_S_rep Ts t2)
   3.105 +      | Const (@{const_name Pair}, _) $ _ => to_S_rep Ts (eta_expand Ts t 1)
   3.106 +      | Const (@{const_name Pair}, _) => to_S_rep Ts (eta_expand Ts t 2)
   3.107 +      | Const (@{const_name fst}, _) $ t1 =>
   3.108 +        let val fst_arity = arity_of SRep card (fastype_of1 (Ts, t)) in
   3.109 +          Project (to_S_rep Ts t1, num_seq 0 fst_arity)
   3.110 +        end
   3.111 +      | Const (@{const_name fst}, _) => to_S_rep Ts (eta_expand Ts t 1)
   3.112 +      | Const (@{const_name snd}, _) $ t1 =>
   3.113 +        let
   3.114 +          val pair_arity = arity_of SRep card (fastype_of1 (Ts, t1))
   3.115 +          val snd_arity = arity_of SRep card (fastype_of1 (Ts, t))
   3.116 +          val fst_arity = pair_arity - snd_arity
   3.117 +        in Project (to_S_rep Ts t1, num_seq fst_arity snd_arity) end
   3.118 +      | Const (@{const_name snd}, _) => to_S_rep Ts (eta_expand Ts t 1)
   3.119 +      | Bound j => rel_expr_for_bound_var card SRep Ts j
   3.120 +      | _ => S_rep_from_R_rep Ts (fastype_of1 (Ts, t)) (to_R_rep Ts t)
   3.121      and to_R_rep Ts t =
   3.122        (case t of
   3.123           @{const Not} => to_R_rep Ts (eta_expand Ts t 1)
   3.124 @@ -282,7 +266,6 @@
   3.125        handle SAME () => R_rep_from_S_rep (fastype_of1 (Ts, t)) (to_S_rep Ts t)
   3.126    in to_F [] end
   3.127  
   3.128 -(* (typ -> int) -> int -> styp -> bound *)
   3.129  fun bound_for_free card i (s, T) =
   3.130    let val js = atom_schema_of RRep card T in
   3.131      ([((length js, i), s)],
   3.132 @@ -290,7 +273,6 @@
   3.133                     |> tuple_set_from_atom_schema])
   3.134    end
   3.135  
   3.136 -(* (typ -> int) -> typ list -> typ -> rel_expr -> formula *)
   3.137  fun declarative_axiom_for_rel_expr card Ts (Type (@{type_name fun}, [T1, T2]))
   3.138                                     r =
   3.139      if body_type T2 = bool_T then
   3.140 @@ -300,15 +282,12 @@
   3.141             declarative_axiom_for_rel_expr card (T1 :: Ts) T2
   3.142                 (List.foldl Join r (vars_for_bound_var card SRep (T1 :: Ts) 0)))
   3.143    | declarative_axiom_for_rel_expr _ _ _ r = One r
   3.144 -(* (typ -> int) -> bool -> int -> styp -> formula *)
   3.145  fun declarative_axiom_for_free card i (_, T) =
   3.146    declarative_axiom_for_rel_expr card [] T (Rel (arity_of RRep card T, i))
   3.147  
   3.148 -(* Proof.context -> (typ -> int) -> term -> problem *)
   3.149  fun kodkod_problem_from_term ctxt raw_card t =
   3.150    let
   3.151      val thy = ProofContext.theory_of ctxt
   3.152 -    (* typ -> int *)
   3.153      fun card (Type (@{type_name fun}, [T1, T2])) =
   3.154          reasonable_power (card T2) (card T1)
   3.155        | card (Type (@{type_name "*"}, [T1, T2])) = card T1 * card T2
   3.156 @@ -328,7 +307,6 @@
   3.157       bounds = bounds, int_bounds = [], expr_assigns = [], formula = formula}
   3.158    end
   3.159  
   3.160 -(* theory -> problem list -> string *)
   3.161  fun solve_any_kodkod_problem thy problems =
   3.162    let
   3.163      val {overlord, ...} = Nitpick_Isar.default_params thy []
     4.1 --- a/src/HOL/Tools/Nitpick/nitpick.ML	Sat Apr 24 16:17:30 2010 +0200
     4.2 +++ b/src/HOL/Tools/Nitpick/nitpick.ML	Sat Apr 24 16:33:01 2010 +0200
     4.3 @@ -141,7 +141,6 @@
     4.4  
     4.5  type rich_problem = KK.problem * problem_extension
     4.6  
     4.7 -(* Proof.context -> string -> term list -> Pretty.T list *)
     4.8  fun pretties_for_formulas _ _ [] = []
     4.9    | pretties_for_formulas ctxt s ts =
    4.10      [Pretty.str (s ^ plural_s_for_list ts ^ ":"),
    4.11 @@ -152,10 +151,8 @@
    4.12                                   Pretty.str (if j = 1 then "." else ";")])
    4.13                 (length ts downto 1) ts))]
    4.14  
    4.15 -(* unit -> string *)
    4.16  fun install_java_message () =
    4.17    "Nitpick requires a Java 1.5 virtual machine called \"java\"."
    4.18 -(* unit -> string *)
    4.19  fun install_kodkodi_message () =
    4.20    "Nitpick requires the external Java program Kodkodi. To install it, download \
    4.21    \the package from Isabelle's web page and add the \"kodkodi-x.y.z\" \
    4.22 @@ -167,35 +164,27 @@
    4.23  val max_unsound_delay_ms = 200
    4.24  val max_unsound_delay_percent = 2
    4.25  
    4.26 -(* Time.time option -> int *)
    4.27  fun unsound_delay_for_timeout NONE = max_unsound_delay_ms
    4.28    | unsound_delay_for_timeout (SOME timeout) =
    4.29      Int.max (0, Int.min (max_unsound_delay_ms,
    4.30                           Time.toMilliseconds timeout
    4.31                           * max_unsound_delay_percent div 100))
    4.32  
    4.33 -(* Time.time option -> bool *)
    4.34  fun passed_deadline NONE = false
    4.35    | passed_deadline (SOME time) = Time.compare (Time.now (), time) <> LESS
    4.36  
    4.37 -(* ('a * bool option) list -> bool *)
    4.38  fun none_true assigns = forall (not_equal (SOME true) o snd) assigns
    4.39  
    4.40  val syntactic_sorts =
    4.41    @{sort "{default,zero,one,plus,minus,uminus,times,inverse,abs,sgn,ord,eq}"} @
    4.42    @{sort number}
    4.43 -(* typ -> bool *)
    4.44  fun has_tfree_syntactic_sort (TFree (_, S as _ :: _)) =
    4.45      subset (op =) (S, syntactic_sorts)
    4.46    | has_tfree_syntactic_sort _ = false
    4.47 -(* term -> bool *)
    4.48  val has_syntactic_sorts = exists_type (exists_subtype has_tfree_syntactic_sort)
    4.49  
    4.50 -(* (unit -> string) -> Pretty.T *)
    4.51  fun plazy f = Pretty.blk (0, pstrs (f ()))
    4.52  
    4.53 -(* Time.time -> Proof.state -> params -> bool -> int -> int -> int
    4.54 -   -> (term * term) list -> term list -> term -> string * Proof.state *)
    4.55  fun pick_them_nits_in_term deadline state (params : params) auto i n step
    4.56                             subst orig_assm_ts orig_t =
    4.57    let
    4.58 @@ -218,7 +207,6 @@
    4.59           check_genuine, batch_size, ...} =
    4.60        params
    4.61      val state_ref = Unsynchronized.ref state
    4.62 -    (* Pretty.T -> unit *)
    4.63      val pprint =
    4.64        if auto then
    4.65          Unsynchronized.change state_ref o Proof.goal_message o K
    4.66 @@ -227,22 +215,17 @@
    4.67        else
    4.68          (fn s => (priority s; if debug then tracing s else ()))
    4.69          o Pretty.string_of
    4.70 -    (* (unit -> Pretty.T) -> unit *)
    4.71      fun pprint_m f = () |> not auto ? pprint o f
    4.72      fun pprint_v f = () |> verbose ? pprint o f
    4.73      fun pprint_d f = () |> debug ? pprint o f
    4.74 -    (* string -> unit *)
    4.75      val print = pprint o curry Pretty.blk 0 o pstrs
    4.76      val print_g = pprint o Pretty.str
    4.77 -    (* (unit -> string) -> unit *)
    4.78      val print_m = pprint_m o K o plazy
    4.79      val print_v = pprint_v o K o plazy
    4.80  
    4.81 -    (* unit -> unit *)
    4.82      fun check_deadline () =
    4.83        if debug andalso passed_deadline deadline then raise TimeLimit.TimeOut
    4.84        else ()
    4.85 -    (* unit -> 'a *)
    4.86      fun do_interrupted () =
    4.87        if passed_deadline deadline then raise TimeLimit.TimeOut
    4.88        else raise Interrupt
    4.89 @@ -307,7 +290,6 @@
    4.90      val got_all_user_axioms =
    4.91        got_all_mono_user_axioms andalso no_poly_user_axioms
    4.92  
    4.93 -    (* styp * (bool * bool) -> unit *)
    4.94      fun print_wf (x, (gfp, wf)) =
    4.95        pprint (Pretty.blk (0,
    4.96            pstrs ("The " ^ (if gfp then "co" else "") ^ "inductive predicate \"")
    4.97 @@ -344,7 +326,6 @@
    4.98  *)
    4.99  
   4.100      val unique_scope = forall (curry (op =) 1 o length o snd) cards_assigns
   4.101 -    (* typ list -> string -> string *)
   4.102      fun monotonicity_message Ts extra =
   4.103        let val ss = map (quote o string_for_type ctxt) Ts in
   4.104          "The type" ^ plural_s_for_list ss ^ " " ^
   4.105 @@ -355,7 +336,6 @@
   4.106             (if length ss = 1 then "is" else "are") ^ " considered monotonic") ^
   4.107          ". " ^ extra
   4.108        end
   4.109 -    (* typ -> bool *)
   4.110      fun is_type_fundamentally_monotonic T =
   4.111        (is_datatype thy stds T andalso not (is_quot_type thy T) andalso
   4.112         (not (is_pure_typedef thy T) orelse is_univ_typedef thy T)) orelse
   4.113 @@ -416,7 +396,6 @@
   4.114          ()
   4.115      (* This detection code is an ugly hack. Fortunately, it is used only to
   4.116         provide a hint to the user. *)
   4.117 -    (* string * (Rule_Cases.T * bool) -> bool *)
   4.118      fun is_struct_induct_step (name, (Rule_Cases.Case {fixes, assumes, ...}, _)) =
   4.119        not (null fixes) andalso
   4.120        exists (String.isSuffix ".hyps" o fst) assumes andalso
   4.121 @@ -464,7 +443,6 @@
   4.122  
   4.123      val too_big_scopes = Unsynchronized.ref []
   4.124  
   4.125 -    (* bool -> scope -> rich_problem option *)
   4.126      fun problem_for_scope unsound
   4.127              (scope as {card_assigns, bits, bisim_depth, datatypes, ofs, ...}) =
   4.128        let
   4.129 @@ -480,7 +458,6 @@
   4.130                           (Typtab.dest ofs)
   4.131  *)
   4.132          val all_exact = forall (is_exact_type datatypes true) all_Ts
   4.133 -        (* nut list -> rep NameTable.table -> nut list * rep NameTable.table *)
   4.134          val repify_consts = choose_reps_for_consts scope all_exact
   4.135          val main_j0 = offset_of_type ofs bool_T
   4.136          val (nat_card, nat_j0) = spec_of_type scope nat_T
   4.137 @@ -604,15 +581,12 @@
   4.138      val checked_problems = Unsynchronized.ref (SOME [])
   4.139      val met_potential = Unsynchronized.ref 0
   4.140  
   4.141 -    (* rich_problem list -> int list -> unit *)
   4.142      fun update_checked_problems problems =
   4.143        List.app (Unsynchronized.change checked_problems o Option.map o cons
   4.144                  o nth problems)
   4.145 -    (* string -> unit *)
   4.146      fun show_kodkod_warning "" = ()
   4.147        | show_kodkod_warning s = print_m (fn () => "Kodkod warning: " ^ s ^ ".")
   4.148  
   4.149 -    (* bool -> KK.raw_bound list -> problem_extension -> bool * bool option *)
   4.150      fun print_and_check_model genuine bounds
   4.151              ({free_names, sel_names, nonsel_names, rel_table, scope, ...}
   4.152               : problem_extension) =
   4.153 @@ -719,14 +693,11 @@
   4.154               NONE)
   4.155          |> pair genuine_means_genuine
   4.156        end
   4.157 -    (* bool * int * int * int -> bool -> rich_problem list
   4.158 -       -> bool * int * int * int *)
   4.159      fun solve_any_problem (found_really_genuine, max_potential, max_genuine,
   4.160                             donno) first_time problems =
   4.161        let
   4.162          val max_potential = Int.max (0, max_potential)
   4.163          val max_genuine = Int.max (0, max_genuine)
   4.164 -        (* bool -> int * KK.raw_bound list -> bool * bool option *)
   4.165          fun print_and_check genuine (j, bounds) =
   4.166            print_and_check_model genuine bounds (snd (nth problems j))
   4.167          val max_solutions = max_potential + max_genuine
   4.168 @@ -826,8 +797,6 @@
   4.169               (found_really_genuine, max_potential, max_genuine, donno + 1))
   4.170        end
   4.171  
   4.172 -    (* int -> int -> scope list -> bool * int * int * int
   4.173 -       -> bool * int * int * int *)
   4.174      fun run_batch j n scopes (found_really_genuine, max_potential, max_genuine,
   4.175                                donno) =
   4.176        let
   4.177 @@ -855,8 +824,6 @@
   4.178                            (length scopes downto 1) scopes))])
   4.179            else
   4.180              ()
   4.181 -        (* scope * bool -> rich_problem list * bool
   4.182 -           -> rich_problem list * bool *)
   4.183          fun add_problem_for_scope (scope, unsound) (problems, donno) =
   4.184            (check_deadline ();
   4.185             case problem_for_scope unsound scope of
   4.186 @@ -902,13 +869,10 @@
   4.187                             donno) true (rev problems)
   4.188        end
   4.189  
   4.190 -    (* rich_problem list -> scope -> int *)
   4.191      fun scope_count (problems : rich_problem list) scope =
   4.192        length (filter (curry scopes_equivalent scope o #scope o snd) problems)
   4.193 -    (* string -> string *)
   4.194      fun excipit did_so_and_so =
   4.195        let
   4.196 -        (* rich_problem list -> rich_problem list *)
   4.197          val do_filter =
   4.198            if !met_potential = max_potential then filter_out (#unsound o snd)
   4.199            else I
   4.200 @@ -930,7 +894,6 @@
   4.201             "") ^ "."
   4.202        end
   4.203  
   4.204 -    (* int -> int -> scope list -> bool * int * int * int -> KK.outcome *)
   4.205      fun run_batches _ _ []
   4.206                      (found_really_genuine, max_potential, max_genuine, donno) =
   4.207          if donno > 0 andalso max_genuine > 0 then
   4.208 @@ -996,8 +959,6 @@
   4.209             else
   4.210               error "Nitpick was interrupted."
   4.211  
   4.212 -(* Proof.state -> params -> bool -> int -> int -> int -> (term * term) list
   4.213 -   -> term list -> term -> string * Proof.state *)
   4.214  fun pick_nits_in_term state (params as {debug, timeout, expect, ...}) auto i n
   4.215                        step subst orig_assm_ts orig_t =
   4.216    if getenv "KODKODI" = "" then
   4.217 @@ -1016,12 +977,10 @@
   4.218        else error ("Unexpected outcome: " ^ quote outcome_code ^ ".")
   4.219      end
   4.220  
   4.221 -(* string list -> term -> bool *)
   4.222  fun is_fixed_equation fixes
   4.223                        (Const (@{const_name "=="}, _) $ Free (s, _) $ Const _) =
   4.224      member (op =) fixes s
   4.225    | is_fixed_equation _ _ = false
   4.226 -(* Proof.context -> term list * term -> (term * term) list * term list * term *)
   4.227  fun extract_fixed_frees ctxt (assms, t) =
   4.228    let
   4.229      val fixes = Variable.fixes_of ctxt |> map snd
   4.230 @@ -1030,7 +989,6 @@
   4.231        |>> map Logic.dest_equals
   4.232    in (subst, other_assms, subst_atomic subst t) end
   4.233  
   4.234 -(* Proof.state -> params -> bool -> int -> int -> string * Proof.state *)
   4.235  fun pick_nits_in_subgoal state params auto i step =
   4.236    let
   4.237      val ctxt = Proof.context_of state
     5.1 --- a/src/HOL/Tools/Nitpick/nitpick_hol.ML	Sat Apr 24 16:17:30 2010 +0200
     5.2 +++ b/src/HOL/Tools/Nitpick/nitpick_hol.ML	Sat Apr 24 16:33:01 2010 +0200
     5.3 @@ -293,31 +293,24 @@
     5.4  
     5.5  (** Constant/type information and term/type manipulation **)
     5.6  
     5.7 -(* int -> string *)
     5.8  fun sel_prefix_for j = sel_prefix ^ string_of_int j ^ name_sep
     5.9 -(* Proof.context -> typ -> string *)
    5.10  fun quot_normal_name_for_type ctxt T =
    5.11    quot_normal_prefix ^ unyxml (Syntax.string_of_typ ctxt T)
    5.12  
    5.13 -(* string -> string * string *)
    5.14  val strip_first_name_sep =
    5.15    Substring.full #> Substring.position name_sep ##> Substring.triml 1
    5.16    #> pairself Substring.string
    5.17 -(* string -> string *)
    5.18  fun original_name s =
    5.19    if String.isPrefix nitpick_prefix s then
    5.20      case strip_first_name_sep s of (s1, "") => s1 | (_, s2) => original_name s2
    5.21    else
    5.22      s
    5.23  
    5.24 -(* term * term -> term *)
    5.25  fun s_betapply (Const (@{const_name If}, _) $ @{const True} $ t, _) = t
    5.26    | s_betapply (Const (@{const_name If}, _) $ @{const False} $ _, t) = t
    5.27    | s_betapply p = betapply p
    5.28 -(* term * term list -> term *)
    5.29  val s_betapplys = Library.foldl s_betapply
    5.30  
    5.31 -(* term * term -> term *)
    5.32  fun s_conj (t1, @{const True}) = t1
    5.33    | s_conj (@{const True}, t2) = t2
    5.34    | s_conj (t1, t2) =
    5.35 @@ -329,18 +322,15 @@
    5.36      if t1 = @{const True} orelse t2 = @{const True} then @{const True}
    5.37      else HOLogic.mk_disj (t1, t2)
    5.38  
    5.39 -(* term -> term -> term list *)
    5.40  fun strip_connective conn_t (t as (t0 $ t1 $ t2)) =
    5.41      if t0 = conn_t then strip_connective t0 t2 @ strip_connective t0 t1 else [t]
    5.42    | strip_connective _ t = [t]
    5.43 -(* term -> term list * term *)
    5.44  fun strip_any_connective (t as (t0 $ _ $ _)) =
    5.45      if t0 = @{const "op &"} orelse t0 = @{const "op |"} then
    5.46        (strip_connective t0 t, t0)
    5.47      else
    5.48        ([t], @{const Not})
    5.49    | strip_any_connective t = ([t], @{const Not})
    5.50 -(* term -> term list *)
    5.51  val conjuncts_of = strip_connective @{const "op &"}
    5.52  val disjuncts_of = strip_connective @{const "op |"}
    5.53  
    5.54 @@ -415,7 +405,6 @@
    5.55     (@{const_name minus_class.minus}, 2),
    5.56     (@{const_name ord_class.less_eq}, 2)]
    5.57  
    5.58 -(* typ -> typ *)
    5.59  fun unarize_type @{typ "unsigned_bit word"} = nat_T
    5.60    | unarize_type @{typ "signed_bit word"} = int_T
    5.61    | unarize_type (Type (s, Ts as _ :: _)) = Type (s, map unarize_type Ts)
    5.62 @@ -436,44 +425,33 @@
    5.63    | uniterize_type T = T
    5.64  val uniterize_unarize_unbox_etc_type = uniterize_type o unarize_unbox_etc_type
    5.65  
    5.66 -(* Proof.context -> typ -> string *)
    5.67  fun string_for_type ctxt = Syntax.string_of_typ ctxt o unarize_unbox_etc_type
    5.68  
    5.69 -(* string -> string -> string *)
    5.70  val prefix_name = Long_Name.qualify o Long_Name.base_name
    5.71 -(* string -> string *)
    5.72  fun shortest_name s = List.last (space_explode "." s) handle List.Empty => ""
    5.73 -(* string -> term -> term *)
    5.74  val prefix_abs_vars = Term.map_abs_vars o prefix_name
    5.75 -(* string -> string *)
    5.76  fun short_name s =
    5.77    case space_explode name_sep s of
    5.78      [_] => s |> String.isPrefix nitpick_prefix s ? unprefix nitpick_prefix
    5.79    | ss => map shortest_name ss |> space_implode "_"
    5.80 -(* typ -> typ *)
    5.81  fun shorten_names_in_type (Type (s, Ts)) =
    5.82      Type (short_name s, map shorten_names_in_type Ts)
    5.83    | shorten_names_in_type T = T
    5.84 -(* term -> term *)
    5.85  val shorten_names_in_term =
    5.86    map_aterms (fn Const (s, T) => Const (short_name s, T) | t => t)
    5.87    #> map_types shorten_names_in_type
    5.88  
    5.89 -(* theory -> typ * typ -> bool *)
    5.90  fun strict_type_match thy (T1, T2) =
    5.91    (Sign.typ_match thy (T2, T1) Vartab.empty; true)
    5.92    handle Type.TYPE_MATCH => false
    5.93  fun type_match thy = strict_type_match thy o pairself unarize_unbox_etc_type
    5.94 -(* theory -> styp * styp -> bool *)
    5.95  fun const_match thy ((s1, T1), (s2, T2)) =
    5.96    s1 = s2 andalso type_match thy (T1, T2)
    5.97 -(* theory -> term * term -> bool *)
    5.98  fun term_match thy (Const x1, Const x2) = const_match thy (x1, x2)
    5.99    | term_match thy (Free (s1, T1), Free (s2, T2)) =
   5.100      const_match thy ((shortest_name s1, T1), (shortest_name s2, T2))
   5.101    | term_match _ (t1, t2) = t1 aconv t2
   5.102  
   5.103 -(* typ -> term -> term -> term *)
   5.104  fun frac_from_term_pair T t1 t2 =
   5.105    case snd (HOLogic.dest_number t1) of
   5.106      0 => HOLogic.mk_number T 0
   5.107 @@ -482,7 +460,6 @@
   5.108            | n2 => Const (@{const_name divide}, T --> T --> T)
   5.109                    $ HOLogic.mk_number T n1 $ HOLogic.mk_number T n2
   5.110  
   5.111 -(* typ -> bool *)
   5.112  fun is_TFree (TFree _) = true
   5.113    | is_TFree _ = false
   5.114  fun is_higher_order_type (Type (@{type_name fun}, _)) = true
   5.115 @@ -508,50 +485,41 @@
   5.116    | is_word_type _ = false
   5.117  val is_integer_like_type = is_iterator_type orf is_integer_type orf is_word_type
   5.118  val is_record_type = not o null o Record.dest_recTs
   5.119 -(* theory -> typ -> bool *)
   5.120  fun is_frac_type thy (Type (s, [])) =
   5.121      not (null (these (AList.lookup (op =) (#frac_types (Data.get thy)) s)))
   5.122    | is_frac_type _ _ = false
   5.123  fun is_number_type thy = is_integer_like_type orf is_frac_type thy
   5.124  
   5.125 -(* bool -> styp -> typ *)
   5.126  fun iterator_type_for_const gfp (s, T) =
   5.127    Type ((if gfp then gfp_iterator_prefix else lfp_iterator_prefix) ^ s,
   5.128          binder_types T)
   5.129 -(* typ -> styp *)
   5.130  fun const_for_iterator_type (Type (s, Ts)) =
   5.131      (strip_first_name_sep s |> snd, Ts ---> bool_T)
   5.132    | const_for_iterator_type T =
   5.133      raise TYPE ("Nitpick_HOL.const_for_iterator_type", [T], [])
   5.134  
   5.135 -(* int -> typ -> typ list * typ *)
   5.136  fun strip_n_binders 0 T = ([], T)
   5.137    | strip_n_binders n (Type (@{type_name fun}, [T1, T2])) =
   5.138      strip_n_binders (n - 1) T2 |>> cons T1
   5.139    | strip_n_binders n (Type (@{type_name fun_box}, Ts)) =
   5.140      strip_n_binders n (Type (@{type_name fun}, Ts))
   5.141    | strip_n_binders _ T = raise TYPE ("Nitpick_HOL.strip_n_binders", [T], [])
   5.142 -(* typ -> typ *)
   5.143  val nth_range_type = snd oo strip_n_binders
   5.144  
   5.145 -(* typ -> int *)
   5.146  fun num_factors_in_type (Type (@{type_name "*"}, [T1, T2])) =
   5.147      fold (Integer.add o num_factors_in_type) [T1, T2] 0
   5.148    | num_factors_in_type _ = 1
   5.149  fun num_binder_types (Type (@{type_name fun}, [_, T2])) =
   5.150      1 + num_binder_types T2
   5.151    | num_binder_types _ = 0
   5.152 -(* typ -> typ list *)
   5.153  val curried_binder_types = maps HOLogic.flatten_tupleT o binder_types
   5.154  fun maybe_curried_binder_types T =
   5.155    (if is_pair_type (body_type T) then binder_types else curried_binder_types) T
   5.156  
   5.157 -(* typ -> term list -> term *)
   5.158  fun mk_flat_tuple _ [t] = t
   5.159    | mk_flat_tuple (Type (@{type_name "*"}, [T1, T2])) (t :: ts) =
   5.160      HOLogic.pair_const T1 T2 $ t $ (mk_flat_tuple T2 ts)
   5.161    | mk_flat_tuple T ts = raise TYPE ("Nitpick_HOL.mk_flat_tuple", [T], ts)
   5.162 -(* int -> term -> term list *)
   5.163  fun dest_n_tuple 1 t = [t]
   5.164    | dest_n_tuple n t = HOLogic.dest_prod t ||> dest_n_tuple (n - 1) |> op ::
   5.165  
   5.166 @@ -560,7 +528,6 @@
   5.167     set_def: thm option, prop_of_Rep: thm, set_name: string,
   5.168     Abs_inverse: thm option, Rep_inverse: thm option}
   5.169  
   5.170 -(* theory -> string -> typedef_info *)
   5.171  fun typedef_info thy s =
   5.172    if is_frac_type thy (Type (s, [])) then
   5.173      SOME {abs_type = Type (s, []), rep_type = @{typ "int * int"},
   5.174 @@ -578,21 +545,17 @@
   5.175            Rep_inverse = SOME Rep_inverse}
   5.176    | _ => NONE
   5.177  
   5.178 -(* theory -> string -> bool *)
   5.179  val is_typedef = is_some oo typedef_info
   5.180  val is_real_datatype = is_some oo Datatype.get_info
   5.181 -(* theory -> (typ option * bool) list -> typ -> bool *)
   5.182  fun is_standard_datatype thy = the oo triple_lookup (type_match thy)
   5.183  
   5.184  (* FIXME: Use antiquotation for "code_numeral" below or detect "rep_datatype",
   5.185     e.g., by adding a field to "Datatype_Aux.info". *)
   5.186 -(* theory -> (typ option * bool) list -> string -> bool *)
   5.187  fun is_basic_datatype thy stds s =
   5.188    member (op =) [@{type_name "*"}, @{type_name bool}, @{type_name unit},
   5.189                   @{type_name int}, "Code_Numeral.code_numeral"] s orelse
   5.190    (s = @{type_name nat} andalso is_standard_datatype thy stds nat_T)
   5.191  
   5.192 -(* theory -> typ -> typ -> typ -> typ *)
   5.193  fun instantiate_type thy T1 T1' T2 =
   5.194    Same.commit (Envir.subst_type_same
   5.195                     (Sign.typ_match thy (T1, T1') Vartab.empty)) T2
   5.196 @@ -601,20 +564,16 @@
   5.197  fun varify_and_instantiate_type thy T1 T1' T2 =
   5.198    instantiate_type thy (Logic.varifyT_global T1) T1' (Logic.varifyT_global T2)
   5.199  
   5.200 -(* theory -> typ -> typ -> styp *)
   5.201  fun repair_constr_type thy body_T' T =
   5.202    varify_and_instantiate_type thy (body_type T) body_T' T
   5.203  
   5.204 -(* string -> (string * string) list -> theory -> theory *)
   5.205  fun register_frac_type frac_s ersaetze thy =
   5.206    let
   5.207      val {frac_types, codatatypes} = Data.get thy
   5.208      val frac_types = AList.update (op =) (frac_s, ersaetze) frac_types
   5.209    in Data.put {frac_types = frac_types, codatatypes = codatatypes} thy end
   5.210 -(* string -> theory -> theory *)
   5.211  fun unregister_frac_type frac_s = register_frac_type frac_s []
   5.212  
   5.213 -(* typ -> string -> styp list -> theory -> theory *)
   5.214  fun register_codatatype co_T case_name constr_xs thy =
   5.215    let
   5.216      val {frac_types, codatatypes} = Data.get thy
   5.217 @@ -630,10 +589,8 @@
   5.218      val codatatypes = AList.update (op =) (co_s, (case_name, constr_xs))
   5.219                                     codatatypes
   5.220    in Data.put {frac_types = frac_types, codatatypes = codatatypes} thy end
   5.221 -(* typ -> theory -> theory *)
   5.222  fun unregister_codatatype co_T = register_codatatype co_T "" []
   5.223  
   5.224 -(* theory -> typ -> bool *)
   5.225  fun is_quot_type thy (Type (s, _)) =
   5.226      is_some (Quotient_Info.quotdata_lookup_raw thy s)
   5.227    | is_quot_type _ _ = false
   5.228 @@ -670,32 +627,26 @@
   5.229         end
   5.230       | NONE => false)
   5.231    | is_univ_typedef _ _ = false
   5.232 -(* theory -> (typ option * bool) list -> typ -> bool *)
   5.233  fun is_datatype thy stds (T as Type (s, _)) =
   5.234      (is_typedef thy s orelse is_codatatype thy T orelse T = @{typ ind} orelse
   5.235       is_quot_type thy T) andalso not (is_basic_datatype thy stds s)
   5.236    | is_datatype _ _ _ = false
   5.237  
   5.238 -(* theory -> typ -> (string * typ) list * (string * typ) *)
   5.239  fun all_record_fields thy T =
   5.240    let val (recs, more) = Record.get_extT_fields thy T in
   5.241      recs @ more :: all_record_fields thy (snd more)
   5.242    end
   5.243    handle TYPE _ => []
   5.244 -(* styp -> bool *)
   5.245  fun is_record_constr (s, T) =
   5.246    String.isSuffix Record.extN s andalso
   5.247    let val dataT = body_type T in
   5.248      is_record_type dataT andalso
   5.249      s = unsuffix Record.ext_typeN (fst (dest_Type dataT)) ^ Record.extN
   5.250    end
   5.251 -(* theory -> typ -> int *)
   5.252  val num_record_fields = Integer.add 1 o length o fst oo Record.get_extT_fields
   5.253 -(* theory -> string -> typ -> int *)
   5.254  fun no_of_record_field thy s T1 =
   5.255    find_index (curry (op =) s o fst)
   5.256               (Record.get_extT_fields thy T1 ||> single |> op @)
   5.257 -(* theory -> styp -> bool *)
   5.258  fun is_record_get thy (s, Type (@{type_name fun}, [T1, _])) =
   5.259      exists (curry (op =) s o fst) (all_record_fields thy T1)
   5.260    | is_record_get _ _ = false
   5.261 @@ -714,7 +665,6 @@
   5.262         SOME {Rep_name, ...} => s = Rep_name
   5.263       | NONE => false)
   5.264    | is_rep_fun _ _ = false
   5.265 -(* Proof.context -> styp -> bool *)
   5.266  fun is_quot_abs_fun ctxt
   5.267                      (x as (_, Type (@{type_name fun}, [_, Type (s', _)]))) =
   5.268      (try (Quotient_Term.absrep_const_chk Quotient_Term.AbsF ctxt) s'
   5.269 @@ -726,19 +676,16 @@
   5.270       = SOME (Const x))
   5.271    | is_quot_rep_fun _ _ = false
   5.272  
   5.273 -(* theory -> styp -> styp *)
   5.274  fun mate_of_rep_fun thy (x as (_, Type (@{type_name fun},
   5.275                                          [T1 as Type (s', _), T2]))) =
   5.276      (case typedef_info thy s' of
   5.277         SOME {Abs_name, ...} => (Abs_name, Type (@{type_name fun}, [T2, T1]))
   5.278       | NONE => raise TERM ("Nitpick_HOL.mate_of_rep_fun", [Const x]))
   5.279    | mate_of_rep_fun _ x = raise TERM ("Nitpick_HOL.mate_of_rep_fun", [Const x])
   5.280 -(* theory -> typ -> typ *)
   5.281  fun rep_type_for_quot_type thy (T as Type (s, _)) =
   5.282    let val {qtyp, rtyp, ...} = Quotient_Info.quotdata_lookup thy s in
   5.283      instantiate_type thy qtyp T rtyp
   5.284    end
   5.285 -(* theory -> typ -> term *)
   5.286  fun equiv_relation_for_quot_type thy (Type (s, Ts)) =
   5.287      let
   5.288        val {qtyp, equiv_rel, ...} = Quotient_Info.quotdata_lookup thy s
   5.289 @@ -747,7 +694,6 @@
   5.290    | equiv_relation_for_quot_type _ T =
   5.291      raise TYPE ("Nitpick_HOL.equiv_relation_for_quot_type", [T], [])
   5.292  
   5.293 -(* theory -> styp -> bool *)
   5.294  fun is_coconstr thy (s, T) =
   5.295    let
   5.296      val {codatatypes, ...} = Data.get thy
   5.297 @@ -770,19 +716,16 @@
   5.298  fun is_stale_constr thy (x as (_, T)) =
   5.299    is_codatatype thy (body_type T) andalso is_constr_like thy x andalso
   5.300    not (is_coconstr thy x)
   5.301 -(* theory -> (typ option * bool) list -> styp -> bool *)
   5.302  fun is_constr thy stds (x as (_, T)) =
   5.303    is_constr_like thy x andalso
   5.304    not (is_basic_datatype thy stds
   5.305                           (fst (dest_Type (unarize_type (body_type T))))) andalso
   5.306    not (is_stale_constr thy x)
   5.307 -(* string -> bool *)
   5.308  val is_sel = String.isPrefix discr_prefix orf String.isPrefix sel_prefix
   5.309  val is_sel_like_and_no_discr =
   5.310    String.isPrefix sel_prefix orf
   5.311    (member (op =) [@{const_name fst}, @{const_name snd}])
   5.312  
   5.313 -(* boxability -> boxability *)
   5.314  fun in_fun_lhs_for InConstr = InSel
   5.315    | in_fun_lhs_for _ = InFunLHS
   5.316  fun in_fun_rhs_for InConstr = InConstr
   5.317 @@ -790,7 +733,6 @@
   5.318    | in_fun_rhs_for InFunRHS1 = InFunRHS2
   5.319    | in_fun_rhs_for _ = InFunRHS1
   5.320  
   5.321 -(* hol_context -> boxability -> typ -> bool *)
   5.322  fun is_boxing_worth_it (hol_ctxt : hol_context) boxy T =
   5.323    case T of
   5.324      Type (@{type_name fun}, _) =>
   5.325 @@ -802,12 +744,10 @@
   5.326       exists (is_boxing_worth_it hol_ctxt InPair)
   5.327              (map (box_type hol_ctxt InPair) Ts))
   5.328    | _ => false
   5.329 -(* hol_context -> boxability -> string * typ list -> string *)
   5.330  and should_box_type (hol_ctxt as {thy, boxes, ...}) boxy z =
   5.331    case triple_lookup (type_match thy) boxes (Type z) of
   5.332      SOME (SOME box_me) => box_me
   5.333    | _ => is_boxing_worth_it hol_ctxt boxy (Type z)
   5.334 -(* hol_context -> boxability -> typ -> typ *)
   5.335  and box_type hol_ctxt boxy T =
   5.336    case T of
   5.337      Type (z as (@{type_name fun}, [T1, T2])) =>
   5.338 @@ -829,37 +769,29 @@
   5.339                             else InPair)) Ts)
   5.340    | _ => T
   5.341  
   5.342 -(* typ -> typ *)
   5.343  fun binarize_nat_and_int_in_type @{typ nat} = @{typ "unsigned_bit word"}
   5.344    | binarize_nat_and_int_in_type @{typ int} = @{typ "signed_bit word"}
   5.345    | binarize_nat_and_int_in_type (Type (s, Ts)) =
   5.346      Type (s, map binarize_nat_and_int_in_type Ts)
   5.347    | binarize_nat_and_int_in_type T = T
   5.348 -(* term -> term *)
   5.349  val binarize_nat_and_int_in_term = map_types binarize_nat_and_int_in_type
   5.350  
   5.351 -(* styp -> styp *)
   5.352  fun discr_for_constr (s, T) = (discr_prefix ^ s, body_type T --> bool_T)
   5.353  
   5.354 -(* typ -> int *)
   5.355  fun num_sels_for_constr_type T = length (maybe_curried_binder_types T)
   5.356 -(* string -> int -> string *)
   5.357  fun nth_sel_name_for_constr_name s n =
   5.358    if s = @{const_name Pair} then
   5.359      if n = 0 then @{const_name fst} else @{const_name snd}
   5.360    else
   5.361      sel_prefix_for n ^ s
   5.362 -(* styp -> int -> styp *)
   5.363  fun nth_sel_for_constr x ~1 = discr_for_constr x
   5.364    | nth_sel_for_constr (s, T) n =
   5.365      (nth_sel_name_for_constr_name s n,
   5.366       body_type T --> nth (maybe_curried_binder_types T) n)
   5.367 -(* hol_context -> bool -> styp -> int -> styp *)
   5.368  fun binarized_and_boxed_nth_sel_for_constr hol_ctxt binarize =
   5.369    apsnd ((binarize ? binarize_nat_and_int_in_type) o box_type hol_ctxt InSel)
   5.370    oo nth_sel_for_constr
   5.371  
   5.372 -(* string -> int *)
   5.373  fun sel_no_from_name s =
   5.374    if String.isPrefix discr_prefix s then
   5.375      ~1
   5.376 @@ -870,15 +802,12 @@
   5.377    else
   5.378      0
   5.379  
   5.380 -(* term -> term *)
   5.381  val close_form =
   5.382    let
   5.383 -    (* (indexname * typ) list -> (indexname * typ) list -> term -> term *)
   5.384      fun close_up zs zs' =
   5.385        fold (fn (z as ((s, _), T)) => fn t' =>
   5.386                 Term.all T $ Abs (s, T, abstract_over (Var z, t')))
   5.387             (take (length zs' - length zs) zs')
   5.388 -    (* (indexname * typ) list -> term -> term *)
   5.389      fun aux zs (@{const "==>"} $ t1 $ t2) =
   5.390          let val zs' = Term.add_vars t1 zs in
   5.391            close_up zs zs' (Logic.mk_implies (t1, aux zs' t2))
   5.392 @@ -886,7 +815,6 @@
   5.393        | aux zs t = close_up zs (Term.add_vars t zs) t
   5.394    in aux [] end
   5.395  
   5.396 -(* typ list -> term -> int -> term *)
   5.397  fun eta_expand _ t 0 = t
   5.398    | eta_expand Ts (Abs (s, T, t')) n =
   5.399      Abs (s, T, eta_expand (T :: Ts) t' (n - 1))
   5.400 @@ -895,7 +823,6 @@
   5.401               (List.take (binder_types (fastype_of1 (Ts, t)), n))
   5.402               (list_comb (incr_boundvars n t, map Bound (n - 1 downto 0)))
   5.403  
   5.404 -(* term -> term *)
   5.405  fun extensionalize t =
   5.406    case t of
   5.407      (t0 as @{const Trueprop}) $ t1 => t0 $ extensionalize t1
   5.408 @@ -905,17 +832,14 @@
   5.409      end
   5.410    | _ => t
   5.411  
   5.412 -(* typ -> term list -> term *)
   5.413  fun distinctness_formula T =
   5.414    all_distinct_unordered_pairs_of
   5.415    #> map (fn (t1, t2) => @{const Not} $ (HOLogic.eq_const T $ t1 $ t2))
   5.416    #> List.foldr (s_conj o swap) @{const True}
   5.417  
   5.418 -(* typ -> term *)
   5.419  fun zero_const T = Const (@{const_name zero_class.zero}, T)
   5.420  fun suc_const T = Const (@{const_name Suc}, T --> T)
   5.421  
   5.422 -(* hol_context -> typ -> styp list *)
   5.423  fun uncached_datatype_constrs ({thy, stds, ...} : hol_context)
   5.424                                (T as Type (s, Ts)) =
   5.425      (case AList.lookup (op =) (#codatatypes (Data.get thy)) s of
   5.426 @@ -952,7 +876,6 @@
   5.427         else
   5.428           [])
   5.429    | uncached_datatype_constrs _ _ = []
   5.430 -(* hol_context -> typ -> styp list *)
   5.431  fun datatype_constrs (hol_ctxt as {constr_cache, ...}) T =
   5.432    case AList.lookup (op =) (!constr_cache) T of
   5.433      SOME xs => xs
   5.434 @@ -960,18 +883,14 @@
   5.435      let val xs = uncached_datatype_constrs hol_ctxt T in
   5.436        (Unsynchronized.change constr_cache (cons (T, xs)); xs)
   5.437      end
   5.438 -(* hol_context -> bool -> typ -> styp list *)
   5.439  fun binarized_and_boxed_datatype_constrs hol_ctxt binarize =
   5.440    map (apsnd ((binarize ? binarize_nat_and_int_in_type)
   5.441                o box_type hol_ctxt InConstr)) o datatype_constrs hol_ctxt
   5.442 -(* hol_context -> typ -> int *)
   5.443  val num_datatype_constrs = length oo datatype_constrs
   5.444  
   5.445 -(* string -> string *)
   5.446  fun constr_name_for_sel_like @{const_name fst} = @{const_name Pair}
   5.447    | constr_name_for_sel_like @{const_name snd} = @{const_name Pair}
   5.448    | constr_name_for_sel_like s' = original_name s'
   5.449 -(* hol_context -> bool -> styp -> styp *)
   5.450  fun binarized_and_boxed_constr_for_sel hol_ctxt binarize (s', T') =
   5.451    let val s = constr_name_for_sel_like s' in
   5.452      AList.lookup (op =)
   5.453 @@ -980,7 +899,6 @@
   5.454      |> the |> pair s
   5.455    end
   5.456  
   5.457 -(* hol_context -> styp -> term *)
   5.458  fun discr_term_for_constr hol_ctxt (x as (s, T)) =
   5.459    let val dataT = body_type T in
   5.460      if s = @{const_name Suc} then
   5.461 @@ -991,7 +909,6 @@
   5.462      else
   5.463        Abs (Name.uu, dataT, @{const True})
   5.464    end
   5.465 -(* hol_context -> styp -> term -> term *)
   5.466  fun discriminate_value (hol_ctxt as {thy, ...}) x t =
   5.467    case head_of t of
   5.468      Const x' =>
   5.469 @@ -1000,7 +917,6 @@
   5.470      else betapply (discr_term_for_constr hol_ctxt x, t)
   5.471    | _ => betapply (discr_term_for_constr hol_ctxt x, t)
   5.472  
   5.473 -(* theory -> (typ option * bool) list -> styp -> term -> term *)
   5.474  fun nth_arg_sel_term_for_constr thy stds (x as (s, T)) n =
   5.475    let val (arg_Ts, dataT) = strip_type T in
   5.476      if dataT = nat_T andalso is_standard_datatype thy stds nat_T then
   5.477 @@ -1009,7 +925,6 @@
   5.478        Const (nth_sel_for_constr x n)
   5.479      else
   5.480        let
   5.481 -        (* int -> typ -> int * term *)
   5.482          fun aux m (Type (@{type_name "*"}, [T1, T2])) =
   5.483              let
   5.484                val (m, t1) = aux m T1
   5.485 @@ -1022,7 +937,6 @@
   5.486                       (List.take (arg_Ts, n)) 0
   5.487        in Abs ("x", dataT, aux m (nth arg_Ts n) |> snd) end
   5.488    end
   5.489 -(* theory -> (typ option * bool) list -> styp -> term -> int -> typ -> term *)
   5.490  fun select_nth_constr_arg thy stds x t n res_T =
   5.491    (case strip_comb t of
   5.492       (Const x', args) =>
   5.493 @@ -1032,7 +946,6 @@
   5.494     | _ => raise SAME())
   5.495    handle SAME () => betapply (nth_arg_sel_term_for_constr thy stds x n, t)
   5.496  
   5.497 -(* theory -> (typ option * bool) list -> styp -> term list -> term *)
   5.498  fun construct_value _ _ x [] = Const x
   5.499    | construct_value thy stds (x as (s, _)) args =
   5.500      let val args = map Envir.eta_contract args in
   5.501 @@ -1049,7 +962,6 @@
   5.502        | _ => list_comb (Const x, args)
   5.503      end
   5.504  
   5.505 -(* hol_context -> typ -> term -> term *)
   5.506  fun constr_expand (hol_ctxt as {thy, stds, ...}) T t =
   5.507    (case head_of t of
   5.508       Const x => if is_constr_like thy x then t else raise SAME ()
   5.509 @@ -1069,17 +981,14 @@
   5.510                                       (index_seq 0 (length arg_Ts)) arg_Ts)
   5.511           end
   5.512  
   5.513 -(* (term -> term) -> int -> term -> term *)
   5.514  fun coerce_bound_no f j t =
   5.515    case t of
   5.516      t1 $ t2 => coerce_bound_no f j t1 $ coerce_bound_no f j t2
   5.517    | Abs (s, T, t') => Abs (s, T, coerce_bound_no f (j + 1) t')
   5.518    | Bound j' => if j' = j then f t else t
   5.519    | _ => t
   5.520 -(* hol_context -> typ -> typ -> term -> term *)
   5.521  fun coerce_bound_0_in_term hol_ctxt new_T old_T =
   5.522    old_T <> new_T ? coerce_bound_no (coerce_term hol_ctxt [new_T] old_T new_T) 0
   5.523 -(* hol_context -> typ list -> typ -> typ -> term -> term *)
   5.524  and coerce_term (hol_ctxt as {thy, stds, fast_descrs, ...}) Ts new_T old_T t =
   5.525    if old_T = new_T then
   5.526      t
   5.527 @@ -1124,7 +1033,6 @@
   5.528          raise TYPE ("Nitpick_HOL.coerce_term", [new_T, old_T], [t])
   5.529      | _ => raise TYPE ("Nitpick_HOL.coerce_term", [new_T, old_T], [t])
   5.530  
   5.531 -(* (typ * int) list -> typ -> int *)
   5.532  fun card_of_type assigns (Type (@{type_name fun}, [T1, T2])) =
   5.533      reasonable_power (card_of_type assigns T2) (card_of_type assigns T1)
   5.534    | card_of_type assigns (Type (@{type_name "*"}, [T1, T2])) =
   5.535 @@ -1138,7 +1046,6 @@
   5.536        SOME k => k
   5.537      | NONE => if T = @{typ bisim_iterator} then 0
   5.538                else raise TYPE ("Nitpick_HOL.card_of_type", [T], [])
   5.539 -(* int -> (typ * int) list -> typ -> int *)
   5.540  fun bounded_card_of_type max default_card assigns
   5.541                           (Type (@{type_name fun}, [T1, T2])) =
   5.542      let
   5.543 @@ -1161,11 +1068,9 @@
   5.544                      card_of_type assigns T
   5.545                      handle TYPE ("Nitpick_HOL.card_of_type", _, _) =>
   5.546                             default_card)
   5.547 -(* hol_context -> typ list -> int -> (typ * int) list -> typ -> int *)
   5.548  fun bounded_exact_card_of_type hol_ctxt finitizable_dataTs max default_card
   5.549                                 assigns T =
   5.550    let
   5.551 -    (* typ list -> typ -> int *)
   5.552      fun aux avoid T =
   5.553        (if member (op =) avoid T then
   5.554           0
   5.555 @@ -1214,47 +1119,36 @@
   5.556  
   5.557  val small_type_max_card = 5
   5.558  
   5.559 -(* hol_context -> typ -> bool *)
   5.560  fun is_finite_type hol_ctxt T =
   5.561    bounded_exact_card_of_type hol_ctxt [] 1 2 [] T > 0
   5.562 -(* hol_context -> typ -> bool *)
   5.563  fun is_small_finite_type hol_ctxt T =
   5.564    let val n = bounded_exact_card_of_type hol_ctxt [] 1 2 [] T in
   5.565      n > 0 andalso n <= small_type_max_card
   5.566    end
   5.567  
   5.568 -(* term -> bool *)
   5.569  fun is_ground_term (t1 $ t2) = is_ground_term t1 andalso is_ground_term t2
   5.570    | is_ground_term (Const _) = true
   5.571    | is_ground_term _ = false
   5.572  
   5.573 -(* term -> word -> word *)
   5.574  fun hashw_term (t1 $ t2) = hashw (hashw_term t1, hashw_term t2)
   5.575    | hashw_term (Const (s, _)) = hashw_string (s, 0w0)
   5.576    | hashw_term _ = 0w0
   5.577 -(* term -> int *)
   5.578  val hash_term = Word.toInt o hashw_term
   5.579  
   5.580 -(* term list -> (indexname * typ) list *)
   5.581  fun special_bounds ts =
   5.582    fold Term.add_vars ts [] |> sort (Term_Ord.fast_indexname_ord o pairself fst)
   5.583  
   5.584 -(* indexname * typ -> term -> term *)
   5.585  fun abs_var ((s, j), T) body = Abs (s, T, abstract_over (Var ((s, j), T), body))
   5.586  
   5.587 -(* theory -> string -> bool *)
   5.588  fun is_funky_typedef_name thy s =
   5.589    member (op =) [@{type_name unit}, @{type_name "*"}, @{type_name "+"},
   5.590                   @{type_name int}] s orelse
   5.591    is_frac_type thy (Type (s, []))
   5.592 -(* theory -> typ -> bool *)
   5.593  fun is_funky_typedef thy (Type (s, _)) = is_funky_typedef_name thy s
   5.594    | is_funky_typedef _ _ = false
   5.595 -(* term -> bool *)
   5.596  fun is_arity_type_axiom (Const (@{const_name HOL.type_class}, _)
   5.597                           $ Const (@{const_name TYPE}, _)) = true
   5.598    | is_arity_type_axiom _ = false
   5.599 -(* theory -> bool -> term -> bool *)
   5.600  fun is_typedef_axiom thy boring (@{const "==>"} $ _ $ t2) =
   5.601      is_typedef_axiom thy boring t2
   5.602    | is_typedef_axiom thy boring
   5.603 @@ -1263,7 +1157,6 @@
   5.604           $ Const _ $ _)) =
   5.605      boring <> is_funky_typedef_name thy s andalso is_typedef thy s
   5.606    | is_typedef_axiom _ _ _ = false
   5.607 -(* term -> bool *)
   5.608  val is_class_axiom =
   5.609    Logic.strip_horn #> swap #> op :: #> forall (can Logic.dest_of_class)
   5.610  
   5.611 @@ -1271,7 +1164,6 @@
   5.612     typedef axioms, and (3) other axioms, and returns the pair ((1), (3)).
   5.613     Typedef axioms are uninteresting to Nitpick, because it can retrieve them
   5.614     using "typedef_info". *)
   5.615 -(* theory -> (string * term) list -> string list -> term list * term list *)
   5.616  fun partition_axioms_by_definitionality thy axioms def_names =
   5.617    let
   5.618      val axioms = sort (fast_string_ord o pairself fst) axioms
   5.619 @@ -1284,15 +1176,12 @@
   5.620  (* Ideally we would check against "Complex_Main", not "Refute", but any theory
   5.621     will do as long as it contains all the "axioms" and "axiomatization"
   5.622     commands. *)
   5.623 -(* theory -> bool *)
   5.624  fun is_built_in_theory thy = Theory.subthy (thy, @{theory Refute})
   5.625  
   5.626 -(* term -> bool *)
   5.627  val is_trivial_definition =
   5.628    the_default false o try (op aconv o Logic.dest_equals)
   5.629  val is_plain_definition =
   5.630    let
   5.631 -    (* term -> bool *)
   5.632      fun do_lhs t1 =
   5.633        case strip_comb t1 of
   5.634          (Const _, args) =>
   5.635 @@ -1304,10 +1193,8 @@
   5.636        | do_eq _ = false
   5.637    in do_eq end
   5.638  
   5.639 -(* theory -> (term * term) list -> term list * term list * term list *)
   5.640  fun all_axioms_of thy subst =
   5.641    let
   5.642 -    (* theory list -> term list *)
   5.643      val axioms_of_thys =
   5.644        maps Thm.axioms_of
   5.645        #> map (apsnd (subst_atomic subst o prop_of))
   5.646 @@ -1336,7 +1223,6 @@
   5.647        user_defs @ built_in_defs
   5.648    in (defs, built_in_nondefs, user_nondefs) end
   5.649  
   5.650 -(* theory -> (typ option * bool) list -> bool -> styp -> int option *)
   5.651  fun arity_of_built_in_const thy stds fast_descrs (s, T) =
   5.652    if s = @{const_name If} then
   5.653      if nth_range_type 3 T = @{typ bool} then NONE else SOME 3
   5.654 @@ -1364,12 +1250,10 @@
   5.655                   else
   5.656                     NONE
   5.657      end
   5.658 -(* theory -> (typ option * bool) list -> bool -> styp -> bool *)
   5.659  val is_built_in_const = is_some oooo arity_of_built_in_const
   5.660  
   5.661  (* This function is designed to work for both real definition axioms and
   5.662     simplification rules (equational specifications). *)
   5.663 -(* term -> term *)
   5.664  fun term_under_def t =
   5.665    case t of
   5.666      @{const "==>"} $ _ $ t2 => term_under_def t2
   5.667 @@ -1383,8 +1267,6 @@
   5.668  (* Here we crucially rely on "Refute.specialize_type" performing a preorder
   5.669     traversal of the term, without which the wrong occurrence of a constant could
   5.670     be matched in the face of overloading. *)
   5.671 -(* theory -> (typ option * bool) list -> bool -> const_table -> styp
   5.672 -   -> term list *)
   5.673  fun def_props_for_const thy stds fast_descrs table (x as (s, _)) =
   5.674    if is_built_in_const thy stds fast_descrs x then
   5.675      []
   5.676 @@ -1393,10 +1275,8 @@
   5.677      |> map_filter (try (Refute.specialize_type thy x))
   5.678      |> filter (curry (op =) (Const x) o term_under_def)
   5.679  
   5.680 -(* term -> term option *)
   5.681  fun normalized_rhs_of t =
   5.682    let
   5.683 -    (* term option -> term option *)
   5.684      fun aux (v as Var _) (SOME t) = SOME (lambda v t)
   5.685        | aux (c as Const (@{const_name TYPE}, _)) (SOME t) = SOME (lambda c t)
   5.686        | aux _ _ = NONE
   5.687 @@ -1409,7 +1289,6 @@
   5.688      val args = strip_comb lhs |> snd
   5.689    in fold_rev aux args (SOME rhs) end
   5.690  
   5.691 -(* theory -> const_table -> styp -> term option *)
   5.692  fun def_of_const thy table (x as (s, _)) =
   5.693    if is_built_in_const thy [(NONE, false)] false x orelse
   5.694       original_name s <> s then
   5.695 @@ -1419,16 +1298,13 @@
   5.696        |> normalized_rhs_of |> Option.map (prefix_abs_vars s)
   5.697      handle List.Empty => NONE
   5.698  
   5.699 -(* term -> fixpoint_kind *)
   5.700  fun fixpoint_kind_of_rhs (Abs (_, _, t)) = fixpoint_kind_of_rhs t
   5.701    | fixpoint_kind_of_rhs (Const (@{const_name lfp}, _) $ Abs _) = Lfp
   5.702    | fixpoint_kind_of_rhs (Const (@{const_name gfp}, _) $ Abs _) = Gfp
   5.703    | fixpoint_kind_of_rhs _ = NoFp
   5.704  
   5.705 -(* theory -> const_table -> term -> bool *)
   5.706  fun is_mutually_inductive_pred_def thy table t =
   5.707    let
   5.708 -    (* term -> bool *)
   5.709      fun is_good_arg (Bound _) = true
   5.710        | is_good_arg (Const (s, _)) =
   5.711          s = @{const_name True} orelse s = @{const_name False} orelse
   5.712 @@ -1442,7 +1318,6 @@
   5.713         | NONE => false)
   5.714      | _ => false
   5.715    end
   5.716 -(* theory -> const_table -> term -> term *)
   5.717  fun unfold_mutually_inductive_preds thy table =
   5.718    map_aterms (fn t as Const x =>
   5.719                   (case def_of_const thy table x of
   5.720 @@ -1454,7 +1329,6 @@
   5.721                   | NONE => t)
   5.722                 | t => t)
   5.723  
   5.724 -(* theory -> (typ option * bool) list -> (string * int) list *)
   5.725  fun case_const_names thy stds =
   5.726    Symtab.fold (fn (dtype_s, {index, descr, case_name, ...}) =>
   5.727                    if is_basic_datatype thy stds dtype_s then
   5.728 @@ -1465,7 +1339,6 @@
   5.729                (Datatype.get_all thy) [] @
   5.730    map (apsnd length o snd) (#codatatypes (Data.get thy))
   5.731  
   5.732 -(* theory -> const_table -> string * typ -> fixpoint_kind *)
   5.733  fun fixpoint_kind_of_const thy table x =
   5.734    if is_built_in_const thy [(NONE, false)] false x then
   5.735      NoFp
   5.736 @@ -1473,7 +1346,6 @@
   5.737      fixpoint_kind_of_rhs (the (def_of_const thy table x))
   5.738      handle Option.Option => NoFp
   5.739  
   5.740 -(* hol_context -> styp -> bool *)
   5.741  fun is_real_inductive_pred ({thy, stds, fast_descrs, def_table, intro_table,
   5.742                               ...} : hol_context) x =
   5.743    fixpoint_kind_of_const thy def_table x <> NoFp andalso
   5.744 @@ -1489,7 +1361,6 @@
   5.745    (is_real_equational_fun hol_ctxt orf is_real_inductive_pred hol_ctxt orf
   5.746     (String.isPrefix ubfp_prefix orf String.isPrefix lbfp_prefix) o fst)
   5.747  
   5.748 -(* term -> term *)
   5.749  fun lhs_of_equation t =
   5.750    case t of
   5.751      Const (@{const_name all}, _) $ Abs (_, _, t1) => lhs_of_equation t1
   5.752 @@ -1500,7 +1371,6 @@
   5.753    | Const (@{const_name "op ="}, _) $ t1 $ _ => SOME t1
   5.754    | @{const "op -->"} $ _ $ t2 => lhs_of_equation t2
   5.755    | _ => NONE
   5.756 -(* theory -> term -> bool *)
   5.757  fun is_constr_pattern _ (Bound _) = true
   5.758    | is_constr_pattern _ (Var _) = true
   5.759    | is_constr_pattern thy t =
   5.760 @@ -1517,10 +1387,8 @@
   5.761  
   5.762  (* Similar to "Refute.specialize_type" but returns all matches rather than only
   5.763     the first (preorder) match. *)
   5.764 -(* theory -> styp -> term -> term list *)
   5.765  fun multi_specialize_type thy slack (s, T) t =
   5.766    let
   5.767 -    (* term -> (typ * term) list -> (typ * term) list *)
   5.768      fun aux (Const (s', T')) ys =
   5.769          if s = s' then
   5.770            ys |> (if AList.defined (op =) ys T' then
   5.771 @@ -1539,22 +1407,18 @@
   5.772            ys
   5.773        | aux _ ys = ys
   5.774    in map snd (fold_aterms aux t []) end
   5.775 -(* theory -> bool -> const_table -> styp -> term list *)
   5.776  fun nondef_props_for_const thy slack table (x as (s, _)) =
   5.777    these (Symtab.lookup table s) |> maps (multi_specialize_type thy slack x)
   5.778  
   5.779 -(* term -> term *)
   5.780  fun unvarify_term (t1 $ t2) = unvarify_term t1 $ unvarify_term t2
   5.781    | unvarify_term (Var ((s, 0), T)) = Free (s, T)
   5.782    | unvarify_term (Abs (s, T, t')) = Abs (s, T, unvarify_term t')
   5.783    | unvarify_term t = t
   5.784 -(* theory -> term -> term *)
   5.785  fun axiom_for_choice_spec thy =
   5.786    unvarify_term
   5.787    #> Object_Logic.atomize_term thy
   5.788    #> Choice_Specification.close_form
   5.789    #> HOLogic.mk_Trueprop
   5.790 -(* hol_context -> styp -> bool *)
   5.791  fun is_choice_spec_fun ({thy, def_table, nondef_table, choice_spec_table, ...}
   5.792                          : hol_context) x =
   5.793    case nondef_props_for_const thy true choice_spec_table x of
   5.794 @@ -1570,7 +1434,6 @@
   5.795                                  ts') ts
   5.796              end
   5.797  
   5.798 -(* theory -> const_table -> term -> bool *)
   5.799  fun is_choice_spec_axiom thy choice_spec_table t =
   5.800    Symtab.exists (fn (_, ts) =>
   5.801                      exists (curry (op aconv) t o axiom_for_choice_spec thy) ts)
   5.802 @@ -1578,18 +1441,15 @@
   5.803  
   5.804  (** Constant unfolding **)
   5.805  
   5.806 -(* theory -> (typ option * bool) list -> int * styp -> term *)
   5.807  fun constr_case_body thy stds (j, (x as (_, T))) =
   5.808    let val arg_Ts = binder_types T in
   5.809      list_comb (Bound j, map2 (select_nth_constr_arg thy stds x (Bound 0))
   5.810                               (index_seq 0 (length arg_Ts)) arg_Ts)
   5.811    end
   5.812 -(* hol_context -> typ -> int * styp -> term -> term *)
   5.813  fun add_constr_case (hol_ctxt as {thy, stds, ...}) res_T (j, x) res_t =
   5.814    Const (@{const_name If}, bool_T --> res_T --> res_T --> res_T)
   5.815    $ discriminate_value hol_ctxt x (Bound 0) $ constr_case_body thy stds (j, x)
   5.816    $ res_t
   5.817 -(* hol_context -> typ -> typ -> term *)
   5.818  fun optimized_case_def (hol_ctxt as {thy, stds, ...}) dataT res_T =
   5.819    let
   5.820      val xs = datatype_constrs hol_ctxt dataT
   5.821 @@ -1600,7 +1460,6 @@
   5.822      |> fold_rev (add_constr_case hol_ctxt res_T) (length xs downto 2 ~~ xs')
   5.823      |> fold_rev (curry absdummy) (func_Ts @ [dataT])
   5.824    end
   5.825 -(* hol_context -> string -> typ -> typ -> term -> term *)
   5.826  fun optimized_record_get (hol_ctxt as {thy, stds, ...}) s rec_T res_T t =
   5.827    let val constr_x = hd (datatype_constrs hol_ctxt rec_T) in
   5.828      case no_of_record_field thy s rec_T of
   5.829 @@ -1617,7 +1476,6 @@
   5.830                                  []))
   5.831      | j => select_nth_constr_arg thy stds constr_x t j res_T
   5.832    end
   5.833 -(* hol_context -> string -> typ -> term -> term -> term *)
   5.834  fun optimized_record_update (hol_ctxt as {thy, stds, ...}) s rec_T fun_t rec_t =
   5.835    let
   5.836      val constr_x as (_, constr_T) = hd (datatype_constrs hol_ctxt rec_T)
   5.837 @@ -1640,12 +1498,10 @@
   5.838  (* Prevents divergence in case of cyclic or infinite definition dependencies. *)
   5.839  val unfold_max_depth = 255
   5.840  
   5.841 -(* hol_context -> term -> term *)
   5.842  fun unfold_defs_in_term (hol_ctxt as {thy, ctxt, stds, fast_descrs, case_names,
   5.843                                        def_table, ground_thm_table, ersatz_table,
   5.844                                        ...}) =
   5.845    let
   5.846 -    (* int -> typ list -> term -> term *)
   5.847      fun do_term depth Ts t =
   5.848        case t of
   5.849          (t0 as Const (@{const_name Int.number_class.number_of},
   5.850 @@ -1695,13 +1551,11 @@
   5.851        | Var _ => t
   5.852        | Bound _ => t
   5.853        | Abs (s, T, body) => Abs (s, T, do_term depth (T :: Ts) body)
   5.854 -    (* int -> typ list -> styp -> term list -> int -> typ -> term * term list *)
   5.855      and select_nth_constr_arg_with_args _ _ (x as (_, T)) [] n res_T =
   5.856          (Abs (Name.uu, body_type T,
   5.857                select_nth_constr_arg thy stds x (Bound 0) n res_T), [])
   5.858        | select_nth_constr_arg_with_args depth Ts x (t :: ts) n res_T =
   5.859          (select_nth_constr_arg thy stds x (do_term depth Ts t) n res_T, ts)
   5.860 -    (* int -> typ list -> term -> styp -> term list -> term *)
   5.861      and do_const depth Ts t (x as (s, T)) ts =
   5.862        case AList.lookup (op =) ersatz_table s of
   5.863          SOME s' =>
   5.864 @@ -1782,39 +1636,30 @@
   5.865  
   5.866  (** Axiom extraction/generation **)
   5.867  
   5.868 -(* term -> string * term *)
   5.869  fun pair_for_prop t =
   5.870    case term_under_def t of
   5.871      Const (s, _) => (s, t)
   5.872    | t' => raise TERM ("Nitpick_HOL.pair_for_prop", [t, t'])
   5.873 -(* (Proof.context -> term list) -> Proof.context -> (term * term) list
   5.874 -   -> const_table *)
   5.875  fun def_table_for get ctxt subst =
   5.876    ctxt |> get |> map (pair_for_prop o subst_atomic subst)
   5.877         |> AList.group (op =) |> Symtab.make
   5.878 -(* term -> string * term *)
   5.879  fun paired_with_consts t = map (rpair t) (Term.add_const_names t [])
   5.880 -(* Proof.context -> (term * term) list -> term list -> const_table *)
   5.881  fun const_def_table ctxt subst ts =
   5.882    def_table_for (map prop_of o Nitpick_Defs.get) ctxt subst
   5.883    |> fold (fn (s, t) => Symtab.map_default (s, []) (cons t))
   5.884            (map pair_for_prop ts)
   5.885 -(* term list -> const_table *)
   5.886  fun const_nondef_table ts =
   5.887    fold (append o paired_with_consts) ts [] |> AList.group (op =) |> Symtab.make
   5.888 -(* Proof.context -> (term * term) list -> const_table *)
   5.889  val const_simp_table = def_table_for (map prop_of o Nitpick_Simps.get)
   5.890  val const_psimp_table = def_table_for (map prop_of o Nitpick_Psimps.get)
   5.891  fun const_choice_spec_table ctxt subst =
   5.892    map (subst_atomic subst o prop_of) (Nitpick_Choice_Specs.get ctxt)
   5.893    |> const_nondef_table
   5.894 -(* Proof.context -> (term * term) list -> const_table -> const_table *)
   5.895  fun inductive_intro_table ctxt subst def_table =
   5.896    def_table_for
   5.897        (map (unfold_mutually_inductive_preds (ProofContext.theory_of ctxt)
   5.898                                              def_table o prop_of)
   5.899             o Nitpick_Intros.get) ctxt subst
   5.900 -(* theory -> term list Inttab.table *)
   5.901  fun ground_theorem_table thy =
   5.902    fold ((fn @{const Trueprop} $ t1 =>
   5.903              is_ground_term t1 ? Inttab.map_default (hash_term t1, []) (cons t1)
   5.904 @@ -1830,16 +1675,13 @@
   5.905     (@{const_name wf_wfrec}, @{const_name wf_wfrec'}),
   5.906     (@{const_name wfrec}, @{const_name wfrec'})]
   5.907  
   5.908 -(* theory -> (string * string) list *)
   5.909  fun ersatz_table thy =
   5.910    fold (append o snd) (#frac_types (Data.get thy)) basic_ersatz_table
   5.911  
   5.912 -(* const_table Unsynchronized.ref -> string -> term list -> unit *)
   5.913  fun add_simps simp_table s eqs =
   5.914    Unsynchronized.change simp_table
   5.915        (Symtab.update (s, eqs @ these (Symtab.lookup (!simp_table) s)))
   5.916  
   5.917 -(* theory -> styp -> term list *)
   5.918  fun inverse_axioms_for_rep_fun thy (x as (_, T)) =
   5.919    let val abs_T = domain_type T in
   5.920      typedef_info thy (fst (dest_Type abs_T)) |> the
   5.921 @@ -1847,7 +1689,6 @@
   5.922      |> pairself (Refute.specialize_type thy x o prop_of o the)
   5.923      ||> single |> op ::
   5.924    end
   5.925 -(* theory -> string * typ list -> term list *)
   5.926  fun optimized_typedef_axioms thy (abs_z as (abs_s, _)) =
   5.927    let val abs_T = Type abs_z in
   5.928      if is_univ_typedef thy abs_T then
   5.929 @@ -1870,7 +1711,6 @@
   5.930        end
   5.931      | NONE => []
   5.932    end
   5.933 -(* Proof.context -> string * typ list -> term list *)
   5.934  fun optimized_quot_type_axioms ctxt stds abs_z =
   5.935    let
   5.936      val thy = ProofContext.theory_of ctxt
   5.937 @@ -1899,7 +1739,6 @@
   5.938            HOLogic.mk_Trueprop (equiv_rel $ x_var $ normal_x))]
   5.939    end
   5.940  
   5.941 -(* hol_context -> typ -> term list *)
   5.942  fun codatatype_bisim_axioms (hol_ctxt as {thy, stds, ...}) T =
   5.943    let
   5.944      val xs = datatype_constrs hol_ctxt T
   5.945 @@ -1914,13 +1753,11 @@
   5.946                            $ (suc_const iter_T $ Bound 0) $ n_var)
   5.947      val x_var = Var (("x", 0), T)
   5.948      val y_var = Var (("y", 0), T)
   5.949 -    (* styp -> int -> typ -> term *)
   5.950      fun nth_sub_bisim x n nth_T =
   5.951        (if is_codatatype thy nth_T then bisim_const $ n_var_minus_1
   5.952         else HOLogic.eq_const nth_T)
   5.953        $ select_nth_constr_arg thy stds x x_var n nth_T
   5.954        $ select_nth_constr_arg thy stds x y_var n nth_T
   5.955 -    (* styp -> term *)
   5.956      fun case_func (x as (_, T)) =
   5.957        let
   5.958          val arg_Ts = binder_types T
   5.959 @@ -1942,22 +1779,18 @@
   5.960  
   5.961  exception NO_TRIPLE of unit
   5.962  
   5.963 -(* theory -> styp -> term -> term list * term list * term *)
   5.964  fun triple_for_intro_rule thy x t =
   5.965    let
   5.966      val prems = Logic.strip_imp_prems t |> map (Object_Logic.atomize_term thy)
   5.967      val concl = Logic.strip_imp_concl t |> Object_Logic.atomize_term thy
   5.968      val (main, side) = List.partition (exists_Const (curry (op =) x)) prems
   5.969 -    (* term -> bool *)
   5.970 -     val is_good_head = curry (op =) (Const x) o head_of
   5.971 +    val is_good_head = curry (op =) (Const x) o head_of
   5.972    in
   5.973      if forall is_good_head main then (side, main, concl) else raise NO_TRIPLE ()
   5.974    end
   5.975  
   5.976 -(* term -> term *)
   5.977  val tuple_for_args = HOLogic.mk_tuple o snd o strip_comb
   5.978  
   5.979 -(* indexname * typ -> term list -> term -> term -> term *)
   5.980  fun wf_constraint_for rel side concl main =
   5.981    let
   5.982      val core = HOLogic.mk_mem (HOLogic.mk_prod (tuple_for_args main,
   5.983 @@ -1971,12 +1804,9 @@
   5.984                    (t, vars)
   5.985    end
   5.986  
   5.987 -(* indexname * typ -> term list * term list * term -> term *)
   5.988  fun wf_constraint_for_triple rel (side, main, concl) =
   5.989    map (wf_constraint_for rel side concl) main |> foldr1 s_conj
   5.990  
   5.991 -(* Proof.context -> Time.time option -> thm
   5.992 -   -> (Proof.context -> tactic -> tactic) -> bool *)
   5.993  fun terminates_by ctxt timeout goal tac =
   5.994    can (SINGLE (Classical.safe_tac (claset_of ctxt)) #> the
   5.995         #> SINGLE (DETERM_TIMEOUT timeout
   5.996 @@ -1992,7 +1822,6 @@
   5.997  val termination_tacs = [Lexicographic_Order.lex_order_tac true,
   5.998                          ScnpReconstruct.sizechange_tac]
   5.999  
  5.1000 -(* hol_context -> const_table -> styp -> bool *)
  5.1001  fun uncached_is_well_founded_inductive_pred
  5.1002          ({thy, ctxt, stds, debug, fast_descrs, tac_timeout, intro_table, ...}
  5.1003           : hol_context) (x as (_, T)) =
  5.1004 @@ -2037,7 +1866,6 @@
  5.1005  
  5.1006  (* The type constraint below is a workaround for a Poly/ML crash. *)
  5.1007  
  5.1008 -(* hol_context -> styp -> bool *)
  5.1009  fun is_well_founded_inductive_pred
  5.1010          (hol_ctxt as {thy, wfs, def_table, wf_cache, ...} : hol_context)
  5.1011          (x as (s, _)) =
  5.1012 @@ -2054,7 +1882,6 @@
  5.1013               Unsynchronized.change wf_cache (cons (x, (gfp, wf))); wf
  5.1014             end
  5.1015  
  5.1016 -(* typ list -> typ -> term -> term *)
  5.1017  fun ap_curry [_] _ t = t
  5.1018    | ap_curry arg_Ts tuple_T t =
  5.1019      let val n = length arg_Ts in
  5.1020 @@ -2063,7 +1890,6 @@
  5.1021                  $ mk_flat_tuple tuple_T (map Bound (n - 1 downto 0)))
  5.1022      end
  5.1023  
  5.1024 -(* int -> term -> int *)
  5.1025  fun num_occs_of_bound_in_term j (t1 $ t2) =
  5.1026      op + (pairself (num_occs_of_bound_in_term j) (t1, t2))
  5.1027    | num_occs_of_bound_in_term j (Abs (_, _, t')) =
  5.1028 @@ -2071,10 +1897,8 @@
  5.1029    | num_occs_of_bound_in_term j (Bound j') = if j' = j then 1 else 0
  5.1030    | num_occs_of_bound_in_term _ _ = 0
  5.1031  
  5.1032 -(* term -> bool *)
  5.1033  val is_linear_inductive_pred_def =
  5.1034    let
  5.1035 -    (* int -> term -> bool *)
  5.1036      fun do_disjunct j (Const (@{const_name Ex}, _) $ Abs (_, _, t2)) =
  5.1037          do_disjunct (j + 1) t2
  5.1038        | do_disjunct j t =
  5.1039 @@ -2082,7 +1906,6 @@
  5.1040            0 => true
  5.1041          | 1 => exists (curry (op =) (Bound j) o head_of) (conjuncts_of t)
  5.1042          | _ => false
  5.1043 -    (* term -> bool *)
  5.1044      fun do_lfp_def (Const (@{const_name lfp}, _) $ t2) =
  5.1045          let val (xs, body) = strip_abs t2 in
  5.1046            case length xs of
  5.1047 @@ -2092,24 +1915,19 @@
  5.1048        | do_lfp_def _ = false
  5.1049    in do_lfp_def o strip_abs_body end
  5.1050  
  5.1051 -(* int -> int list list *)
  5.1052  fun n_ptuple_paths 0 = []
  5.1053    | n_ptuple_paths 1 = []
  5.1054    | n_ptuple_paths n = [] :: map (cons 2) (n_ptuple_paths (n - 1))
  5.1055 -(* int -> typ -> typ -> term -> term *)
  5.1056  val ap_n_split = HOLogic.mk_psplits o n_ptuple_paths
  5.1057  
  5.1058 -(* term -> term * term *)
  5.1059  val linear_pred_base_and_step_rhss =
  5.1060    let
  5.1061 -    (* term -> term *)
  5.1062      fun aux (Const (@{const_name lfp}, _) $ t2) =
  5.1063          let
  5.1064            val (xs, body) = strip_abs t2
  5.1065            val arg_Ts = map snd (tl xs)
  5.1066            val tuple_T = HOLogic.mk_tupleT arg_Ts
  5.1067            val j = length arg_Ts
  5.1068 -          (* int -> term -> term *)
  5.1069            fun repair_rec j (Const (@{const_name Ex}, T1) $ Abs (s2, T2, t2')) =
  5.1070                Const (@{const_name Ex}, T1)
  5.1071                $ Abs (s2, T2, repair_rec (j + 1) t2')
  5.1072 @@ -2139,7 +1957,6 @@
  5.1073          raise TERM ("Nitpick_HOL.linear_pred_base_and_step_rhss.aux", [t])
  5.1074    in aux end
  5.1075  
  5.1076 -(* hol_context -> styp -> term -> term *)
  5.1077  fun starred_linear_pred_const (hol_ctxt as {simp_table, ...}) (s, T) def =
  5.1078    let
  5.1079      val j = maxidx_of_term def + 1
  5.1080 @@ -2173,7 +1990,6 @@
  5.1081      |> unfold_defs_in_term hol_ctxt
  5.1082    end
  5.1083  
  5.1084 -(* hol_context -> bool -> styp -> term *)
  5.1085  fun unrolled_inductive_pred_const (hol_ctxt as {thy, star_linear_preds,
  5.1086                                                  def_table, simp_table, ...})
  5.1087                                    gfp (x as (s, T)) =
  5.1088 @@ -2210,7 +2026,6 @@
  5.1089        in unrolled_const end
  5.1090    end
  5.1091  
  5.1092 -(* hol_context -> styp -> term *)
  5.1093  fun raw_inductive_pred_axiom ({thy, def_table, ...} : hol_context) x =
  5.1094    let
  5.1095      val def = the (def_of_const thy def_table x)
  5.1096 @@ -2237,7 +2052,6 @@
  5.1097    else
  5.1098      raw_inductive_pred_axiom hol_ctxt x
  5.1099  
  5.1100 -(* hol_context -> styp -> term list *)
  5.1101  fun raw_equational_fun_axioms (hol_ctxt as {thy, stds, fast_descrs, simp_table,
  5.1102                                              psimp_table, ...}) x =
  5.1103    case def_props_for_const thy stds fast_descrs (!simp_table) x of
  5.1104 @@ -2246,7 +2060,6 @@
  5.1105             | psimps => psimps)
  5.1106    | simps => simps
  5.1107  val equational_fun_axioms = map extensionalize oo raw_equational_fun_axioms
  5.1108 -(* hol_context -> styp -> bool *)
  5.1109  fun is_equational_fun_surely_complete hol_ctxt x =
  5.1110    case raw_equational_fun_axioms hol_ctxt x of
  5.1111      [@{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t1 $ _)] =>
  5.1112 @@ -2255,10 +2068,8 @@
  5.1113  
  5.1114  (** Type preprocessing **)
  5.1115  
  5.1116 -(* term list -> term list *)
  5.1117  fun merge_type_vars_in_terms ts =
  5.1118    let
  5.1119 -    (* typ -> (sort * string) list -> (sort * string) list *)
  5.1120      fun add_type (TFree (s, S)) table =
  5.1121          (case AList.lookup (op =) table S of
  5.1122             SOME s' =>
  5.1123 @@ -2267,12 +2078,10 @@
  5.1124           | NONE => (S, s) :: table)
  5.1125        | add_type _ table = table
  5.1126      val table = fold (fold_types (fold_atyps add_type)) ts []
  5.1127 -    (* typ -> typ *)
  5.1128      fun coalesce (TFree (_, S)) = TFree (AList.lookup (op =) table S |> the, S)
  5.1129        | coalesce T = T
  5.1130    in map (map_types (map_atyps coalesce)) ts end
  5.1131  
  5.1132 -(* hol_context -> bool -> typ -> typ list -> typ list *)
  5.1133  fun add_ground_types hol_ctxt binarize =
  5.1134    let
  5.1135      fun aux T accum =
  5.1136 @@ -2293,10 +2102,8 @@
  5.1137        | _ => insert (op =) T accum
  5.1138    in aux end
  5.1139  
  5.1140 -(* hol_context -> bool -> typ -> typ list *)
  5.1141  fun ground_types_in_type hol_ctxt binarize T =
  5.1142    add_ground_types hol_ctxt binarize T []
  5.1143 -(* hol_context -> term list -> typ list *)
  5.1144  fun ground_types_in_terms hol_ctxt binarize ts =
  5.1145    fold (fold_types (add_ground_types hol_ctxt binarize)) ts []
  5.1146  
     6.1 --- a/src/HOL/Tools/Nitpick/nitpick_isar.ML	Sat Apr 24 16:17:30 2010 +0200
     6.2 +++ b/src/HOL/Tools/Nitpick/nitpick_isar.ML	Sat Apr 24 16:33:01 2010 +0200
     6.3 @@ -109,7 +109,6 @@
     6.4     ("trust_potential", "check_potential"),
     6.5     ("trust_genuine", "check_genuine")]
     6.6  
     6.7 -(* string -> bool *)
     6.8  fun is_known_raw_param s =
     6.9    AList.defined (op =) default_default_params s orelse
    6.10    AList.defined (op =) negated_params s orelse
    6.11 @@ -118,19 +117,16 @@
    6.12           ["card", "max", "iter", "box", "dont_box", "finitize", "dont_finitize",
    6.13            "mono", "non_mono", "std", "non_std", "wf", "non_wf", "format"]
    6.14  
    6.15 -(* string * 'a -> unit *)
    6.16  fun check_raw_param (s, _) =
    6.17    if is_known_raw_param s then ()
    6.18    else error ("Unknown parameter: " ^ quote s ^ ".")  
    6.19  
    6.20 -(* string -> string option *)
    6.21  fun unnegate_param_name name =
    6.22    case AList.lookup (op =) negated_params name of
    6.23      NONE => if String.isPrefix "dont_" name then SOME (unprefix "dont_" name)
    6.24              else if String.isPrefix "non_" name then SOME (unprefix "non_" name)
    6.25              else NONE
    6.26    | some_name => some_name
    6.27 -(* raw_param -> raw_param *)
    6.28  fun unnegate_raw_param (name, value) =
    6.29    case unnegate_param_name name of
    6.30      SOME name' => (name', case value of
    6.31 @@ -146,43 +142,32 @@
    6.32    val extend = I
    6.33    fun merge p : T = AList.merge (op =) (K true) p)
    6.34  
    6.35 -(* raw_param -> theory -> theory *)
    6.36  val set_default_raw_param = Data.map o AList.update (op =) o unnegate_raw_param
    6.37 -(* theory -> raw_param list *)
    6.38  val default_raw_params = Data.get
    6.39  
    6.40 -(* string -> bool *)
    6.41  fun is_punctuation s = (s = "," orelse s = "-" orelse s = "\<midarrow>")
    6.42  
    6.43 -(* string list -> string *)
    6.44  fun stringify_raw_param_value [] = ""
    6.45    | stringify_raw_param_value [s] = s
    6.46    | stringify_raw_param_value (s1 :: s2 :: ss) =
    6.47      s1 ^ (if is_punctuation s1 orelse is_punctuation s2 then "" else " ") ^
    6.48      stringify_raw_param_value (s2 :: ss)
    6.49  
    6.50 -(* int -> string -> int *)
    6.51  fun maxed_int_from_string min_int s = Int.max (min_int, the (Int.fromString s))
    6.52  
    6.53 -(* Proof.context -> bool -> raw_param list -> raw_param list -> params *)
    6.54  fun extract_params ctxt auto default_params override_params =
    6.55    let
    6.56      val override_params = map unnegate_raw_param override_params
    6.57      val raw_params = rev override_params @ rev default_params
    6.58 -    (* string -> string *)
    6.59      val lookup =
    6.60        Option.map stringify_raw_param_value o AList.lookup (op =) raw_params
    6.61      val lookup_string = the_default "" o lookup
    6.62 -    (* bool -> bool option -> string -> bool option *)
    6.63      fun general_lookup_bool option default_value name =
    6.64        case lookup name of
    6.65          SOME s => parse_bool_option option name s
    6.66        | NONE => default_value
    6.67 -    (* string -> bool *)
    6.68      val lookup_bool = the o general_lookup_bool false (SOME false)
    6.69 -    (* string -> bool option *)
    6.70      val lookup_bool_option = general_lookup_bool true NONE
    6.71 -    (* string -> string option -> int *)
    6.72      fun do_int name value =
    6.73        case value of
    6.74          SOME s => (case Int.fromString s of
    6.75 @@ -190,14 +175,11 @@
    6.76                     | NONE => error ("Parameter " ^ quote name ^
    6.77                                      " must be assigned an integer value."))
    6.78        | NONE => 0
    6.79 -    (* string -> int *)
    6.80      fun lookup_int name = do_int name (lookup name)
    6.81 -    (* string -> int option *)
    6.82      fun lookup_int_option name =
    6.83        case lookup name of
    6.84          SOME "smart" => NONE
    6.85        | value => SOME (do_int name value)
    6.86 -    (* string -> int -> string -> int list *)
    6.87      fun int_range_from_string name min_int s =
    6.88        let
    6.89          val (k1, k2) =
    6.90 @@ -211,17 +193,14 @@
    6.91        handle Option.Option =>
    6.92               error ("Parameter " ^ quote name ^
    6.93                      " must be assigned a sequence of integers.")
    6.94 -    (* string -> int -> string -> int list *)
    6.95      fun int_seq_from_string name min_int s =
    6.96        maps (int_range_from_string name min_int) (space_explode "," s)
    6.97 -    (* string -> int -> int list *)
    6.98      fun lookup_int_seq name min_int =
    6.99        case lookup name of
   6.100          SOME s => (case int_seq_from_string name min_int s of
   6.101                       [] => [min_int]
   6.102                     | value => value)
   6.103        | NONE => [min_int]
   6.104 -    (* (string -> 'a) -> int -> string -> ('a option * int list) list *)
   6.105      fun lookup_ints_assigns read prefix min_int =
   6.106        (NONE, lookup_int_seq prefix min_int)
   6.107        :: map (fn (name, value) =>
   6.108 @@ -229,7 +208,6 @@
   6.109                    value |> stringify_raw_param_value
   6.110                          |> int_seq_from_string name min_int))
   6.111               (filter (String.isPrefix (prefix ^ " ") o fst) raw_params)
   6.112 -    (* (string -> 'a) -> string -> ('a option * bool) list *)
   6.113      fun lookup_bool_assigns read prefix =
   6.114        (NONE, lookup_bool prefix)
   6.115        :: map (fn (name, value) =>
   6.116 @@ -237,7 +215,6 @@
   6.117                    value |> stringify_raw_param_value
   6.118                          |> parse_bool_option false name |> the))
   6.119               (filter (String.isPrefix (prefix ^ " ") o fst) raw_params)
   6.120 -    (* (string -> 'a) -> string -> ('a option * bool option) list *)
   6.121      fun lookup_bool_option_assigns read prefix =
   6.122        (NONE, lookup_bool_option prefix)
   6.123        :: map (fn (name, value) =>
   6.124 @@ -245,21 +222,17 @@
   6.125                    value |> stringify_raw_param_value
   6.126                          |> parse_bool_option true name))
   6.127               (filter (String.isPrefix (prefix ^ " ") o fst) raw_params)
   6.128 -    (* string -> Time.time option *)
   6.129      fun lookup_time name =
   6.130        case lookup name of
   6.131          NONE => NONE
   6.132        | SOME s => parse_time_option name s
   6.133 -    (* string -> term list *)
   6.134      val lookup_term_list =
   6.135        AList.lookup (op =) raw_params #> these #> Syntax.read_terms ctxt
   6.136      val read_type_polymorphic =
   6.137        Syntax.read_typ ctxt #> Logic.mk_type
   6.138        #> singleton (Variable.polymorphic ctxt) #> Logic.dest_type
   6.139 -    (* string -> term *)
   6.140      val read_term_polymorphic =
   6.141        Syntax.read_term ctxt #> singleton (Variable.polymorphic ctxt)
   6.142 -    (* string -> styp *)
   6.143      val read_const_polymorphic = read_term_polymorphic #> dest_Const
   6.144      val cards_assigns = lookup_ints_assigns read_type_polymorphic "card" 1
   6.145      val maxes_assigns = lookup_ints_assigns read_const_polymorphic "max" ~1
   6.146 @@ -330,25 +303,19 @@
   6.147       check_genuine = check_genuine, batch_size = batch_size, expect = expect}
   6.148    end
   6.149  
   6.150 -(* theory -> (string * string) list -> params *)
   6.151  fun default_params thy =
   6.152    extract_params (ProofContext.init thy) false (default_raw_params thy)
   6.153    o map (apsnd single)
   6.154  
   6.155 -(* P.token list -> string * P.token list *)
   6.156  val parse_key = Scan.repeat1 P.typ_group >> space_implode " "
   6.157 -(* P.token list -> string list * P.token list *)
   6.158  val parse_value =
   6.159    Scan.repeat1 (P.minus >> single
   6.160                  || Scan.repeat1 (Scan.unless P.minus P.name)
   6.161                  || P.$$$ "," |-- P.number >> prefix "," >> single) >> flat
   6.162 -(* P.token list -> raw_param * P.token list *)
   6.163  val parse_param = parse_key -- Scan.optional (P.$$$ "=" |-- parse_value) []
   6.164 -(* P.token list -> raw_param list * P.token list *)
   6.165  val parse_params =
   6.166    Scan.optional (P.$$$ "[" |-- P.list parse_param --| P.$$$ "]") []
   6.167  
   6.168 -(* Proof.context -> ('a -> 'a) -> 'a -> 'a *)
   6.169  fun handle_exceptions ctxt f x =
   6.170    f x
   6.171    handle ARG (loc, details) =>
   6.172 @@ -386,7 +353,6 @@
   6.173         | Refute.REFUTE (loc, details) =>
   6.174           error ("Unhandled Refute error (" ^ quote loc ^ "): " ^ details ^ ".")
   6.175  
   6.176 -(* raw_param list -> bool -> int -> int -> Proof.state -> bool * Proof.state *)
   6.177  fun pick_nits override_params auto i step state =
   6.178    let
   6.179      val thy = Proof.theory_of state
   6.180 @@ -394,7 +360,6 @@
   6.181      val _ = List.app check_raw_param override_params
   6.182      val params as {blocking, debug, ...} =
   6.183        extract_params ctxt auto (default_raw_params thy) override_params
   6.184 -    (* unit -> bool * Proof.state *)
   6.185      fun go () =
   6.186        (false, state)
   6.187        |> (if auto then perhaps o try
   6.188 @@ -407,17 +372,14 @@
   6.189      else (Toplevel.thread true (fn () => (go (); ())); (false, state))
   6.190    end
   6.191  
   6.192 -(* raw_param list * int -> Toplevel.transition -> Toplevel.transition *)
   6.193  fun nitpick_trans (params, i) =
   6.194    Toplevel.keep (fn st =>
   6.195        (pick_nits params false i (Toplevel.proof_position_of st)
   6.196                   (Toplevel.proof_of st); ()))
   6.197  
   6.198 -(* raw_param -> string *)
   6.199  fun string_for_raw_param (name, value) =
   6.200    name ^ " = " ^ stringify_raw_param_value value
   6.201  
   6.202 -(* raw_param list -> Toplevel.transition -> Toplevel.transition *)
   6.203  fun nitpick_params_trans params =
   6.204    Toplevel.theory
   6.205        (fold set_default_raw_param params
   6.206 @@ -430,8 +392,6 @@
   6.207                                 params |> map string_for_raw_param
   6.208                                        |> sort_strings |> cat_lines)))))
   6.209  
   6.210 -(* P.token list
   6.211 -   -> (Toplevel.transition -> Toplevel.transition) * P.token list *)
   6.212  val parse_nitpick_command =
   6.213    (parse_params -- Scan.optional P.nat 1) #>> nitpick_trans
   6.214  val parse_nitpick_params_command = parse_params #>> nitpick_params_trans
   6.215 @@ -443,7 +403,6 @@
   6.216              "set and display the default parameters for Nitpick"
   6.217              K.thy_decl parse_nitpick_params_command
   6.218  
   6.219 -(* Proof.state -> bool * Proof.state *)
   6.220  fun auto_nitpick state =
   6.221    if not (!auto) then (false, state) else pick_nits [] true 1 0 state
   6.222  
     7.1 --- a/src/HOL/Tools/Nitpick/nitpick_kodkod.ML	Sat Apr 24 16:17:30 2010 +0200
     7.2 +++ b/src/HOL/Tools/Nitpick/nitpick_kodkod.ML	Sat Apr 24 16:33:01 2010 +0200
     7.3 @@ -57,24 +57,19 @@
     7.4  
     7.5  structure NfaGraph = Typ_Graph
     7.6  
     7.7 -(* int -> KK.int_expr list *)
     7.8  fun flip_nums n = index_seq 1 n @ [0] |> map KK.Num
     7.9  
    7.10 -(* int -> int -> int -> KK.bound list -> KK.formula -> int *)
    7.11  fun univ_card nat_card int_card main_j0 bounds formula =
    7.12    let
    7.13 -    (* KK.rel_expr -> int -> int *)
    7.14      fun rel_expr_func r k =
    7.15        Int.max (k, case r of
    7.16                      KK.Atom j => j + 1
    7.17                    | KK.AtomSeq (k', j0) => j0 + k'
    7.18                    | _ => 0)
    7.19 -    (* KK.tuple -> int -> int *)
    7.20      fun tuple_func t k =
    7.21        case t of
    7.22          KK.Tuple js => fold Integer.max (map (Integer.add 1) js) k
    7.23        | _ => k
    7.24 -    (* KK.tuple_set -> int -> int *)
    7.25      fun tuple_set_func ts k =
    7.26        Int.max (k, case ts of KK.TupleAtomSeq (k', j0) => j0 + k' | _ => 0)
    7.27      val expr_F = {formula_func = K I, rel_expr_func = rel_expr_func,
    7.28 @@ -84,10 +79,8 @@
    7.29                 |> KK.fold_formula expr_F formula
    7.30    in Int.max (main_j0 + fold Integer.max [2, nat_card, int_card] 0, card) end
    7.31  
    7.32 -(* int -> KK.formula -> unit *)
    7.33  fun check_bits bits formula =
    7.34    let
    7.35 -    (* KK.int_expr -> unit -> unit *)
    7.36      fun int_expr_func (KK.Num k) () =
    7.37          if is_twos_complement_representable bits k then
    7.38            ()
    7.39 @@ -100,7 +93,6 @@
    7.40                    int_expr_func = int_expr_func}
    7.41    in KK.fold_formula expr_F formula () end
    7.42  
    7.43 -(* int -> int -> unit *)
    7.44  fun check_arity univ_card n =
    7.45    if n > KK.max_arity univ_card then
    7.46      raise TOO_LARGE ("Nitpick_Kodkod.check_arity",
    7.47 @@ -109,7 +101,6 @@
    7.48    else
    7.49      ()
    7.50  
    7.51 -(* bool -> int -> int list -> KK.tuple *)
    7.52  fun kk_tuple debug univ_card js =
    7.53    if debug then
    7.54      KK.Tuple js
    7.55 @@ -117,19 +108,13 @@
    7.56      KK.TupleIndex (length js,
    7.57                     fold (fn j => fn accum => accum * univ_card + j) js 0)
    7.58  
    7.59 -(* (int * int) list -> KK.tuple_set *)
    7.60  val tuple_set_from_atom_schema = foldl1 KK.TupleProduct o map KK.TupleAtomSeq
    7.61 -(* rep -> KK.tuple_set *)
    7.62  val upper_bound_for_rep = tuple_set_from_atom_schema o atom_schema_of_rep
    7.63  
    7.64 -(* int -> KK.tuple_set *)
    7.65  val single_atom = KK.TupleSet o single o KK.Tuple o single
    7.66 -(* int -> KK.int_bound list *)
    7.67  fun sequential_int_bounds n = [(NONE, map single_atom (index_seq 0 n))]
    7.68 -(* int -> int -> KK.int_bound list *)
    7.69  fun pow_of_two_int_bounds bits j0 =
    7.70    let
    7.71 -    (* int -> int -> int -> KK.int_bound list *)
    7.72      fun aux 0  _ _ = []
    7.73        | aux 1 pow_of_two j = [(SOME (~ pow_of_two), [single_atom j])]
    7.74        | aux iter pow_of_two j =
    7.75 @@ -137,10 +122,8 @@
    7.76          aux (iter - 1) (2 * pow_of_two) (j + 1)
    7.77    in aux (bits + 1) 1 j0 end
    7.78  
    7.79 -(* KK.formula -> KK.n_ary_index list *)
    7.80  fun built_in_rels_in_formula formula =
    7.81    let
    7.82 -    (* KK.rel_expr -> KK.n_ary_index list -> KK.n_ary_index list *)
    7.83      fun rel_expr_func (KK.Rel (x as (n, j))) =
    7.84          if x = unsigned_bit_word_sel_rel orelse x = signed_bit_word_sel_rel then
    7.85            I
    7.86 @@ -155,7 +138,6 @@
    7.87  
    7.88  val max_table_size = 65536
    7.89  
    7.90 -(* int -> unit *)
    7.91  fun check_table_size k =
    7.92    if k > max_table_size then
    7.93      raise TOO_LARGE ("Nitpick_Kodkod.check_table_size",
    7.94 @@ -163,7 +145,6 @@
    7.95    else
    7.96      ()
    7.97  
    7.98 -(* bool -> int -> int * int -> (int -> int) -> KK.tuple list *)
    7.99  fun tabulate_func1 debug univ_card (k, j0) f =
   7.100    (check_table_size k;
   7.101     map_filter (fn j1 => let val j2 = f j1 in
   7.102 @@ -172,7 +153,6 @@
   7.103                            else
   7.104                              NONE
   7.105                          end) (index_seq 0 k))
   7.106 -(* bool -> int -> int * int -> int -> (int * int -> int) -> KK.tuple list *)
   7.107  fun tabulate_op2 debug univ_card (k, j0) res_j0 f =
   7.108    (check_table_size (k * k);
   7.109     map_filter (fn j => let
   7.110 @@ -186,8 +166,6 @@
   7.111                           else
   7.112                             NONE
   7.113                         end) (index_seq 0 (k * k)))
   7.114 -(* bool -> int -> int * int -> int -> (int * int -> int * int)
   7.115 -   -> KK.tuple list *)
   7.116  fun tabulate_op2_2 debug univ_card (k, j0) res_j0 f =
   7.117    (check_table_size (k * k);
   7.118     map_filter (fn j => let
   7.119 @@ -202,33 +180,27 @@
   7.120                           else
   7.121                             NONE
   7.122                         end) (index_seq 0 (k * k)))
   7.123 -(* bool -> int -> int * int -> (int * int -> int) -> KK.tuple list *)
   7.124  fun tabulate_nat_op2 debug univ_card (k, j0) f =
   7.125    tabulate_op2 debug univ_card (k, j0) j0 (atom_for_nat (k, 0) o f)
   7.126  fun tabulate_int_op2 debug univ_card (k, j0) f =
   7.127    tabulate_op2 debug univ_card (k, j0) j0
   7.128                 (atom_for_int (k, 0) o f o pairself (int_for_atom (k, 0)))
   7.129 -(* bool -> int -> int * int -> (int * int -> int * int) -> KK.tuple list *)
   7.130  fun tabulate_int_op2_2 debug univ_card (k, j0) f =
   7.131    tabulate_op2_2 debug univ_card (k, j0) j0
   7.132                   (pairself (atom_for_int (k, 0)) o f
   7.133                    o pairself (int_for_atom (k, 0)))
   7.134  
   7.135 -(* int * int -> int *)
   7.136  fun isa_div (m, n) = m div n handle General.Div => 0
   7.137  fun isa_mod (m, n) = m mod n handle General.Div => m
   7.138  fun isa_gcd (m, 0) = m
   7.139    | isa_gcd (m, n) = isa_gcd (n, isa_mod (m, n))
   7.140  fun isa_lcm (m, n) = isa_div (m * n, isa_gcd (m, n))
   7.141  val isa_zgcd = isa_gcd o pairself abs
   7.142 -(* int * int -> int * int *)
   7.143  fun isa_norm_frac (m, n) =
   7.144    if n < 0 then isa_norm_frac (~m, ~n)
   7.145    else if m = 0 orelse n = 0 then (0, 1)
   7.146    else let val p = isa_zgcd (m, n) in (isa_div (m, p), isa_div (n, p)) end
   7.147  
   7.148 -(* bool -> int -> int -> int -> int -> int * int
   7.149 -   -> string * bool * KK.tuple list *)
   7.150  fun tabulate_built_in_rel debug univ_card nat_card int_card j0 (x as (n, _)) =
   7.151    (check_arity univ_card n;
   7.152     if x = not3_rel then
   7.153 @@ -269,25 +241,21 @@
   7.154     else
   7.155       raise ARG ("Nitpick_Kodkod.tabulate_built_in_rel", "unknown relation"))
   7.156  
   7.157 -(* bool -> int -> int -> int -> int -> int * int -> KK.rel_expr -> KK.bound *)
   7.158  fun bound_for_built_in_rel debug univ_card nat_card int_card j0 x =
   7.159    let
   7.160      val (nick, ts) = tabulate_built_in_rel debug univ_card nat_card int_card
   7.161                                             j0 x
   7.162    in ([(x, nick)], [KK.TupleSet ts]) end
   7.163  
   7.164 -(* bool -> int -> int -> int -> int -> KK.formula -> KK.bound list *)
   7.165  fun bounds_for_built_in_rels_in_formula debug univ_card nat_card int_card j0 =
   7.166    map (bound_for_built_in_rel debug univ_card nat_card int_card j0)
   7.167    o built_in_rels_in_formula
   7.168  
   7.169 -(* Proof.context -> bool -> string -> typ -> rep -> string *)
   7.170  fun bound_comment ctxt debug nick T R =
   7.171    short_name nick ^
   7.172    (if debug then " :: " ^ unyxml (Syntax.string_of_typ ctxt T) else "") ^
   7.173    " : " ^ string_for_rep R
   7.174  
   7.175 -(* Proof.context -> bool -> nut -> KK.bound *)
   7.176  fun bound_for_plain_rel ctxt debug (u as FreeRel (x, T, R, nick)) =
   7.177      ([(x, bound_comment ctxt debug nick T R)],
   7.178       if nick = @{const_name bisim_iterator_max} then
   7.179 @@ -299,7 +267,6 @@
   7.180    | bound_for_plain_rel _ _ u =
   7.181      raise NUT ("Nitpick_Kodkod.bound_for_plain_rel", [u])
   7.182  
   7.183 -(* Proof.context -> bool -> dtype_spec list -> nut -> KK.bound *)
   7.184  fun bound_for_sel_rel ctxt debug dtypes
   7.185          (FreeRel (x, T as Type (@{type_name fun}, [T1, T2]),
   7.186                    R as Func (Atom (_, j0), R2), nick)) =
   7.187 @@ -331,12 +298,9 @@
   7.188    | bound_for_sel_rel _ _ _ u =
   7.189      raise NUT ("Nitpick_Kodkod.bound_for_sel_rel", [u])
   7.190  
   7.191 -(* KK.bound list -> KK.bound list *)
   7.192  fun merge_bounds bs =
   7.193    let
   7.194 -    (* KK.bound -> int *)
   7.195      fun arity (zs, _) = fst (fst (hd zs))
   7.196 -    (* KK.bound list -> KK.bound -> KK.bound list -> KK.bound list *)
   7.197      fun add_bound ds b [] = List.revAppend (ds, [b])
   7.198        | add_bound ds b (c :: cs) =
   7.199          if arity b = arity c andalso snd b = snd c then
   7.200 @@ -345,40 +309,33 @@
   7.201            add_bound (c :: ds) b cs
   7.202    in fold (add_bound []) bs [] end
   7.203  
   7.204 -(* int -> int -> KK.rel_expr list *)
   7.205  fun unary_var_seq j0 n = map (curry KK.Var 1) (index_seq j0 n)
   7.206  
   7.207 -(* int list -> KK.rel_expr *)
   7.208  val singleton_from_combination = foldl1 KK.Product o map KK.Atom
   7.209 -(* rep -> KK.rel_expr list *)
   7.210  fun all_singletons_for_rep R =
   7.211    if is_lone_rep R then
   7.212      all_combinations_for_rep R |> map singleton_from_combination
   7.213    else
   7.214      raise REP ("Nitpick_Kodkod.all_singletons_for_rep", [R])
   7.215  
   7.216 -(* KK.rel_expr -> KK.rel_expr list *)
   7.217  fun unpack_products (KK.Product (r1, r2)) =
   7.218      unpack_products r1 @ unpack_products r2
   7.219    | unpack_products r = [r]
   7.220  fun unpack_joins (KK.Join (r1, r2)) = unpack_joins r1 @ unpack_joins r2
   7.221    | unpack_joins r = [r]
   7.222  
   7.223 -(* rep -> KK.rel_expr *)
   7.224  val empty_rel_for_rep = empty_n_ary_rel o arity_of_rep
   7.225  fun full_rel_for_rep R =
   7.226    case atom_schema_of_rep R of
   7.227      [] => raise REP ("Nitpick_Kodkod.full_rel_for_rep", [R])
   7.228    | schema => foldl1 KK.Product (map KK.AtomSeq schema)
   7.229  
   7.230 -(* int -> int list -> KK.decl list *)
   7.231  fun decls_for_atom_schema j0 schema =
   7.232    map2 (fn j => fn x => KK.DeclOne ((1, j), KK.AtomSeq x))
   7.233         (index_seq j0 (length schema)) schema
   7.234  
   7.235  (* The type constraint below is a workaround for a Poly/ML bug. *)
   7.236  
   7.237 -(* kodkod_constrs -> rep -> KK.rel_expr -> KK.formula *)
   7.238  fun d_n_ary_function ({kk_all, kk_join, kk_lone, kk_one, ...} : kodkod_constrs)
   7.239                       R r =
   7.240    let val body_R = body_rep R in
   7.241 @@ -420,14 +377,11 @@
   7.242        d_n_ary_function kk R r
   7.243    | kk_n_ary_function kk R r = d_n_ary_function kk R r
   7.244  
   7.245 -(* kodkod_constrs -> KK.rel_expr list -> KK.formula *)
   7.246  fun kk_disjoint_sets _ [] = KK.True
   7.247    | kk_disjoint_sets (kk as {kk_and, kk_no, kk_intersect, ...} : kodkod_constrs)
   7.248                       (r :: rs) =
   7.249      fold (kk_and o kk_no o kk_intersect r) rs (kk_disjoint_sets kk rs)
   7.250  
   7.251 -(* int -> kodkod_constrs -> (KK.rel_expr -> KK.rel_expr) -> KK.rel_expr
   7.252 -   -> KK.rel_expr *)
   7.253  fun basic_rel_rel_let j ({kk_rel_let, ...} : kodkod_constrs) f r =
   7.254    if inline_rel_expr r then
   7.255      f r
   7.256 @@ -435,36 +389,25 @@
   7.257      let val x = (KK.arity_of_rel_expr r, j) in
   7.258        kk_rel_let [KK.AssignRelReg (x, r)] (f (KK.RelReg x))
   7.259      end
   7.260 -(* kodkod_constrs -> (KK.rel_expr -> KK.rel_expr) -> KK.rel_expr
   7.261 -   -> KK.rel_expr *)
   7.262  val single_rel_rel_let = basic_rel_rel_let 0
   7.263 -(* kodkod_constrs -> (KK.rel_expr -> KK.rel_expr -> KK.rel_expr) -> KK.rel_expr
   7.264 -   -> KK.rel_expr -> KK.rel_expr *)
   7.265  fun double_rel_rel_let kk f r1 r2 =
   7.266    single_rel_rel_let kk (fn r1 => basic_rel_rel_let 1 kk (f r1) r2) r1
   7.267 -(* kodkod_constrs -> (KK.rel_expr -> KK.rel_expr -> KK.rel_expr -> KK.rel_expr)
   7.268 -   -> KK.rel_expr -> KK.rel_expr -> KK.rel_expr -> KK.rel_expr *)
   7.269  fun triple_rel_rel_let kk f r1 r2 r3 =
   7.270    double_rel_rel_let kk
   7.271        (fn r1 => fn r2 => basic_rel_rel_let 2 kk (f r1 r2) r3) r1 r2
   7.272  
   7.273 -(* kodkod_constrs -> int -> KK.formula -> KK.rel_expr *)
   7.274  fun atom_from_formula ({kk_rel_if, ...} : kodkod_constrs) j0 f =
   7.275    kk_rel_if f (KK.Atom (j0 + 1)) (KK.Atom j0)
   7.276 -(* kodkod_constrs -> rep -> KK.formula -> KK.rel_expr *)
   7.277  fun rel_expr_from_formula kk R f =
   7.278    case unopt_rep R of
   7.279      Atom (2, j0) => atom_from_formula kk j0 f
   7.280    | _ => raise REP ("Nitpick_Kodkod.rel_expr_from_formula", [R])
   7.281  
   7.282 -(* kodkod_cotrs -> int -> int -> KK.rel_expr -> KK.rel_expr list *)
   7.283  fun unpack_vect_in_chunks ({kk_project_seq, ...} : kodkod_constrs) chunk_arity
   7.284                            num_chunks r =
   7.285    List.tabulate (num_chunks, fn j => kk_project_seq r (j * chunk_arity)
   7.286                                                      chunk_arity)
   7.287  
   7.288 -(* kodkod_constrs -> bool -> rep -> rep -> KK.rel_expr -> KK.rel_expr
   7.289 -   -> KK.rel_expr *)
   7.290  fun kk_n_fold_join
   7.291          (kk as {kk_intersect, kk_product, kk_join, kk_project_seq, ...}) one R1
   7.292          res_R r1 r2 =
   7.293 @@ -484,8 +427,6 @@
   7.294              arity1 (arity_of_rep res_R)
   7.295      end
   7.296  
   7.297 -(* kodkod_constrs -> rep -> rep -> KK.rel_expr -> KK.rel_expr list
   7.298 -   -> KK.rel_expr list -> KK.rel_expr *)
   7.299  fun kk_case_switch (kk as {kk_union, kk_product, ...}) R1 R2 r rs1 rs2 =
   7.300    if rs1 = rs2 then r
   7.301    else kk_n_fold_join kk true R1 R2 r (fold1 kk_union (map2 kk_product rs1 rs2))
   7.302 @@ -493,7 +434,6 @@
   7.303  val lone_rep_fallback_max_card = 4096
   7.304  val some_j0 = 0
   7.305  
   7.306 -(* kodkod_constrs -> rep -> rep -> KK.rel_expr -> KK.rel_expr *)
   7.307  fun lone_rep_fallback kk new_R old_R r =
   7.308    if old_R = new_R then
   7.309      r
   7.310 @@ -510,7 +450,6 @@
   7.311        else
   7.312          raise REP ("Nitpick_Kodkod.lone_rep_fallback", [old_R, new_R])
   7.313      end
   7.314 -(* kodkod_constrs -> int * int -> rep -> KK.rel_expr -> KK.rel_expr *)
   7.315  and atom_from_rel_expr kk x old_R r =
   7.316    case old_R of
   7.317      Func (R1, R2) =>
   7.318 @@ -523,7 +462,6 @@
   7.319      end
   7.320    | Opt _ => raise REP ("Nitpick_Kodkod.atom_from_rel_expr", [old_R])
   7.321    | _ => lone_rep_fallback kk (Atom x) old_R r
   7.322 -(* kodkod_constrs -> rep list -> rep -> KK.rel_expr -> KK.rel_expr *)
   7.323  and struct_from_rel_expr kk Rs old_R r =
   7.324    case old_R of
   7.325      Atom _ => lone_rep_fallback kk (Struct Rs) old_R r
   7.326 @@ -547,7 +485,6 @@
   7.327          lone_rep_fallback kk (Struct Rs) old_R r
   7.328      end
   7.329    | _ => raise REP ("Nitpick_Kodkod.struct_from_rel_expr", [old_R])
   7.330 -(* kodkod_constrs -> int -> rep -> rep -> KK.rel_expr -> KK.rel_expr *)
   7.331  and vect_from_rel_expr kk k R old_R r =
   7.332    case old_R of
   7.333      Atom _ => lone_rep_fallback kk (Vect (k, R)) old_R r
   7.334 @@ -570,7 +507,6 @@
   7.335                                           (kk_n_fold_join kk true R1 R2 arg_r r))
   7.336                 (all_singletons_for_rep R1))
   7.337    | _ => raise REP ("Nitpick_Kodkod.vect_from_rel_expr", [old_R])
   7.338 -(* kodkod_constrs -> rep -> rep -> rep -> KK.rel_expr -> KK.rel_expr *)
   7.339  and func_from_no_opt_rel_expr kk R1 R2 (Atom x) r =
   7.340      let
   7.341        val dom_card = card_of_rep R1
   7.342 @@ -599,7 +535,6 @@
   7.343         let
   7.344           val args_rs = all_singletons_for_rep R1
   7.345           val vals_rs = unpack_vect_in_chunks kk 1 k r
   7.346 -         (* KK.rel_expr -> KK.rel_expr -> KK.rel_expr *)
   7.347           fun empty_or_singleton_set_for arg_r val_r =
   7.348             #kk_join kk val_r (#kk_product kk (KK.Atom (j0 + 1)) arg_r)
   7.349         in
   7.350 @@ -682,7 +617,6 @@
   7.351          end
   7.352      | _ => raise REP ("Nitpick_Kodkod.func_from_no_opt_rel_expr",
   7.353                        [old_R, Func (R1, R2)])
   7.354 -(* kodkod_constrs -> rep -> rep -> KK.rel_expr -> KK.rel_expr *)
   7.355  and rel_expr_from_rel_expr kk new_R old_R r =
   7.356    let
   7.357      val unopt_old_R = unopt_rep old_R
   7.358 @@ -702,25 +636,20 @@
   7.359                           [old_R, new_R]))
   7.360            unopt_old_R r
   7.361    end
   7.362 -(* kodkod_constrs -> rep -> rep -> rep -> KK.rel_expr -> KK.rel_expr *)
   7.363  and rel_expr_to_func kk R1 R2 = rel_expr_from_rel_expr kk (Func (R1, R2))
   7.364  
   7.365 -(* kodkod_constrs -> typ -> KK.rel_expr -> KK.rel_expr *)
   7.366  fun bit_set_from_atom ({kk_join, ...} : kodkod_constrs) T r =
   7.367    kk_join r (KK.Rel (if T = @{typ "unsigned_bit word"} then
   7.368                         unsigned_bit_word_sel_rel
   7.369                       else
   7.370                         signed_bit_word_sel_rel))
   7.371 -(* kodkod_constrs -> typ -> KK.rel_expr -> KK.int_expr *)
   7.372  val int_expr_from_atom = KK.SetSum ooo bit_set_from_atom
   7.373 -(* kodkod_constrs -> typ -> rep -> KK.int_expr -> KK.rel_expr *)
   7.374  fun atom_from_int_expr (kk as {kk_rel_eq, kk_comprehension, ...}
   7.375                          : kodkod_constrs) T R i =
   7.376    kk_comprehension (decls_for_atom_schema ~1 (atom_schema_of_rep R))
   7.377                     (kk_rel_eq (bit_set_from_atom kk T (KK.Var (1, ~1)))
   7.378                                (KK.Bits i))
   7.379  
   7.380 -(* kodkod_constrs -> nut -> KK.formula *)
   7.381  fun declarative_axiom_for_plain_rel kk (FreeRel (x, _, R as Func _, nick)) =
   7.382      kk_n_ary_function kk (R |> nick = @{const_name List.set} ? unopt_rep)
   7.383                        (KK.Rel x)
   7.384 @@ -732,17 +661,13 @@
   7.385    | declarative_axiom_for_plain_rel _ u =
   7.386      raise NUT ("Nitpick_Kodkod.declarative_axiom_for_plain_rel", [u])
   7.387  
   7.388 -(* nut NameTable.table -> styp -> KK.rel_expr * rep * int *)
   7.389  fun const_triple rel_table (x as (s, T)) =
   7.390    case the_name rel_table (ConstName (s, T, Any)) of
   7.391      FreeRel ((n, j), _, R, _) => (KK.Rel (n, j), R, n)
   7.392    | _ => raise TERM ("Nitpick_Kodkod.const_triple", [Const x])
   7.393  
   7.394 -(* nut NameTable.table -> styp -> KK.rel_expr *)
   7.395  fun discr_rel_expr rel_table = #1 o const_triple rel_table o discr_for_constr
   7.396  
   7.397 -(* hol_context -> bool -> kodkod_constrs -> nut NameTable.table
   7.398 -   -> dtype_spec list -> styp -> int -> nfa_transition list *)
   7.399  fun nfa_transitions_for_sel hol_ctxt binarize
   7.400                              ({kk_project, ...} : kodkod_constrs) rel_table
   7.401                              (dtypes : dtype_spec list) constr_x n =
   7.402 @@ -757,14 +682,10 @@
   7.403                     else SOME (kk_project r (map KK.Num [0, j]), T))
   7.404                 (index_seq 1 (arity - 1) ~~ tl type_schema)
   7.405    end
   7.406 -(* hol_context -> bool -> kodkod_constrs -> nut NameTable.table
   7.407 -   -> dtype_spec list -> styp -> nfa_transition list *)
   7.408  fun nfa_transitions_for_constr hol_ctxt binarize kk rel_table dtypes
   7.409                                 (x as (_, T)) =
   7.410    maps (nfa_transitions_for_sel hol_ctxt binarize kk rel_table dtypes x)
   7.411         (index_seq 0 (num_sels_for_constr_type T))
   7.412 -(* hol_context -> bool -> kodkod_constrs -> nut NameTable.table
   7.413 -   -> dtype_spec list -> dtype_spec -> nfa_entry option *)
   7.414  fun nfa_entry_for_datatype _ _ _ _ _ ({co = true, ...} : dtype_spec) = NONE
   7.415    | nfa_entry_for_datatype _ _ _ _ _ {standard = false, ...} = NONE
   7.416    | nfa_entry_for_datatype _ _ _ _ _ {deep = false, ...} = NONE
   7.417 @@ -775,12 +696,10 @@
   7.418  
   7.419  val empty_rel = KK.Product (KK.None, KK.None)
   7.420  
   7.421 -(* nfa_table -> typ -> typ -> KK.rel_expr list *)
   7.422  fun direct_path_rel_exprs nfa start_T final_T =
   7.423    case AList.lookup (op =) nfa final_T of
   7.424      SOME trans => map fst (filter (curry (op =) start_T o snd) trans)
   7.425    | NONE => []
   7.426 -(* kodkod_constrs -> nfa_table -> typ list -> typ -> typ -> KK.rel_expr *)
   7.427  and any_path_rel_expr ({kk_union, ...} : kodkod_constrs) nfa [] start_T
   7.428                        final_T =
   7.429      fold kk_union (direct_path_rel_exprs nfa start_T final_T)
   7.430 @@ -788,14 +707,11 @@
   7.431    | any_path_rel_expr (kk as {kk_union, ...}) nfa (T :: Ts) start_T final_T =
   7.432      kk_union (any_path_rel_expr kk nfa Ts start_T final_T)
   7.433               (knot_path_rel_expr kk nfa Ts start_T T final_T)
   7.434 -(* kodkod_constrs -> nfa_table -> typ list -> typ -> typ -> typ
   7.435 -   -> KK.rel_expr *)
   7.436  and knot_path_rel_expr (kk as {kk_join, kk_reflexive_closure, ...}) nfa Ts
   7.437                         start_T knot_T final_T =
   7.438    kk_join (kk_join (any_path_rel_expr kk nfa Ts knot_T final_T)
   7.439                     (kk_reflexive_closure (loop_path_rel_expr kk nfa Ts knot_T)))
   7.440            (any_path_rel_expr kk nfa Ts start_T knot_T)
   7.441 -(* kodkod_constrs -> nfa_table -> typ list -> typ -> KK.rel_expr *)
   7.442  and loop_path_rel_expr ({kk_union, ...} : kodkod_constrs) nfa [] start_T =
   7.443      fold kk_union (direct_path_rel_exprs nfa start_T start_T) empty_rel
   7.444    | loop_path_rel_expr (kk as {kk_union, kk_closure, ...}) nfa (T :: Ts)
   7.445 @@ -806,12 +722,9 @@
   7.446        kk_union (loop_path_rel_expr kk nfa Ts start_T)
   7.447                 (knot_path_rel_expr kk nfa Ts start_T T start_T)
   7.448  
   7.449 -(* nfa_table -> unit NfaGraph.T *)
   7.450  fun graph_for_nfa nfa =
   7.451    let
   7.452 -    (* typ -> unit NfaGraph.T -> unit NfaGraph.T *)
   7.453      fun new_node T = perhaps (try (NfaGraph.new_node (T, ())))
   7.454 -    (* nfa_table -> unit NfaGraph.T -> unit NfaGraph.T *)
   7.455      fun add_nfa [] = I
   7.456        | add_nfa ((_, []) :: nfa) = add_nfa nfa
   7.457        | add_nfa ((T, ((_, T') :: transitions)) :: nfa) =
   7.458 @@ -819,25 +732,19 @@
   7.459          new_node T' o new_node T
   7.460    in add_nfa nfa NfaGraph.empty end
   7.461  
   7.462 -(* nfa_table -> nfa_table list *)
   7.463  fun strongly_connected_sub_nfas nfa =
   7.464    nfa |> graph_for_nfa |> NfaGraph.strong_conn
   7.465        |> map (fn keys => filter (member (op =) keys o fst) nfa)
   7.466  
   7.467 -(* kodkod_constrs -> nfa_table -> typ -> KK.formula *)
   7.468  fun acyclicity_axiom_for_datatype kk nfa start_T =
   7.469    #kk_no kk (#kk_intersect kk
   7.470                   (loop_path_rel_expr kk nfa (map fst nfa) start_T) KK.Iden)
   7.471 -(* hol_context -> bool -> kodkod_constrs -> nut NameTable.table
   7.472 -   -> dtype_spec list -> KK.formula list *)
   7.473  fun acyclicity_axioms_for_datatypes hol_ctxt binarize kk rel_table dtypes =
   7.474    map_filter (nfa_entry_for_datatype hol_ctxt binarize kk rel_table dtypes)
   7.475               dtypes
   7.476    |> strongly_connected_sub_nfas
   7.477    |> maps (fn nfa => map (acyclicity_axiom_for_datatype kk nfa o fst) nfa)
   7.478  
   7.479 -(* hol_context -> bool -> int -> kodkod_constrs -> nut NameTable.table
   7.480 -   -> KK.rel_expr -> constr_spec -> int -> KK.formula *)
   7.481  fun sel_axiom_for_sel hol_ctxt binarize j0
   7.482          (kk as {kk_all, kk_formula_if, kk_subset, kk_no, kk_join, ...})
   7.483          rel_table dom_r ({const, delta, epsilon, exclusive, ...} : constr_spec)
   7.484 @@ -857,8 +764,6 @@
   7.485                                (kk_n_ary_function kk R2 r') (kk_no r'))
   7.486        end
   7.487    end
   7.488 -(* hol_context -> bool -> int -> int -> kodkod_constrs -> nut NameTable.table
   7.489 -   -> constr_spec -> KK.formula list *)
   7.490  fun sel_axioms_for_constr hol_ctxt binarize bits j0 kk rel_table
   7.491          (constr as {const, delta, epsilon, explicit_max, ...}) =
   7.492    let
   7.493 @@ -885,19 +790,14 @@
   7.494              (index_seq 0 (num_sels_for_constr_type (snd const)))
   7.495        end
   7.496    end
   7.497 -(* hol_context -> bool -> int -> int -> kodkod_constrs -> nut NameTable.table
   7.498 -   -> dtype_spec -> KK.formula list *)
   7.499  fun sel_axioms_for_datatype hol_ctxt binarize bits j0 kk rel_table
   7.500                              ({constrs, ...} : dtype_spec) =
   7.501    maps (sel_axioms_for_constr hol_ctxt binarize bits j0 kk rel_table) constrs
   7.502  
   7.503 -(* hol_context -> bool -> kodkod_constrs -> nut NameTable.table -> constr_spec
   7.504 -   -> KK.formula list *)
   7.505  fun uniqueness_axiom_for_constr hol_ctxt binarize
   7.506          ({kk_all, kk_implies, kk_and, kk_rel_eq, kk_lone, kk_join, ...}
   7.507           : kodkod_constrs) rel_table ({const, ...} : constr_spec) =
   7.508    let
   7.509 -    (* KK.rel_expr -> KK.formula *)
   7.510      fun conjunct_for_sel r =
   7.511        kk_rel_eq (kk_join (KK.Var (1, 0)) r) (kk_join (KK.Var (1, 1)) r)
   7.512      val num_sels = num_sels_for_constr_type (snd const)
   7.513 @@ -915,16 +815,11 @@
   7.514                    (fold1 kk_and (map (conjunct_for_sel o #1) (tl triples)))
   7.515                    (kk_rel_eq (KK.Var (1, 0)) (KK.Var (1, 1))))
   7.516    end
   7.517 -(* hol_context -> bool -> kodkod_constrs -> nut NameTable.table -> dtype_spec
   7.518 -   -> KK.formula list *)
   7.519  fun uniqueness_axioms_for_datatype hol_ctxt binarize kk rel_table
   7.520                                     ({constrs, ...} : dtype_spec) =
   7.521    map (uniqueness_axiom_for_constr hol_ctxt binarize kk rel_table) constrs
   7.522  
   7.523 -(* constr_spec -> int *)
   7.524  fun effective_constr_max ({delta, epsilon, ...} : constr_spec) = epsilon - delta
   7.525 -(* int -> kodkod_constrs -> nut NameTable.table -> dtype_spec
   7.526 -   -> KK.formula list *)
   7.527  fun partition_axioms_for_datatype j0 (kk as {kk_rel_eq, kk_union, ...})
   7.528                                    rel_table
   7.529                                    ({card, constrs, ...} : dtype_spec) =
   7.530 @@ -936,8 +831,6 @@
   7.531         kk_disjoint_sets kk rs]
   7.532      end
   7.533  
   7.534 -(* hol_context -> bool -> int -> int Typtab.table -> kodkod_constrs
   7.535 -   -> nut NameTable.table -> dtype_spec -> KK.formula list *)
   7.536  fun other_axioms_for_datatype _ _ _ _ _ _ {deep = false, ...} = []
   7.537    | other_axioms_for_datatype hol_ctxt binarize bits ofs kk rel_table
   7.538                                (dtype as {typ, ...}) =
   7.539 @@ -947,15 +840,12 @@
   7.540        partition_axioms_for_datatype j0 kk rel_table dtype
   7.541      end
   7.542  
   7.543 -(* hol_context -> bool -> int -> int Typtab.table -> kodkod_constrs
   7.544 -   -> nut NameTable.table -> dtype_spec list -> KK.formula list *)
   7.545  fun declarative_axioms_for_datatypes hol_ctxt binarize bits ofs kk rel_table
   7.546                                       dtypes =
   7.547    acyclicity_axioms_for_datatypes hol_ctxt binarize kk rel_table dtypes @
   7.548    maps (other_axioms_for_datatype hol_ctxt binarize bits ofs kk rel_table)
   7.549         dtypes
   7.550  
   7.551 -(* int Typtab.table -> kodkod_constrs -> nut -> KK.formula *)
   7.552  fun kodkod_formula_from_nut ofs
   7.553          (kk as {kk_all, kk_exist, kk_formula_let, kk_formula_if, kk_or, kk_not,
   7.554                  kk_iff, kk_implies, kk_and, kk_subset, kk_rel_eq, kk_no,
   7.555 @@ -970,17 +860,13 @@
   7.556      val false_atom = KK.Atom bool_j0
   7.557      val true_atom = KK.Atom (bool_j0 + 1)
   7.558  
   7.559 -    (* polarity -> int -> KK.rel_expr -> KK.formula *)
   7.560      fun formula_from_opt_atom polar j0 r =
   7.561        case polar of
   7.562          Neg => kk_not (kk_rel_eq r (KK.Atom j0))
   7.563        | _ => kk_rel_eq r (KK.Atom (j0 + 1))
   7.564 -    (* int -> KK.rel_expr -> KK.formula *)
   7.565      val formula_from_atom = formula_from_opt_atom Pos
   7.566  
   7.567 -    (* KK.formula -> KK.formula -> KK.formula *)
   7.568      fun kk_notimplies f1 f2 = kk_and f1 (kk_not f2)
   7.569 -    (* KK.rel_expr -> KK.rel_expr -> KK.rel_expr *)
   7.570      val kk_or3 =
   7.571        double_rel_rel_let kk
   7.572            (fn r1 => fn r2 =>
   7.573 @@ -993,21 +879,15 @@
   7.574                          (kk_intersect r1 r2))
   7.575      fun kk_notimplies3 r1 r2 = kk_and3 r1 (kk_not3 r2)
   7.576  
   7.577 -    (* int -> KK.rel_expr -> KK.formula list *)
   7.578      val unpack_formulas =
   7.579        map (formula_from_atom bool_j0) oo unpack_vect_in_chunks kk 1
   7.580 -    (* (KK.formula -> KK.formula -> KK.formula) -> int -> KK.rel_expr
   7.581 -       -> KK.rel_expr -> KK.rel_expr *)
   7.582      fun kk_vect_set_op connective k r1 r2 =
   7.583        fold1 kk_product (map2 (atom_from_formula kk bool_j0 oo connective)
   7.584                               (unpack_formulas k r1) (unpack_formulas k r2))
   7.585 -    (* (KK.formula -> KK.formula -> KK.formula) -> int -> KK.rel_expr
   7.586 -       -> KK.rel_expr -> KK.formula *)
   7.587      fun kk_vect_set_bool_op connective k r1 r2 =
   7.588        fold1 kk_and (map2 connective (unpack_formulas k r1)
   7.589                           (unpack_formulas k r2))
   7.590  
   7.591 -    (* nut -> KK.formula *)
   7.592      fun to_f u =
   7.593        case rep_of u of
   7.594          Formula polar =>
   7.595 @@ -1060,7 +940,6 @@
   7.596               else
   7.597                 let
   7.598                   (* FIXME: merge with similar code below *)
   7.599 -                 (* bool -> nut -> KK.rel_expr *)
   7.600                   fun set_to_r widen u =
   7.601                     if widen then
   7.602                       kk_difference (full_rel_for_rep dom_R)
   7.603 @@ -1078,7 +957,6 @@
   7.604                kk_iff (to_f_with_polarity polar u1) (to_f_with_polarity polar u2)
   7.605              | min_R =>
   7.606                let
   7.607 -                (* nut -> nut list *)
   7.608                  fun args (Op2 (Apply, _, _, u1, u2)) = u2 :: args u1
   7.609                    | args (Tuple (_, _, us)) = us
   7.610                    | args _ = []
   7.611 @@ -1177,14 +1055,12 @@
   7.612           | _ => raise NUT ("Nitpick_Kodkod.to_f", [u]))
   7.613        | Atom (2, j0) => formula_from_atom j0 (to_r u)
   7.614        | _ => raise NUT ("Nitpick_Kodkod.to_f", [u])
   7.615 -    (* polarity -> nut -> KK.formula *)
   7.616      and to_f_with_polarity polar u =
   7.617        case rep_of u of
   7.618          Formula _ => to_f u
   7.619        | Atom (2, j0) => formula_from_atom j0 (to_r u)
   7.620        | Opt (Atom (2, j0)) => formula_from_opt_atom polar j0 (to_r u)
   7.621        | _ => raise NUT ("Nitpick_Kodkod.to_f_with_polarity", [u])
   7.622 -    (* nut -> KK.rel_expr *)
   7.623      and to_r u =
   7.624        case u of
   7.625          Cst (False, _, Atom _) => false_atom
   7.626 @@ -1523,7 +1399,6 @@
   7.627             | Opt (Atom (2, _)) =>
   7.628               let
   7.629                 (* FIXME: merge with similar code above *)
   7.630 -               (* rep -> rep -> nut -> KK.rel_expr *)
   7.631                 fun must R1 R2 u =
   7.632                   kk_join (to_rep (Func (Struct [R1, R2], body_R)) u) true_atom
   7.633                 fun may R1 R2 u =
   7.634 @@ -1558,9 +1433,7 @@
   7.635                          (to_rep (Func (b_R, Formula Neut)) u2)
   7.636             | Opt (Atom (2, _)) =>
   7.637               let
   7.638 -               (* KK.rel_expr -> rep -> nut -> KK.rel_expr *)
   7.639                 fun do_nut r R u = kk_join (to_rep (Func (R, body_R)) u) r
   7.640 -               (* KK.rel_expr -> KK.rel_expr *)
   7.641                 fun do_term r =
   7.642                   kk_product (kk_product (do_nut r a_R u1) (do_nut r b_R u2)) r
   7.643               in kk_union (do_term true_atom) (do_term false_atom) end
   7.644 @@ -1572,7 +1445,6 @@
   7.645             (Func (R11, R12), Func (R21, Formula Neut)) =>
   7.646             if R21 = R11 andalso is_lone_rep R12 then
   7.647               let
   7.648 -               (* KK.rel_expr -> KK.rel_expr *)
   7.649                 fun big_join r = kk_n_fold_join kk false R21 R12 r (to_r u1)
   7.650                 val core_r = big_join (to_r u2)
   7.651                 val core_R = Func (R12, Formula Neut)
   7.652 @@ -1666,39 +1538,32 @@
   7.653        | FreeRel (x, _, _, _) => KK.Rel x
   7.654        | RelReg (j, _, R) => KK.RelReg (arity_of_rep R, j)
   7.655        | u => raise NUT ("Nitpick_Kodkod.to_r", [u])
   7.656 -    (* nut -> KK.decl *)
   7.657      and to_decl (BoundRel (x, _, R, _)) =
   7.658          KK.DeclOne (x, KK.AtomSeq (the_single (atom_schema_of_rep R)))
   7.659        | to_decl u = raise NUT ("Nitpick_Kodkod.to_decl", [u])
   7.660 -    (* nut -> KK.expr_assign *)
   7.661      and to_expr_assign (FormulaReg (j, _, _)) u =
   7.662          KK.AssignFormulaReg (j, to_f u)
   7.663        | to_expr_assign (RelReg (j, _, R)) u =
   7.664          KK.AssignRelReg ((arity_of_rep R, j), to_r u)
   7.665        | to_expr_assign u1 _ = raise NUT ("Nitpick_Kodkod.to_expr_assign", [u1])
   7.666 -    (* int * int -> nut -> KK.rel_expr *)
   7.667      and to_atom (x as (k, j0)) u =
   7.668        case rep_of u of
   7.669          Formula _ => atom_from_formula kk j0 (to_f u)
   7.670        | Unit => if k = 1 then KK.Atom j0
   7.671                  else raise NUT ("Nitpick_Kodkod.to_atom", [u])
   7.672        | R => atom_from_rel_expr kk x R (to_r u)
   7.673 -    (* rep list -> nut -> KK.rel_expr *)
   7.674      and to_struct Rs u =
   7.675        case rep_of u of
   7.676          Unit => full_rel_for_rep (Struct Rs)
   7.677        | R' => struct_from_rel_expr kk Rs R' (to_r u)
   7.678 -    (* int -> rep -> nut -> KK.rel_expr *)
   7.679      and to_vect k R u =
   7.680        case rep_of u of
   7.681          Unit => full_rel_for_rep (Vect (k, R))
   7.682        | R' => vect_from_rel_expr kk k R R' (to_r u)
   7.683 -    (* rep -> rep -> nut -> KK.rel_expr *)
   7.684      and to_func R1 R2 u =
   7.685        case rep_of u of
   7.686          Unit => full_rel_for_rep (Func (R1, R2))
   7.687        | R' => rel_expr_to_func kk R1 R2 R' (to_r u)
   7.688 -    (* rep -> nut -> KK.rel_expr *)
   7.689      and to_opt R u =
   7.690        let val old_R = rep_of u in
   7.691          if is_opt_rep old_R then
   7.692 @@ -1706,16 +1571,13 @@
   7.693          else
   7.694            to_rep R u
   7.695        end
   7.696 -    (* rep -> nut -> KK.rel_expr *)
   7.697      and to_rep (Atom x) u = to_atom x u
   7.698        | to_rep (Struct Rs) u = to_struct Rs u
   7.699        | to_rep (Vect (k, R)) u = to_vect k R u
   7.700        | to_rep (Func (R1, R2)) u = to_func R1 R2 u
   7.701        | to_rep (Opt R) u = to_opt R u
   7.702        | to_rep R _ = raise REP ("Nitpick_Kodkod.to_rep", [R])
   7.703 -    (* nut -> KK.rel_expr *)
   7.704      and to_integer u = to_opt (one_rep ofs (type_of u) (rep_of u)) u
   7.705 -    (* nut list -> rep -> KK.rel_expr -> KK.rel_expr *)
   7.706      and to_guard guard_us R r =
   7.707        let
   7.708          val unpacked_rs = unpack_joins r
   7.709 @@ -1733,16 +1595,13 @@
   7.710          if null guard_fs then r
   7.711          else kk_rel_if (fold1 kk_or guard_fs) (empty_rel_for_rep R) r
   7.712        end
   7.713 -    (* rep -> rep -> KK.rel_expr -> int -> KK.rel_expr *)
   7.714      and to_project new_R old_R r j0 =
   7.715        rel_expr_from_rel_expr kk new_R old_R
   7.716                               (kk_project_seq r j0 (arity_of_rep old_R))
   7.717 -    (* rep list -> nut list -> KK.rel_expr *)
   7.718      and to_product Rs us =
   7.719        case map (uncurry to_opt) (filter (not_equal Unit o fst) (Rs ~~ us)) of
   7.720          [] => raise REP ("Nitpick_Kodkod.to_product", Rs)
   7.721        | rs => fold1 kk_product rs
   7.722 -    (* int -> typ -> rep -> nut -> KK.rel_expr *)
   7.723      and to_nth_pair_sel n res_T res_R u =
   7.724        case u of
   7.725          Tuple (_, _, us) => to_rep res_R (nth us n)
   7.726 @@ -1770,9 +1629,6 @@
   7.727                                 (to_rep res_R (Cst (Unity, res_T, Unit)))
   7.728                 | _ => to_project res_R nth_R (to_rep (Opt (Struct Rs)) u) j0
   7.729               end
   7.730 -    (* (KK.formula -> KK.formula -> KK.formula)
   7.731 -       -> (KK.rel_expr -> KK.rel_expr -> KK.formula) -> nut -> nut
   7.732 -       -> KK.formula *)
   7.733      and to_set_bool_op connective set_oper u1 u2 =
   7.734        let
   7.735          val min_R = min_rep (rep_of u1) (rep_of u2)
   7.736 @@ -1788,12 +1644,6 @@
   7.737                                         (kk_join r2 true_atom)
   7.738          | _ => raise REP ("Nitpick_Kodkod.to_set_bool_op", [min_R])
   7.739        end
   7.740 -    (* (KK.formula -> KK.formula -> KK.formula)
   7.741 -       -> (KK.rel_expr -> KK.rel_expr -> KK.rel_expr)
   7.742 -       -> (KK.rel_expr -> KK.rel_expr -> KK.formula)
   7.743 -       -> (KK.rel_expr -> KK.rel_expr -> KK.formula)
   7.744 -       -> (KK.rel_expr -> KK.rel_expr -> KK.formula) -> bool -> rep -> nut
   7.745 -       -> nut -> KK.rel_expr *)
   7.746      and to_set_op connective connective3 set_oper true_set_oper false_set_oper
   7.747                    neg_second R u1 u2 =
   7.748        let
   7.749 @@ -1825,11 +1675,9 @@
   7.750                     r1 r2
   7.751               | _ => raise REP ("Nitpick_Kodkod.to_set_op", [min_R]))
   7.752        end
   7.753 -    (* typ -> rep -> (KK.int_expr -> KK.int_expr) -> KK.rel_expr *)
   7.754      and to_bit_word_unary_op T R oper =
   7.755        let
   7.756          val Ts = strip_type T ||> single |> op @
   7.757 -        (* int -> KK.int_expr *)
   7.758          fun int_arg j = int_expr_from_atom kk (nth Ts j) (KK.Var (1, j))
   7.759        in
   7.760          kk_comprehension (decls_for_atom_schema 0 (atom_schema_of_rep R))
   7.761 @@ -1837,12 +1685,9 @@
   7.762                   (map (fn j => KK.AssignIntReg (j, int_arg j)) (0 upto 1),
   7.763                    KK.IntEq (KK.IntReg 1, oper (KK.IntReg 0))))
   7.764        end
   7.765 -    (* typ -> rep -> (KK.int_expr -> KK.int_expr -> KK.int_expr -> bool) option
   7.766 -       -> (KK.int_expr -> KK.int_expr -> KK.int_expr) option -> KK.rel_expr *)
   7.767      and to_bit_word_binary_op T R opt_guard opt_oper =
   7.768        let
   7.769          val Ts = strip_type T ||> single |> op @
   7.770 -        (* int -> KK.int_expr *)
   7.771          fun int_arg j = int_expr_from_atom kk (nth Ts j) (KK.Var (1, j))
   7.772        in
   7.773          kk_comprehension (decls_for_atom_schema 0 (atom_schema_of_rep R))
   7.774 @@ -1859,7 +1704,6 @@
   7.775                              [KK.IntEq (KK.IntReg 2,
   7.776                                         oper (KK.IntReg 0) (KK.IntReg 1))]))))
   7.777        end
   7.778 -    (* rep -> rep -> KK.rel_expr -> nut -> KK.rel_expr *)
   7.779      and to_apply (R as Formula _) func_u arg_u =
   7.780          raise REP ("Nitpick_Kodkod.to_apply", [R])
   7.781        | to_apply res_R func_u arg_u =
   7.782 @@ -1896,7 +1740,6 @@
   7.783                (kk_n_fold_join kk true R1 R2 (to_opt R1 arg_u) (to_r func_u))
   7.784            |> body_rep R2 = Formula Neut ? to_guard [arg_u] res_R
   7.785          | _ => raise NUT ("Nitpick_Kodkod.to_apply", [func_u])
   7.786 -    (* int -> rep -> rep -> KK.rel_expr -> nut *)
   7.787      and to_apply_vect k R' res_R func_r arg_u =
   7.788        let
   7.789          val arg_R = one_rep ofs (type_of arg_u) (unopt_rep (rep_of arg_u))
   7.790 @@ -1906,10 +1749,8 @@
   7.791          kk_case_switch kk arg_R res_R (to_opt arg_R arg_u)
   7.792                         (all_singletons_for_rep arg_R) vect_rs
   7.793        end
   7.794 -    (* bool -> nut -> KK.formula *)
   7.795      and to_could_be_unrep neg u =
   7.796        if neg andalso is_opt_rep (rep_of u) then kk_no (to_r u) else KK.False
   7.797 -    (* nut -> KK.rel_expr -> KK.rel_expr *)
   7.798      and to_compare_with_unrep u r =
   7.799        if is_opt_rep (rep_of u) then
   7.800          kk_rel_if (kk_some (to_r u)) r (empty_rel_for_rep (rep_of u))
     8.1 --- a/src/HOL/Tools/Nitpick/nitpick_model.ML	Sat Apr 24 16:17:30 2010 +0200
     8.2 +++ b/src/HOL/Tools/Nitpick/nitpick_model.ML	Sat Apr 24 16:33:01 2010 +0200
     8.3 @@ -16,7 +16,6 @@
     8.4      show_skolems: bool,
     8.5      show_datatypes: bool,
     8.6      show_consts: bool}
     8.7 -
     8.8    type term_postprocessor =
     8.9      Proof.context -> string -> (typ -> term list) -> typ -> term -> term
    8.10  
    8.11 @@ -82,10 +81,8 @@
    8.12  
    8.13  type atom_pool = ((string * int) * int list) list
    8.14  
    8.15 -(* Proof.context -> ((string * string) * (string * string)) * Proof.context *)
    8.16  fun add_wacky_syntax ctxt =
    8.17    let
    8.18 -    (* term -> string *)
    8.19      val name_of = fst o dest_Const
    8.20      val thy = ProofContext.theory_of ctxt |> Context.reject_draft
    8.21      val (maybe_t, thy) =
    8.22 @@ -107,7 +104,6 @@
    8.23  
    8.24  (** Term reconstruction **)
    8.25  
    8.26 -(* atom_pool Unsynchronized.ref -> string -> int -> int -> string *)
    8.27  fun nth_atom_suffix pool s j k =
    8.28    (case AList.lookup (op =) (!pool) (s, k) of
    8.29       SOME js =>
    8.30 @@ -119,7 +115,6 @@
    8.31    |> nat_subscript
    8.32    |> (s <> "" andalso Symbol.is_ascii_digit (List.last (explode s)))
    8.33       ? prefix "\<^isub>,"
    8.34 -(* atom_pool Unsynchronized.ref -> string -> typ -> int -> int -> string *)
    8.35  fun nth_atom_name pool prefix (Type (s, _)) j k =
    8.36      let val s' = shortest_name s in
    8.37        prefix ^ (if String.isPrefix "\\" s' then s' else substring (s', 0, 1)) ^
    8.38 @@ -129,18 +124,15 @@
    8.39      prefix ^ perhaps (try (unprefix "'")) s ^ nth_atom_suffix pool s j k
    8.40    | nth_atom_name _ _ T _ _ =
    8.41      raise TYPE ("Nitpick_Model.nth_atom_name", [T], [])
    8.42 -(* atom_pool Unsynchronized.ref -> bool -> typ -> int -> int -> term *)
    8.43  fun nth_atom pool for_auto T j k =
    8.44    if for_auto then
    8.45      Free (nth_atom_name pool (hd (space_explode "." nitpick_prefix)) T j k, T)
    8.46    else
    8.47      Const (nth_atom_name pool "" T j k, T)
    8.48  
    8.49 -(* term -> real *)
    8.50  fun extract_real_number (Const (@{const_name divide}, _) $ t1 $ t2) =
    8.51      real (snd (HOLogic.dest_number t1)) / real (snd (HOLogic.dest_number t2))
    8.52    | extract_real_number t = real (snd (HOLogic.dest_number t))
    8.53 -(* term * term -> order *)
    8.54  fun nice_term_ord (Abs (_, _, t1), Abs (_, _, t2)) = nice_term_ord (t1, t2)
    8.55    | nice_term_ord tp = Real.compare (pairself extract_real_number tp)
    8.56      handle TERM ("dest_number", _) =>
    8.57 @@ -151,16 +143,12 @@
    8.58                | ord => ord)
    8.59             | _ => Term_Ord.fast_term_ord tp
    8.60  
    8.61 -(* typ -> term_postprocessor -> theory -> theory *)
    8.62  fun register_term_postprocessor T p = Data.map (cons (T, p))
    8.63 -(* typ -> theory -> theory *)
    8.64  fun unregister_term_postprocessor T = Data.map (AList.delete (op =) T)
    8.65  
    8.66 -(* nut NameTable.table -> KK.raw_bound list -> nut -> int list list *)
    8.67  fun tuple_list_for_name rel_table bounds name =
    8.68    the (AList.lookup (op =) bounds (the_rel rel_table name)) handle NUT _ => [[]]
    8.69  
    8.70 -(* term -> term *)
    8.71  fun unarize_unbox_etc_term (Const (@{const_name FinFun}, _) $ t1) =
    8.72      unarize_unbox_etc_term t1
    8.73    | unarize_unbox_etc_term (Const (@{const_name FunBox}, _) $ t1) =
    8.74 @@ -185,7 +173,6 @@
    8.75    | unarize_unbox_etc_term (Abs (s, T, t')) =
    8.76      Abs (s, uniterize_unarize_unbox_etc_type T, unarize_unbox_etc_term t')
    8.77  
    8.78 -(* typ -> typ -> (typ * typ) * (typ * typ) *)
    8.79  fun factor_out_types (T1 as Type (@{type_name "*"}, [T11, T12]))
    8.80                       (T2 as Type (@{type_name "*"}, [T21, T22])) =
    8.81      let val (n1, n2) = pairself num_factors_in_type (T11, T21) in
    8.82 @@ -210,25 +197,20 @@
    8.83      ((T1, NONE), (T21, SOME T22))
    8.84    | factor_out_types T1 T2 = ((T1, NONE), (T2, NONE))
    8.85  
    8.86 -(* bool -> typ -> typ -> (term * term) list -> term *)
    8.87  fun make_plain_fun maybe_opt T1 T2 =
    8.88    let
    8.89 -    (* typ -> typ -> (term * term) list -> term *)
    8.90      fun aux T1 T2 [] =
    8.91          Const (if maybe_opt then opt_flag else non_opt_flag, T1 --> T2)
    8.92        | aux T1 T2 ((t1, t2) :: tps) =
    8.93          Const (@{const_name fun_upd}, (T1 --> T2) --> T1 --> T2 --> T1 --> T2)
    8.94          $ aux T1 T2 tps $ t1 $ t2
    8.95    in aux T1 T2 o rev end
    8.96 -(* term -> bool *)
    8.97  fun is_plain_fun (Const (s, _)) = (s = opt_flag orelse s = non_opt_flag)
    8.98    | is_plain_fun (Const (@{const_name fun_upd}, _) $ t0 $ _ $ _) =
    8.99      is_plain_fun t0
   8.100    | is_plain_fun _ = false
   8.101 -(* term -> bool * (term list * term list) *)
   8.102  val dest_plain_fun =
   8.103    let
   8.104 -    (* term -> bool * (term list * term list) *)
   8.105      fun aux (Abs (_, _, Const (s, _))) = (s <> irrelevant, ([], []))
   8.106        | aux (Const (s, _)) = (s <> non_opt_flag, ([], []))
   8.107        | aux (Const (@{const_name fun_upd}, _) $ t0 $ t1 $ t2) =
   8.108 @@ -238,7 +220,6 @@
   8.109        | aux t = raise TERM ("Nitpick_Model.dest_plain_fun", [t])
   8.110    in apsnd (pairself rev) o aux end
   8.111  
   8.112 -(* typ -> typ -> typ -> term -> term * term *)
   8.113  fun break_in_two T T1 T2 t =
   8.114    let
   8.115      val ps = HOLogic.flat_tupleT_paths T
   8.116 @@ -246,7 +227,6 @@
   8.117      val (ps1, ps2) = pairself HOLogic.flat_tupleT_paths (T1, T2)
   8.118      val (ts1, ts2) = t |> HOLogic.strip_ptuple ps |> chop cut
   8.119    in (HOLogic.mk_ptuple ps1 T1 ts1, HOLogic.mk_ptuple ps2 T2 ts2) end
   8.120 -(* typ -> term -> term -> term *)
   8.121  fun pair_up (Type (@{type_name "*"}, [T1', T2']))
   8.122              (t1 as Const (@{const_name Pair},
   8.123                            Type (@{type_name fun},
   8.124 @@ -255,13 +235,10 @@
   8.125      if T1 = T1' then HOLogic.mk_prod (t1, t2)
   8.126      else HOLogic.mk_prod (t11, pair_up T2' t12 t2)
   8.127    | pair_up _ t1 t2 = HOLogic.mk_prod (t1, t2)
   8.128 -(* typ -> term -> term list * term list -> (term * term) list*)
   8.129  fun multi_pair_up T1 t1 (ts2, ts3) = map2 (pair o pair_up T1 t1) ts2 ts3
   8.130  
   8.131 -(* typ -> typ -> typ -> term -> term *)
   8.132  fun typecast_fun (Type (@{type_name fun}, [T1', T2'])) T1 T2 t =
   8.133      let
   8.134 -      (* typ -> typ -> typ -> typ -> term -> term *)
   8.135        fun do_curry T1 T1a T1b T2 t =
   8.136          let
   8.137            val (maybe_opt, tsp) = dest_plain_fun t
   8.138 @@ -271,7 +248,6 @@
   8.139                  |> AList.coalesce (op =)
   8.140                  |> map (apsnd (make_plain_fun maybe_opt T1b T2))
   8.141          in make_plain_fun maybe_opt T1a (T1b --> T2) tps end
   8.142 -      (* typ -> typ -> term -> term *)
   8.143        and do_uncurry T1 T2 t =
   8.144          let
   8.145            val (maybe_opt, tsp) = dest_plain_fun t
   8.146 @@ -280,7 +256,6 @@
   8.147                  |> maps (fn (t1, t2) =>
   8.148                              multi_pair_up T1 t1 (snd (dest_plain_fun t2)))
   8.149          in make_plain_fun maybe_opt T1 T2 tps end
   8.150 -      (* typ -> typ -> typ -> typ -> term -> term *)
   8.151        and do_arrow T1' T2' _ _ (Const (s, _)) = Const (s, T1' --> T2')
   8.152          | do_arrow T1' T2' T1 T2
   8.153                     (Const (@{const_name fun_upd}, _) $ t0 $ t1 $ t2) =
   8.154 @@ -297,7 +272,6 @@
   8.155          | ((T1a', SOME T1b'), (_, NONE)) =>
   8.156            t |> do_arrow T1a' (T1b' --> T2') T1 T2 |> do_uncurry T1' T2'
   8.157          | _ => raise TYPE ("Nitpick_Model.typecast_fun.do_fun", [T1, T1'], [])
   8.158 -      (* typ -> typ -> term -> term *)
   8.159        and do_term (Type (@{type_name fun}, [T1', T2']))
   8.160                    (Type (@{type_name fun}, [T1, T2])) t =
   8.161            do_fun T1' T2' T1 T2 t
   8.162 @@ -313,33 +287,25 @@
   8.163    | typecast_fun T' _ _ _ =
   8.164      raise TYPE ("Nitpick_Model.typecast_fun", [T'], [])
   8.165  
   8.166 -(* term -> string *)
   8.167  fun truth_const_sort_key @{const True} = "0"
   8.168    | truth_const_sort_key @{const False} = "2"
   8.169    | truth_const_sort_key _ = "1"
   8.170  
   8.171 -(* typ -> term list -> term *)
   8.172  fun mk_tuple (Type (@{type_name "*"}, [T1, T2])) ts =
   8.173      HOLogic.mk_prod (mk_tuple T1 ts,
   8.174          mk_tuple T2 (List.drop (ts, length (HOLogic.flatten_tupleT T1))))
   8.175    | mk_tuple _ (t :: _) = t
   8.176    | mk_tuple T [] = raise TYPE ("Nitpick_Model.mk_tuple", [T], [])
   8.177  
   8.178 -(* theory -> typ * typ -> bool *)
   8.179  fun varified_type_match thy (candid_T, pat_T) =
   8.180    strict_type_match thy (candid_T, Logic.varifyT_global pat_T)
   8.181  
   8.182 -(* atom_pool -> (string * string) * (string * string) -> scope -> nut list
   8.183 -   -> nut list -> nut list -> nut NameTable.table -> KK.raw_bound list -> typ
   8.184 -   -> term list *)
   8.185  fun all_values_of_type pool wacky_names (scope as {card_assigns, ...} : scope)
   8.186                         sel_names rel_table bounds card T =
   8.187    let
   8.188      val card = if card = 0 then card_of_type card_assigns T else card
   8.189 -    (* nat -> term *)
   8.190      fun nth_value_of_type n =
   8.191        let
   8.192 -        (* bool -> term *)
   8.193          fun term unfold =
   8.194            reconstruct_term unfold pool wacky_names scope sel_names rel_table
   8.195                             bounds T T (Atom (card, 0)) [[n]]
   8.196 @@ -353,15 +319,11 @@
   8.197          | t => t
   8.198        end
   8.199    in index_seq 0 card |> map nth_value_of_type |> sort nice_term_ord end
   8.200 -(* bool -> atom_pool -> (string * string) * (string * string) -> scope
   8.201 -   -> nut list -> nut list -> nut list -> nut NameTable.table
   8.202 -   -> KK.raw_bound list -> typ -> typ -> rep -> int list list -> term *)
   8.203  and reconstruct_term unfold pool (wacky_names as ((maybe_name, abs_name), _))
   8.204          (scope as {hol_ctxt as {ctxt, thy, stds, ...}, binarize, card_assigns,
   8.205                     bits, datatypes, ofs, ...}) sel_names rel_table bounds =
   8.206    let
   8.207      val for_auto = (maybe_name = "")
   8.208 -    (* int list list -> int *)
   8.209      fun value_of_bits jss =
   8.210        let
   8.211          val j0 = offset_of_type ofs @{typ unsigned_bit}
   8.212 @@ -370,10 +332,8 @@
   8.213          fold (fn j => Integer.add (reasonable_power 2 j |> j = bits ? op ~))
   8.214               js 0
   8.215        end
   8.216 -    (* typ -> term list *)
   8.217      val all_values =
   8.218        all_values_of_type pool wacky_names scope sel_names rel_table bounds 0
   8.219 -    (* typ -> term -> term *)
   8.220      fun postprocess_term (Type (@{type_name fun}, _)) = I
   8.221        | postprocess_term T =
   8.222          if null (Data.get thy) then
   8.223 @@ -381,7 +341,6 @@
   8.224          else case AList.lookup (varified_type_match thy) (Data.get thy) T of
   8.225            SOME postproc => postproc ctxt maybe_name all_values T
   8.226          | NONE => I
   8.227 -    (* typ list -> term -> term *)
   8.228      fun postprocess_subterms Ts (t1 $ t2) =
   8.229          let val t = postprocess_subterms Ts t1 $ postprocess_subterms Ts t2 in
   8.230            postprocess_term (fastype_of1 (Ts, t)) t
   8.231 @@ -389,13 +348,11 @@
   8.232        | postprocess_subterms Ts (Abs (s, T, t')) =
   8.233          Abs (s, T, postprocess_subterms (T :: Ts) t')
   8.234        | postprocess_subterms Ts t = postprocess_term (fastype_of1 (Ts, t)) t
   8.235 -    (* bool -> typ -> typ -> (term * term) list -> term *)
   8.236      fun make_set maybe_opt T1 T2 tps =
   8.237        let
   8.238          val empty_const = Const (@{const_abbrev Set.empty}, T1 --> T2)
   8.239          val insert_const = Const (@{const_name insert},
   8.240                                    T1 --> (T1 --> T2) --> T1 --> T2)
   8.241 -        (* (term * term) list -> term *)
   8.242          fun aux [] =
   8.243              if maybe_opt andalso not (is_complete_type datatypes false T1) then
   8.244                insert_const $ Const (unrep, T1) $ empty_const
   8.245 @@ -416,12 +373,10 @@
   8.246          else
   8.247            aux tps
   8.248        end
   8.249 -    (* bool -> typ -> typ -> typ -> (term * term) list -> term *)
   8.250      fun make_map maybe_opt T1 T2 T2' =
   8.251        let
   8.252          val update_const = Const (@{const_name fun_upd},
   8.253                                    (T1 --> T2) --> T1 --> T2 --> T1 --> T2)
   8.254 -        (* (term * term) list -> term *)
   8.255          fun aux' [] = Const (@{const_abbrev Map.empty}, T1 --> T2)
   8.256            | aux' ((t1, t2) :: tps) =
   8.257              (case t2 of
   8.258 @@ -434,7 +389,6 @@
   8.259            else
   8.260              aux' tps
   8.261        in aux end
   8.262 -    (* typ list -> term -> term *)
   8.263      fun polish_funs Ts t =
   8.264        (case fastype_of1 (Ts, t) of
   8.265           Type (@{type_name fun}, [T1, T2]) =>
   8.266 @@ -475,7 +429,6 @@
   8.267                 else
   8.268                   t
   8.269               | t => t
   8.270 -    (* bool -> typ -> typ -> typ -> term list -> term list -> term *)
   8.271      fun make_fun maybe_opt T1 T2 T' ts1 ts2 =
   8.272        ts1 ~~ ts2 |> sort (nice_term_ord o pairself fst)
   8.273                   |> make_plain_fun maybe_opt T1 T2
   8.274 @@ -483,7 +436,6 @@
   8.275                   |> typecast_fun (uniterize_unarize_unbox_etc_type T')
   8.276                                   (uniterize_unarize_unbox_etc_type T1)
   8.277                                   (uniterize_unarize_unbox_etc_type T2)
   8.278 -    (* (typ * int) list -> typ -> typ -> int -> term *)
   8.279      fun term_for_atom seen (T as Type (@{type_name fun}, [T1, T2])) T' j _ =
   8.280          let
   8.281            val k1 = card_of_type card_assigns T1
   8.282 @@ -524,10 +476,8 @@
   8.283          | SOME {deep = false, ...} => nth_atom pool for_auto T j k
   8.284          | SOME {co, standard, constrs, ...} =>
   8.285            let
   8.286 -            (* styp -> int list *)
   8.287              fun tuples_for_const (s, T) =
   8.288                tuple_list_for_name rel_table bounds (ConstName (s, T, Any))
   8.289 -            (* unit -> term *)
   8.290              fun cyclic_atom () =
   8.291                nth_atom pool for_auto (Type (cyclic_type_name, [])) j k
   8.292              fun cyclic_var () = Var ((nth_atom_name pool "" T j k, 0), T)
   8.293 @@ -616,14 +566,11 @@
   8.294                    t
   8.295                end
   8.296            end
   8.297 -    (* (typ * int) list -> int -> rep -> typ -> typ -> typ -> int list
   8.298 -       -> term *)
   8.299      and term_for_vect seen k R T1 T2 T' js =
   8.300        make_fun true T1 T2 T'
   8.301                 (map (fn j => term_for_atom seen T1 T1 j k) (index_seq 0 k))
   8.302                 (map (term_for_rep true seen T2 T2 R o single)
   8.303                      (batch_list (arity_of_rep R) js))
   8.304 -    (* bool -> (typ * int) list -> typ -> typ -> rep -> int list list -> term *)
   8.305      and term_for_rep _ seen T T' Unit [[]] = term_for_atom seen T T' 0 1
   8.306        | term_for_rep _ seen T T' (R as Atom (k, j0)) [[j]] =
   8.307          if j >= j0 andalso j < j0 + k then term_for_atom seen T T' (j - j0) k
   8.308 @@ -675,14 +622,12 @@
   8.309  
   8.310  (** Constant postprocessing **)
   8.311  
   8.312 -(* int -> typ -> typ list *)
   8.313  fun dest_n_tuple_type 1 T = [T]
   8.314    | dest_n_tuple_type n (Type (_, [T1, T2])) =
   8.315      T1 :: dest_n_tuple_type (n - 1) T2
   8.316    | dest_n_tuple_type _ T =
   8.317      raise TYPE ("Nitpick_Model.dest_n_tuple_type", [T], [])
   8.318  
   8.319 -(* theory -> const_table -> styp -> int list *)
   8.320  fun const_format thy def_table (x as (s, T)) =
   8.321    if String.isPrefix unrolled_prefix s then
   8.322      const_format thy def_table (original_name s, range_type T)
   8.323 @@ -702,7 +647,6 @@
   8.324                 else
   8.325                   [num_binder_types T]
   8.326    | NONE => [num_binder_types T]
   8.327 -(* int list -> int list -> int list *)
   8.328  fun intersect_formats _ [] = []
   8.329    | intersect_formats [] _ = []
   8.330    | intersect_formats ks1 ks2 =
   8.331 @@ -712,7 +656,6 @@
   8.332        [Int.min (k1, k2)]
   8.333      end
   8.334  
   8.335 -(* theory -> const_table -> (term option * int list) list -> term -> int list *)
   8.336  fun lookup_format thy def_table formats t =
   8.337    case AList.lookup (fn (SOME x, SOME y) =>
   8.338                          (term_match thy) (x, y) | _ => false)
   8.339 @@ -725,7 +668,6 @@
   8.340                | _ => format
   8.341              end
   8.342  
   8.343 -(* int list -> int list -> typ -> typ *)
   8.344  fun format_type default_format format T =
   8.345    let
   8.346      val T = uniterize_unarize_unbox_etc_type T
   8.347 @@ -743,28 +685,22 @@
   8.348            |> map (HOLogic.mk_tupleT o rev)
   8.349        in List.foldl (op -->) body_T batched end
   8.350    end
   8.351 -(* theory -> const_table -> (term option * int list) list -> term -> typ *)
   8.352  fun format_term_type thy def_table formats t =
   8.353    format_type (the (AList.lookup (op =) formats NONE))
   8.354                (lookup_format thy def_table formats t) (fastype_of t)
   8.355  
   8.356 -(* int list -> int -> int list -> int list *)
   8.357  fun repair_special_format js m format =
   8.358    m - 1 downto 0 |> chunk_list_unevenly (rev format)
   8.359                   |> map (rev o filter_out (member (op =) js))
   8.360                   |> filter_out null |> map length |> rev
   8.361  
   8.362 -(* hol_context -> string * string -> (term option * int list) list
   8.363 -   -> styp -> term * typ *)
   8.364  fun user_friendly_const ({thy, evals, def_table, skolems, special_funs, ...}
   8.365                           : hol_context) (base_name, step_name) formats =
   8.366    let
   8.367      val default_format = the (AList.lookup (op =) formats NONE)
   8.368 -    (* styp -> term * typ *)
   8.369      fun do_const (x as (s, T)) =
   8.370        (if String.isPrefix special_prefix s then
   8.371           let
   8.372 -           (* term -> term *)
   8.373             val do_term = map_aterms (fn Const x => fst (do_const x) | t' => t')
   8.374             val (x' as (_, T'), js, ts) =
   8.375               AList.find (op =) (!special_funs) (s, unarize_unbox_etc_type T)
   8.376 @@ -773,7 +709,6 @@
   8.377             val Ts = List.take (binder_types T', max_j + 1)
   8.378             val missing_js = filter_out (member (op =) js) (0 upto max_j)
   8.379             val missing_Ts = filter_indices missing_js Ts
   8.380 -           (* int -> indexname *)
   8.381             fun nth_missing_var n =
   8.382               ((arg_var_prefix ^ nat_subscript (n + 1), 0), nth missing_Ts n)
   8.383             val missing_vars = map nth_missing_var (0 upto length missing_js - 1)
   8.384 @@ -865,7 +800,6 @@
   8.385        |>> shorten_names_in_term |>> Term.map_abs_vars shortest_name
   8.386    in do_const end
   8.387  
   8.388 -(* styp -> string *)
   8.389  fun assign_operator_for_const (s, T) =
   8.390    if String.isPrefix ubfp_prefix s then
   8.391      if is_fun_type T then "\<subseteq>" else "\<le>"
   8.392 @@ -878,8 +812,6 @@
   8.393  
   8.394  (** Model reconstruction **)
   8.395  
   8.396 -(* atom_pool -> scope -> nut list -> nut NameTable.table -> KK.raw_bound list
   8.397 -   -> nut -> term *)
   8.398  fun term_for_name pool scope sel_names rel_table bounds name =
   8.399    let val T = type_of name in
   8.400      tuple_list_for_name rel_table bounds name
   8.401 @@ -887,13 +819,11 @@
   8.402                          rel_table bounds T T (rep_of name)
   8.403    end
   8.404  
   8.405 -(* term -> term *)
   8.406  fun unfold_outer_the_binders (t as Const (@{const_name The}, _)
   8.407                                     $ Abs (s, T, Const (@{const_name "op ="}, _)
   8.408                                                  $ Bound 0 $ t')) =
   8.409      betapply (Abs (s, T, t'), t) |> unfold_outer_the_binders
   8.410    | unfold_outer_the_binders t = t
   8.411 -(* typ list -> int -> term * term -> bool *)
   8.412  fun bisimilar_values _ 0 _ = true
   8.413    | bisimilar_values coTs max_depth (t1, t2) =
   8.414      let val T = fastype_of t1 in
   8.415 @@ -910,9 +840,6 @@
   8.416          t1 = t2
   8.417      end
   8.418  
   8.419 -(* params -> scope -> (term option * int list) list -> styp list -> nut list
   8.420 -  -> nut list -> nut list -> nut NameTable.table -> KK.raw_bound list
   8.421 -  -> Pretty.T * bool *)
   8.422  fun reconstruct_hol_model {show_skolems, show_datatypes, show_consts}
   8.423          ({hol_ctxt = {thy, ctxt, max_bisim_depth, boxes, stds, wfs, user_axioms,
   8.424                        debug, binary_ints, destroy_constrs, specialize,
   8.425 @@ -945,13 +872,10 @@
   8.426      val scope = {hol_ctxt = hol_ctxt, binarize = binarize,
   8.427                   card_assigns = card_assigns, bits = bits,
   8.428                   bisim_depth = bisim_depth, datatypes = datatypes, ofs = ofs}
   8.429 -    (* bool -> typ -> typ -> rep -> int list list -> term *)
   8.430      fun term_for_rep unfold =
   8.431        reconstruct_term unfold pool wacky_names scope sel_names rel_table bounds
   8.432 -    (* nat -> typ -> nat -> term *)
   8.433      fun nth_value_of_type card T n =
   8.434        let
   8.435 -        (* bool -> term *)
   8.436          fun aux unfold = term_for_rep unfold T T (Atom (card, 0)) [[n]]
   8.437        in
   8.438          case aux false of
   8.439 @@ -962,10 +886,8 @@
   8.440              t
   8.441          | t => t
   8.442        end
   8.443 -    (* nat -> typ -> term list *)
   8.444      val all_values =
   8.445        all_values_of_type pool wacky_names scope sel_names rel_table bounds
   8.446 -    (* dtype_spec list -> dtype_spec -> bool *)
   8.447      fun is_codatatype_wellformed (cos : dtype_spec list)
   8.448                                   ({typ, card, ...} : dtype_spec) =
   8.449        let
   8.450 @@ -975,7 +897,6 @@
   8.451          forall (not o bisimilar_values (map #typ cos) max_depth)
   8.452                 (all_distinct_unordered_pairs_of ts)
   8.453        end
   8.454 -    (* string -> Pretty.T *)
   8.455      fun pretty_for_assign name =
   8.456        let
   8.457          val (oper, (t1, T'), T) =
   8.458 @@ -999,7 +920,6 @@
   8.459              [setmp_show_all_types (Syntax.pretty_term ctxt) t1,
   8.460               Pretty.str oper, Syntax.pretty_term ctxt t2])
   8.461        end
   8.462 -    (* dtype_spec -> Pretty.T *)
   8.463      fun pretty_for_datatype ({typ, card, complete, ...} : dtype_spec) =
   8.464        Pretty.block (Pretty.breaks
   8.465            (Syntax.pretty_typ ctxt (uniterize_unarize_unbox_etc_type typ) ::
   8.466 @@ -1013,7 +933,6 @@
   8.467                  (map (Syntax.pretty_term ctxt) (all_values card typ) @
   8.468                   (if fun_from_pair complete false then []
   8.469                    else [Pretty.str unrep]))]))
   8.470 -    (* typ -> dtype_spec list *)
   8.471      fun integer_datatype T =
   8.472        [{typ = T, card = card_of_type card_assigns T, co = false,
   8.473          standard = true, complete = (false, false), concrete = (true, true),
   8.474 @@ -1036,7 +955,6 @@
   8.475                           (map pretty_for_datatype codatatypes)]
   8.476        else
   8.477          []
   8.478 -    (* bool -> string -> nut list -> Pretty.T list *)
   8.479      fun block_of_names show title names =
   8.480        if show andalso not (null names) then
   8.481          Pretty.str (title ^ plural_s_for_list names ^ ":")
   8.482 @@ -1075,17 +993,13 @@
   8.483       forall (is_codatatype_wellformed codatatypes) codatatypes)
   8.484    end
   8.485  
   8.486 -(* scope -> Time.time option -> nut list -> nut list -> nut NameTable.table
   8.487 -   -> KK.raw_bound list -> term -> bool option *)
   8.488  fun prove_hol_model (scope as {hol_ctxt = {thy, ctxt, debug, ...},
   8.489                                 card_assigns, ...})
   8.490                      auto_timeout free_names sel_names rel_table bounds prop =
   8.491    let
   8.492      val pool = Unsynchronized.ref []
   8.493 -    (* typ * int -> term *)
   8.494      fun free_type_assm (T, k) =
   8.495        let
   8.496 -        (* int -> term *)
   8.497          fun atom j = nth_atom pool true T j k
   8.498          fun equation_for_atom j = HOLogic.eq_const T $ Bound 0 $ atom j
   8.499          val eqs = map equation_for_atom (index_seq 0 k)
   8.500 @@ -1094,14 +1008,12 @@
   8.501                $ Abs ("x", T, foldl1 HOLogic.mk_disj eqs)
   8.502          val distinct_assm = distinctness_formula T (map atom (index_seq 0 k))
   8.503        in s_conj (compreh_assm, distinct_assm) end
   8.504 -    (* nut -> term *)
   8.505      fun free_name_assm name =
   8.506        HOLogic.mk_eq (Free (nickname_of name, type_of name),
   8.507                       term_for_name pool scope sel_names rel_table bounds name)
   8.508      val freeT_assms = map free_type_assm (filter (is_TFree o fst) card_assigns)
   8.509      val model_assms = map free_name_assm free_names
   8.510      val assm = foldr1 s_conj (freeT_assms @ model_assms)
   8.511 -    (* bool -> bool *)
   8.512      fun try_out negate =
   8.513        let
   8.514          val concl = (negate ? curry (op $) @{const Not})
     9.1 --- a/src/HOL/Tools/Nitpick/nitpick_mono.ML	Sat Apr 24 16:17:30 2010 +0200
     9.2 +++ b/src/HOL/Tools/Nitpick/nitpick_mono.ML	Sat Apr 24 16:33:01 2010 +0200
     9.3 @@ -54,55 +54,42 @@
     9.4  exception MTYPE of string * mtyp list * typ list
     9.5  exception MTERM of string * mterm list
     9.6  
     9.7 -(* string -> unit *)
     9.8  fun print_g (_ : string) = ()
     9.9  (* val print_g = tracing *)
    9.10  
    9.11 -(* var -> string *)
    9.12  val string_for_var = signed_string_of_int
    9.13 -(* string -> var list -> string *)
    9.14  fun string_for_vars sep [] = "0\<^bsub>" ^ sep ^ "\<^esub>"
    9.15    | string_for_vars sep xs = space_implode sep (map string_for_var xs)
    9.16  fun subscript_string_for_vars sep xs =
    9.17    if null xs then "" else "\<^bsub>" ^ string_for_vars sep xs ^ "\<^esub>"
    9.18  
    9.19 -(* sign -> string *)
    9.20  fun string_for_sign Plus = "+"
    9.21    | string_for_sign Minus = "-"
    9.22  
    9.23 -(* sign -> sign -> sign *)
    9.24  fun xor sn1 sn2 = if sn1 = sn2 then Plus else Minus
    9.25 -(* sign -> sign *)
    9.26  val negate = xor Minus
    9.27  
    9.28 -(* sign_atom -> string *)
    9.29  fun string_for_sign_atom (S sn) = string_for_sign sn
    9.30    | string_for_sign_atom (V x) = string_for_var x
    9.31  
    9.32 -(* literal -> string *)
    9.33  fun string_for_literal (x, sn) = string_for_var x ^ " = " ^ string_for_sign sn
    9.34  
    9.35  val bool_M = MType (@{type_name bool}, [])
    9.36  val dummy_M = MType (nitpick_prefix ^ "dummy", [])
    9.37  
    9.38 -(* mtyp -> bool *)
    9.39  fun is_MRec (MRec _) = true
    9.40    | is_MRec _ = false
    9.41 -(* mtyp -> mtyp * sign_atom * mtyp *)
    9.42  fun dest_MFun (MFun z) = z
    9.43    | dest_MFun M = raise MTYPE ("Nitpick_Mono.dest_MFun", [M], [])
    9.44  
    9.45  val no_prec = 100
    9.46  
    9.47 -(* mtyp -> int *)
    9.48  fun precedence_of_mtype (MFun _) = 1
    9.49    | precedence_of_mtype (MPair _) = 2
    9.50    | precedence_of_mtype _ = no_prec
    9.51  
    9.52 -(* mtyp -> string *)
    9.53  val string_for_mtype =
    9.54    let
    9.55 -    (* int -> mtyp -> string *)
    9.56      fun aux outer_prec M =
    9.57        let
    9.58          val prec = precedence_of_mtype M
    9.59 @@ -126,22 +113,17 @@
    9.60        end
    9.61    in aux 0 end
    9.62  
    9.63 -(* mtyp -> mtyp list *)
    9.64  fun flatten_mtype (MPair (M1, M2)) = maps flatten_mtype [M1, M2]
    9.65    | flatten_mtype (MType (_, Ms)) = maps flatten_mtype Ms
    9.66    | flatten_mtype M = [M]
    9.67  
    9.68 -(* mterm -> bool *)
    9.69  fun precedence_of_mterm (MRaw _) = no_prec
    9.70    | precedence_of_mterm (MAbs _) = 1
    9.71    | precedence_of_mterm (MApp _) = 2
    9.72  
    9.73 -(* Proof.context -> mterm -> string *)
    9.74  fun string_for_mterm ctxt =
    9.75    let
    9.76 -    (* mtype -> string *)
    9.77      fun mtype_annotation M = "\<^bsup>" ^ string_for_mtype M ^ "\<^esup>"
    9.78 -    (* int -> mterm -> string *)
    9.79      fun aux outer_prec m =
    9.80        let
    9.81          val prec = precedence_of_mterm m
    9.82 @@ -158,7 +140,6 @@
    9.83        end
    9.84    in aux 0 end
    9.85  
    9.86 -(* mterm -> mtyp *)
    9.87  fun mtype_of_mterm (MRaw (_, M)) = M
    9.88    | mtype_of_mterm (MAbs (_, _, M, a, m)) = MFun (M, a, mtype_of_mterm m)
    9.89    | mtype_of_mterm (MApp (m1, _)) =
    9.90 @@ -166,29 +147,24 @@
    9.91        MFun (_, _, M12) => M12
    9.92      | M1 => raise MTYPE ("Nitpick_Mono.mtype_of_mterm", [M1], [])
    9.93  
    9.94 -(* mterm -> mterm * mterm list *)
    9.95  fun strip_mcomb (MApp (m1, m2)) = strip_mcomb m1 ||> (fn ms => append ms [m2])
    9.96    | strip_mcomb m = (m, [])
    9.97  
    9.98 -(* hol_context -> bool -> bool -> typ -> mdata *)
    9.99  fun initial_mdata hol_ctxt binarize no_harmless alpha_T =
   9.100    ({hol_ctxt = hol_ctxt, binarize = binarize, alpha_T = alpha_T,
   9.101      no_harmless = no_harmless, max_fresh = Unsynchronized.ref 0,
   9.102      datatype_mcache = Unsynchronized.ref [],
   9.103      constr_mcache = Unsynchronized.ref []} : mdata)
   9.104  
   9.105 -(* typ -> typ -> bool *)
   9.106  fun could_exist_alpha_subtype alpha_T (T as Type (_, Ts)) =
   9.107      T = alpha_T orelse (not (is_fp_iterator_type T) andalso
   9.108                          exists (could_exist_alpha_subtype alpha_T) Ts)
   9.109    | could_exist_alpha_subtype alpha_T T = (T = alpha_T)
   9.110 -(* theory -> typ -> typ -> bool *)
   9.111  fun could_exist_alpha_sub_mtype _ (alpha_T as TFree _) T =
   9.112      could_exist_alpha_subtype alpha_T T
   9.113    | could_exist_alpha_sub_mtype thy alpha_T T =
   9.114      (T = alpha_T orelse is_datatype thy [(NONE, true)] T)
   9.115  
   9.116 -(* mtyp -> bool *)
   9.117  fun exists_alpha_sub_mtype MAlpha = true
   9.118    | exists_alpha_sub_mtype (MFun (M1, _, M2)) =
   9.119      exists exists_alpha_sub_mtype [M1, M2]
   9.120 @@ -197,7 +173,6 @@
   9.121    | exists_alpha_sub_mtype (MType (_, Ms)) = exists exists_alpha_sub_mtype Ms
   9.122    | exists_alpha_sub_mtype (MRec _) = true
   9.123  
   9.124 -(* mtyp -> bool *)
   9.125  fun exists_alpha_sub_mtype_fresh MAlpha = true
   9.126    | exists_alpha_sub_mtype_fresh (MFun (_, V _, _)) = true
   9.127    | exists_alpha_sub_mtype_fresh (MFun (_, _, M2)) =
   9.128 @@ -208,11 +183,9 @@
   9.129      exists exists_alpha_sub_mtype_fresh Ms
   9.130    | exists_alpha_sub_mtype_fresh (MRec _) = true
   9.131  
   9.132 -(* string * typ list -> mtyp list -> mtyp *)
   9.133  fun constr_mtype_for_binders z Ms =
   9.134    fold_rev (fn M => curry3 MFun M (S Minus)) Ms (MRec z)
   9.135  
   9.136 -(* ((string * typ list) * mtyp) list -> mtyp list -> mtyp -> mtyp *)
   9.137  fun repair_mtype _ _ MAlpha = MAlpha
   9.138    | repair_mtype cache seen (MFun (M1, a, M2)) =
   9.139      MFun (repair_mtype cache seen M1, a, repair_mtype cache seen M2)
   9.140 @@ -226,30 +199,24 @@
   9.141      | M => if member (op =) seen M then MType (s, [])
   9.142             else repair_mtype cache (M :: seen) M
   9.143  
   9.144 -(* ((string * typ list) * mtyp) list Unsynchronized.ref -> unit *)
   9.145  fun repair_datatype_mcache cache =
   9.146    let
   9.147 -    (* (string * typ list) * mtyp -> unit *)
   9.148      fun repair_one (z, M) =
   9.149        Unsynchronized.change cache
   9.150            (AList.update (op =) (z, repair_mtype (!cache) [] M))
   9.151    in List.app repair_one (rev (!cache)) end
   9.152  
   9.153 -(* (typ * mtyp) list -> (styp * mtyp) list Unsynchronized.ref -> unit *)
   9.154  fun repair_constr_mcache dtype_cache constr_mcache =
   9.155    let
   9.156 -    (* styp * mtyp -> unit *)
   9.157      fun repair_one (x, M) =
   9.158        Unsynchronized.change constr_mcache
   9.159            (AList.update (op =) (x, repair_mtype dtype_cache [] M))
   9.160    in List.app repair_one (!constr_mcache) end
   9.161  
   9.162 -(* typ -> bool *)
   9.163  fun is_fin_fun_supported_type @{typ prop} = true
   9.164    | is_fin_fun_supported_type @{typ bool} = true
   9.165    | is_fin_fun_supported_type (Type (@{type_name option}, _)) = true
   9.166    | is_fin_fun_supported_type _ = false
   9.167 -(* typ -> typ -> term -> term option *)
   9.168  fun fin_fun_body _ _ (t as @{term False}) = SOME t
   9.169    | fin_fun_body _ _ (t as Const (@{const_name None}, _)) = SOME t
   9.170    | fin_fun_body dom_T ran_T
   9.171 @@ -265,7 +232,6 @@
   9.172                  $ (Const (@{const_name unknown}, ran_T)) $ (t0 $ t1 $ t2 $ t3)))
   9.173    | fin_fun_body _ _ _ = NONE
   9.174  
   9.175 -(* mdata -> bool -> typ -> typ -> mtyp * sign_atom * mtyp *)
   9.176  fun fresh_mfun_for_fun_type (mdata as {max_fresh, ...} : mdata) all_minus
   9.177                              T1 T2 =
   9.178    let
   9.179 @@ -277,12 +243,10 @@
   9.180              else
   9.181                S Minus
   9.182    in (M1, a, M2) end
   9.183 -(* mdata -> bool -> typ -> mtyp *)
   9.184  and fresh_mtype_for_type (mdata as {hol_ctxt as {thy, ...}, binarize, alpha_T,
   9.185                                      datatype_mcache, constr_mcache, ...})
   9.186                           all_minus =
   9.187    let
   9.188 -    (* typ -> mtyp *)
   9.189      fun do_type T =
   9.190        if T = alpha_T then
   9.191          MAlpha
   9.192 @@ -329,21 +293,17 @@
   9.193        | _ => MType (Refute.string_of_typ T, [])
   9.194    in do_type end
   9.195  
   9.196 -(* mtyp -> mtyp list *)
   9.197  fun prodM_factors (MPair (M1, M2)) = maps prodM_factors [M1, M2]
   9.198    | prodM_factors M = [M]
   9.199 -(* mtyp -> mtyp list * mtyp *)
   9.200  fun curried_strip_mtype (MFun (M1, _, M2)) =
   9.201      curried_strip_mtype M2 |>> append (prodM_factors M1)
   9.202    | curried_strip_mtype M = ([], M)
   9.203 -(* string -> mtyp -> mtyp *)
   9.204  fun sel_mtype_from_constr_mtype s M =
   9.205    let val (arg_Ms, dataM) = curried_strip_mtype M in
   9.206      MFun (dataM, S Minus,
   9.207            case sel_no_from_name s of ~1 => bool_M | n => nth arg_Ms n)
   9.208    end
   9.209  
   9.210 -(* mdata -> styp -> mtyp *)
   9.211  fun mtype_for_constr (mdata as {hol_ctxt = {thy, ...}, alpha_T, constr_mcache,
   9.212                                  ...}) (x as (_, T)) =
   9.213    if could_exist_alpha_sub_mtype thy alpha_T T then
   9.214 @@ -362,14 +322,11 @@
   9.215    x |> binarized_and_boxed_constr_for_sel hol_ctxt binarize
   9.216      |> mtype_for_constr mdata |> sel_mtype_from_constr_mtype s
   9.217  
   9.218 -(* literal list -> sign_atom -> sign_atom *)
   9.219  fun resolve_sign_atom lits (V x) =
   9.220      x |> AList.lookup (op =) lits |> Option.map S |> the_default (V x)
   9.221    | resolve_sign_atom _ a = a
   9.222 -(* literal list -> mtyp -> mtyp *)
   9.223  fun resolve_mtype lits =
   9.224    let
   9.225 -    (* mtyp -> mtyp *)
   9.226      fun aux MAlpha = MAlpha
   9.227        | aux (MFun (M1, a, M2)) = MFun (aux M1, resolve_sign_atom lits a, aux M2)
   9.228        | aux (MPair Mp) = MPair (pairself aux Mp)
   9.229 @@ -384,24 +341,19 @@
   9.230  
   9.231  type constraint_set = literal list * comp list * sign_expr list
   9.232  
   9.233 -(* comp_op -> string *)
   9.234  fun string_for_comp_op Eq = "="
   9.235    | string_for_comp_op Leq = "\<le>"
   9.236  
   9.237 -(* sign_expr -> string *)
   9.238  fun string_for_sign_expr [] = "\<bot>"
   9.239    | string_for_sign_expr lits =
   9.240      space_implode " \<or> " (map string_for_literal lits)
   9.241  
   9.242 -(* literal -> literal list option -> literal list option *)
   9.243  fun do_literal _ NONE = NONE
   9.244    | do_literal (x, sn) (SOME lits) =
   9.245      case AList.lookup (op =) lits x of
   9.246        SOME sn' => if sn = sn' then SOME lits else NONE
   9.247      | NONE => SOME ((x, sn) :: lits)
   9.248  
   9.249 -(* comp_op -> var list -> sign_atom -> sign_atom -> literal list * comp list
   9.250 -   -> (literal list * comp list) option *)
   9.251  fun do_sign_atom_comp Eq [] a1 a2 (accum as (lits, comps)) =
   9.252      (case (a1, a2) of
   9.253         (S sn1, S sn2) => if sn1 = sn2 then SOME accum else NONE
   9.254 @@ -419,8 +371,6 @@
   9.255    | do_sign_atom_comp cmp xs a1 a2 (lits, comps) =
   9.256      SOME (lits, insert (op =) (a1, a2, cmp, xs) comps)
   9.257  
   9.258 -(* comp -> var list -> mtyp -> mtyp -> (literal list * comp list) option
   9.259 -   -> (literal list * comp list) option *)
   9.260  fun do_mtype_comp _ _ _ _ NONE = NONE
   9.261    | do_mtype_comp _ _ MAlpha MAlpha accum = accum
   9.262    | do_mtype_comp Eq xs (MFun (M11, a1, M12)) (MFun (M21, a2, M22))
   9.263 @@ -450,7 +400,6 @@
   9.264      raise MTYPE ("Nitpick_Mono.do_mtype_comp (" ^ string_for_comp_op cmp ^ ")",
   9.265                   [M1, M2], [])
   9.266  
   9.267 -(* comp_op -> mtyp -> mtyp -> constraint_set -> constraint_set *)
   9.268  fun add_mtype_comp cmp M1 M2 ((lits, comps, sexps) : constraint_set) =
   9.269      (print_g ("*** Add " ^ string_for_mtype M1 ^ " " ^ string_for_comp_op cmp ^
   9.270                " " ^ string_for_mtype M2);
   9.271 @@ -458,12 +407,9 @@
   9.272         NONE => (print_g "**** Unsolvable"; raise UNSOLVABLE ())
   9.273       | SOME (lits, comps) => (lits, comps, sexps))
   9.274  
   9.275 -(* mtyp -> mtyp -> constraint_set -> constraint_set *)
   9.276  val add_mtypes_equal = add_mtype_comp Eq
   9.277  val add_is_sub_mtype = add_mtype_comp Leq
   9.278  
   9.279 -(* sign -> sign_expr -> mtyp -> (literal list * sign_expr list) option
   9.280 -   -> (literal list * sign_expr list) option *)
   9.281  fun do_notin_mtype_fv _ _ _ NONE = NONE
   9.282    | do_notin_mtype_fv Minus _ MAlpha accum = accum
   9.283    | do_notin_mtype_fv Plus [] MAlpha _ = NONE
   9.284 @@ -499,7 +445,6 @@
   9.285    | do_notin_mtype_fv _ _ M _ =
   9.286      raise MTYPE ("Nitpick_Mono.do_notin_mtype_fv", [M], [])
   9.287  
   9.288 -(* sign -> mtyp -> constraint_set -> constraint_set *)
   9.289  fun add_notin_mtype_fv sn M ((lits, comps, sexps) : constraint_set) =
   9.290      (print_g ("*** Add " ^ string_for_mtype M ^ " is " ^
   9.291                (case sn of Minus => "concrete" | Plus => "complete") ^ ".");
   9.292 @@ -507,31 +452,23 @@
   9.293         NONE => (print_g "**** Unsolvable"; raise UNSOLVABLE ())
   9.294       | SOME (lits, sexps) => (lits, comps, sexps))
   9.295  
   9.296 -(* mtyp -> constraint_set -> constraint_set *)
   9.297  val add_mtype_is_concrete = add_notin_mtype_fv Minus
   9.298  val add_mtype_is_complete = add_notin_mtype_fv Plus
   9.299  
   9.300  val bool_from_minus = true
   9.301  
   9.302 -(* sign -> bool *)
   9.303  fun bool_from_sign Plus = not bool_from_minus
   9.304    | bool_from_sign Minus = bool_from_minus
   9.305 -(* bool -> sign *)
   9.306  fun sign_from_bool b = if b = bool_from_minus then Minus else Plus
   9.307  
   9.308 -(* literal -> PropLogic.prop_formula *)
   9.309  fun prop_for_literal (x, sn) =
   9.310    (not (bool_from_sign sn) ? PropLogic.Not) (PropLogic.BoolVar x)
   9.311 -(* sign_atom -> PropLogic.prop_formula *)
   9.312  fun prop_for_sign_atom_eq (S sn', sn) =
   9.313      if sn = sn' then PropLogic.True else PropLogic.False
   9.314    | prop_for_sign_atom_eq (V x, sn) = prop_for_literal (x, sn)
   9.315 -(* sign_expr -> PropLogic.prop_formula *)
   9.316  fun prop_for_sign_expr xs = PropLogic.exists (map prop_for_literal xs)
   9.317 -(* var list -> sign -> PropLogic.prop_formula *)
   9.318  fun prop_for_exists_eq xs sn =
   9.319    PropLogic.exists (map (fn x => prop_for_literal (x, sn)) xs)
   9.320 -(* comp -> PropLogic.prop_formula *)
   9.321  fun prop_for_comp (a1, a2, Eq, []) =
   9.322      PropLogic.SAnd (prop_for_comp (a1, a2, Leq, []),
   9.323                      prop_for_comp (a2, a1, Leq, []))
   9.324 @@ -541,7 +478,6 @@
   9.325    | prop_for_comp (a1, a2, cmp, xs) =
   9.326      PropLogic.SOr (prop_for_exists_eq xs Minus, prop_for_comp (a1, a2, cmp, []))
   9.327  
   9.328 -(* var -> (int -> bool option) -> literal list -> literal list *)
   9.329  fun literals_from_assignments max_var assigns lits =
   9.330    fold (fn x => fn accum =>
   9.331             if AList.defined (op =) lits x then
   9.332 @@ -550,18 +486,15 @@
   9.333               SOME b => (x, sign_from_bool b) :: accum
   9.334             | NONE => accum) (max_var downto 1) lits
   9.335  
   9.336 -(* comp -> string *)
   9.337  fun string_for_comp (a1, a2, cmp, xs) =
   9.338    string_for_sign_atom a1 ^ " " ^ string_for_comp_op cmp ^
   9.339    subscript_string_for_vars " \<and> " xs ^ " " ^ string_for_sign_atom a2
   9.340  
   9.341 -(* literal list -> comp list -> sign_expr list -> unit *)
   9.342  fun print_problem lits comps sexps =
   9.343    print_g ("*** Problem:\n" ^ cat_lines (map string_for_literal lits @
   9.344                                           map string_for_comp comps @
   9.345                                           map string_for_sign_expr sexps))
   9.346  
   9.347 -(* literal list -> unit *)
   9.348  fun print_solution lits =
   9.349    let val (pos, neg) = List.partition (curry (op =) Plus o snd) lits in
   9.350      print_g ("*** Solution:\n" ^
   9.351 @@ -569,10 +502,8 @@
   9.352               "-: " ^ commas (map (string_for_var o fst) neg))
   9.353    end
   9.354  
   9.355 -(* var -> constraint_set -> literal list option *)
   9.356  fun solve max_var (lits, comps, sexps) =
   9.357      let
   9.358 -      (* (int -> bool option) -> literal list option *)
   9.359        fun do_assigns assigns =
   9.360          SOME (literals_from_assignments max_var assigns lits
   9.361                |> tap print_solution)
   9.362 @@ -607,27 +538,21 @@
   9.363  
   9.364  val initial_gamma = {bound_Ts = [], bound_Ms = [], frees = [], consts = []}
   9.365  
   9.366 -(* typ -> mtyp -> mtype_context -> mtype_context *)
   9.367  fun push_bound T M {bound_Ts, bound_Ms, frees, consts} =
   9.368    {bound_Ts = T :: bound_Ts, bound_Ms = M :: bound_Ms, frees = frees,
   9.369     consts = consts}
   9.370 -(* mtype_context -> mtype_context *)
   9.371  fun pop_bound {bound_Ts, bound_Ms, frees, consts} =
   9.372    {bound_Ts = tl bound_Ts, bound_Ms = tl bound_Ms, frees = frees,
   9.373     consts = consts}
   9.374    handle List.Empty => initial_gamma (* FIXME: needed? *)
   9.375  
   9.376 -(* mdata -> term -> accumulator -> mterm * accumulator *)
   9.377  fun consider_term (mdata as {hol_ctxt as {thy, ctxt, stds, fast_descrs,
   9.378                                            def_table, ...},
   9.379                               alpha_T, max_fresh, ...}) =
   9.380    let
   9.381 -    (* typ -> mtyp *)
   9.382      val mtype_for = fresh_mtype_for_type mdata false
   9.383 -    (* mtyp -> mtyp *)
   9.384      fun plus_set_mtype_for_dom M =
   9.385        MFun (M, S (if exists_alpha_sub_mtype M then Plus else Minus), bool_M)
   9.386 -    (* typ -> accumulator -> mterm * accumulator *)
   9.387      fun do_all T (gamma, cset) =
   9.388        let
   9.389          val abs_M = mtype_for (domain_type (domain_type T))
   9.390 @@ -656,7 +581,6 @@
   9.391        let
   9.392          val set_T = domain_type T
   9.393          val set_M = mtype_for set_T
   9.394 -        (* typ -> mtyp *)
   9.395          fun custom_mtype_for (T as Type (@{type_name fun}, [T1, T2])) =
   9.396              if T = set_T then set_M
   9.397              else MFun (custom_mtype_for T1, S Minus, custom_mtype_for T2)
   9.398 @@ -664,20 +588,16 @@
   9.399        in
   9.400          (custom_mtype_for T, (gamma, cset |> add_mtype_is_concrete set_M))
   9.401        end
   9.402 -    (* typ -> accumulator -> mtyp * accumulator *)
   9.403      fun do_pair_constr T accum =
   9.404        case mtype_for (nth_range_type 2 T) of
   9.405          M as MPair (a_M, b_M) =>
   9.406          (MFun (a_M, S Minus, MFun (b_M, S Minus, M)), accum)
   9.407        | M => raise MTYPE ("Nitpick_Mono.consider_term.do_pair_constr", [M], [])
   9.408 -    (* int -> typ -> accumulator -> mtyp * accumulator *)
   9.409      fun do_nth_pair_sel n T =
   9.410        case mtype_for (domain_type T) of
   9.411          M as MPair (a_M, b_M) =>
   9.412          pair (MFun (M, S Minus, if n = 0 then a_M else b_M))
   9.413        | M => raise MTYPE ("Nitpick_Mono.consider_term.do_nth_pair_sel", [M], [])
   9.414 -    (* term -> string -> typ -> term -> term -> term -> accumulator
   9.415 -       -> mterm * accumulator *)
   9.416      fun do_bounded_quantifier t0 abs_s abs_T connective_t bound_t body_t accum =
   9.417        let
   9.418          val abs_M = mtype_for abs_T
   9.419 @@ -697,7 +617,6 @@
   9.420                                   MApp (bound_m, MRaw (Bound 0, M1))),
   9.421                             body_m))), accum)
   9.422        end
   9.423 -    (* term -> accumulator -> mterm * accumulator *)
   9.424      and do_term t (accum as (gamma as {bound_Ts, bound_Ms, frees, consts},
   9.425                               cset)) =
   9.426          (case t of
   9.427 @@ -747,7 +666,6 @@
   9.428                | @{const_name converse} =>
   9.429                  let
   9.430                    val x = Unsynchronized.inc max_fresh
   9.431 -                  (* typ -> mtyp *)
   9.432                    fun mtype_for_set T =
   9.433                      MFun (mtype_for (domain_type T), V x, bool_M)
   9.434                    val ab_set_M = domain_type T |> mtype_for_set
   9.435 @@ -757,7 +675,6 @@
   9.436                | @{const_name rel_comp} =>
   9.437                  let
   9.438                    val x = Unsynchronized.inc max_fresh
   9.439 -                  (* typ -> mtyp *)
   9.440                    fun mtype_for_set T =
   9.441                      MFun (mtype_for (domain_type T), V x, bool_M)
   9.442                    val bc_set_M = domain_type T |> mtype_for_set
   9.443 @@ -783,7 +700,6 @@
   9.444                | @{const_name Sigma} =>
   9.445                  let
   9.446                    val x = Unsynchronized.inc max_fresh
   9.447 -                  (* typ -> mtyp *)
   9.448                    fun mtype_for_set T =
   9.449                      MFun (mtype_for (domain_type T), V x, bool_M)
   9.450                    val a_set_T = domain_type T
   9.451 @@ -891,14 +807,12 @@
   9.452                                        string_for_mterm ctxt m))
   9.453    in do_term end
   9.454  
   9.455 -(* int -> mtyp -> accumulator -> accumulator *)
   9.456  fun force_minus_funs 0 _ = I
   9.457    | force_minus_funs n (M as MFun (M1, _, M2)) =
   9.458      add_mtypes_equal M (MFun (M1, S Minus, M2))
   9.459      #> force_minus_funs (n - 1) M2
   9.460    | force_minus_funs _ M =
   9.461      raise MTYPE ("Nitpick_Mono.force_minus_funs", [M], [])
   9.462 -(* mdata -> bool -> styp -> term -> term -> mterm * accumulator *)
   9.463  fun consider_general_equals mdata def (x as (_, T)) t1 t2 accum =
   9.464    let
   9.465      val (m1, accum) = consider_term mdata t1 accum
   9.466 @@ -918,17 +832,12 @@
   9.467            accum)
   9.468    end
   9.469  
   9.470 -(* mdata -> sign -> term -> accumulator -> mterm * accumulator *)
   9.471  fun consider_general_formula (mdata as {hol_ctxt = {ctxt, ...}, ...}) =
   9.472    let
   9.473 -    (* typ -> mtyp *)
   9.474      val mtype_for = fresh_mtype_for_type mdata false
   9.475 -    (* term -> accumulator -> mterm * accumulator *)
   9.476      val do_term = consider_term mdata
   9.477 -    (* sign -> term -> accumulator -> mterm * accumulator *)
   9.478      fun do_formula sn t accum =
   9.479          let
   9.480 -          (* styp -> string -> typ -> term -> mterm * accumulator *)
   9.481            fun do_quantifier (quant_x as (quant_s, _)) abs_s abs_T body_t =
   9.482              let
   9.483                val abs_M = mtype_for abs_T
   9.484 @@ -944,7 +853,6 @@
   9.485                       MAbs (abs_s, abs_T, abs_M, S Minus, body_m)),
   9.486                 accum |>> pop_bound)
   9.487              end
   9.488 -          (* styp -> term -> term -> mterm * accumulator *)
   9.489            fun do_equals x t1 t2 =
   9.490              case sn of
   9.491                Plus => do_term t accum
   9.492 @@ -1005,7 +913,6 @@
   9.493    [@{const_name ord_class.less}, @{const_name ord_class.less_eq}]
   9.494  val bounteous_consts = [@{const_name bisim}]
   9.495  
   9.496 -(* mdata -> term -> bool *)
   9.497  fun is_harmless_axiom ({no_harmless = true, ...} : mdata) _ = false
   9.498    | is_harmless_axiom {hol_ctxt = {thy, stds, fast_descrs, ...}, ...} t =
   9.499      Term.add_consts t []
   9.500 @@ -1013,12 +920,10 @@
   9.501      |> (forall (member (op =) harmless_consts o original_name o fst) orf
   9.502          exists (member (op =) bounteous_consts o fst))
   9.503  
   9.504 -(* mdata -> term -> accumulator -> mterm * accumulator *)
   9.505  fun consider_nondefinitional_axiom mdata t =
   9.506    if is_harmless_axiom mdata t then pair (MRaw (t, dummy_M))
   9.507    else consider_general_formula mdata Plus t
   9.508  
   9.509 -(* mdata -> term -> accumulator -> mterm * accumulator *)
   9.510  fun consider_definitional_axiom (mdata as {hol_ctxt = {thy, ...}, ...}) t =
   9.511    if not (is_constr_pattern_formula thy t) then
   9.512      consider_nondefinitional_axiom mdata t
   9.513 @@ -1026,11 +931,8 @@
   9.514      pair (MRaw (t, dummy_M))
   9.515    else
   9.516      let
   9.517 -      (* typ -> mtyp *)
   9.518        val mtype_for = fresh_mtype_for_type mdata false
   9.519 -      (* term -> accumulator -> mterm * accumulator *)
   9.520        val do_term = consider_term mdata
   9.521 -      (* term -> string -> typ -> term -> accumulator -> mterm * accumulator *)
   9.522        fun do_all quant_t abs_s abs_T body_t accum =
   9.523          let
   9.524            val abs_M = mtype_for abs_T
   9.525 @@ -1043,7 +945,6 @@
   9.526                   MAbs (abs_s, abs_T, abs_M, S Minus, body_m)),
   9.527             accum |>> pop_bound)
   9.528          end
   9.529 -      (* term -> term -> term -> accumulator -> mterm * accumulator *)
   9.530        and do_conjunction t0 t1 t2 accum =
   9.531          let
   9.532            val (m1, accum) = do_formula t1 accum
   9.533 @@ -1058,7 +959,6 @@
   9.534          in
   9.535            (MApp (MApp (MRaw (t0, mtype_for (fastype_of t0)), m1), m2), accum)
   9.536          end
   9.537 -      (* term -> accumulator -> accumulator *)
   9.538        and do_formula t accum =
   9.539            case t of
   9.540              (t0 as Const (@{const_name all}, _)) $ Abs (s1, T1, t1) =>
   9.541 @@ -1083,22 +983,17 @@
   9.542                               \do_formula", [t])
   9.543      in do_formula t end
   9.544  
   9.545 -(* Proof.context -> literal list -> term -> mtyp -> string *)
   9.546  fun string_for_mtype_of_term ctxt lits t M =
   9.547    Syntax.string_of_term ctxt t ^ " : " ^ string_for_mtype (resolve_mtype lits M)
   9.548  
   9.549 -(* theory -> literal list -> mtype_context -> unit *)
   9.550  fun print_mtype_context ctxt lits ({frees, consts, ...} : mtype_context) =
   9.551    map (fn (x, M) => string_for_mtype_of_term ctxt lits (Free x) M) frees @
   9.552    map (fn (x, M) => string_for_mtype_of_term ctxt lits (Const x) M) consts
   9.553    |> cat_lines |> print_g
   9.554  
   9.555 -(* ('a -> 'b -> 'c * 'd) -> 'a -> 'c list * 'b -> 'c list * 'd *)
   9.556  fun amass f t (ms, accum) =
   9.557    let val (m, accum) = f t accum in (m :: ms, accum) end
   9.558  
   9.559 -(* string -> bool -> hol_context -> bool -> typ -> term list * term list
   9.560 -   -> (literal list * (mterm list * mterm list) * (styp * mtyp) list) option *)
   9.561  fun infer which no_harmless (hol_ctxt as {ctxt, ...}) binarize alpha_T
   9.562            (nondef_ts, def_ts) =
   9.563    let
   9.564 @@ -1127,15 +1022,11 @@
   9.565         | MTERM (loc, ms) =>
   9.566           raise BAD (loc, commas (map (string_for_mterm ctxt) ms))
   9.567  
   9.568 -(* hol_context -> bool -> typ -> term list * term list -> bool *)
   9.569  val formulas_monotonic = is_some oooo infer "Monotonicity" false
   9.570  
   9.571 -(* typ -> typ -> styp *)
   9.572  fun fin_fun_constr T1 T2 =
   9.573    (@{const_name FinFun}, (T1 --> T2) --> Type (@{type_name fin_fun}, [T1, T2]))
   9.574  
   9.575 -(* hol_context -> bool -> (typ option * bool option) list -> typ
   9.576 -   -> term list * term list -> term list * term list *)
   9.577  fun finitize_funs (hol_ctxt as {thy, stds, fast_descrs, constr_cache, ...})
   9.578                    binarize finitizes alpha_T tsp =
   9.579    case infer "Finiteness" true hol_ctxt binarize alpha_T tsp of
   9.580 @@ -1144,12 +1035,10 @@
   9.581        tsp
   9.582      else
   9.583        let
   9.584 -        (* typ -> sign_atom -> bool *)
   9.585          fun should_finitize T a =
   9.586            case triple_lookup (type_match thy) finitizes T of
   9.587              SOME (SOME false) => false
   9.588            | _ => resolve_sign_atom lits a = S Plus
   9.589 -        (* typ -> mtyp -> typ *)
   9.590          fun type_from_mtype T M =
   9.591            case (M, T) of
   9.592              (MAlpha, _) => T
   9.593 @@ -1161,12 +1050,10 @@
   9.594            | (MType _, _) => T
   9.595            | _ => raise MTYPE ("Nitpick_Mono.finitize_funs.type_from_mtype",
   9.596                                [M], [T])
   9.597 -        (* styp -> styp *)
   9.598          fun finitize_constr (x as (s, T)) =
   9.599            (s, case AList.lookup (op =) constr_mtypes x of
   9.600                  SOME M => type_from_mtype T M
   9.601                | NONE => T)
   9.602 -        (* typ list -> mterm -> term *)
   9.603          fun term_from_mterm Ts m =
   9.604            case m of
   9.605              MRaw (t, M) =>
    10.1 --- a/src/HOL/Tools/Nitpick/nitpick_nut.ML	Sat Apr 24 16:17:30 2010 +0200
    10.2 +++ b/src/HOL/Tools/Nitpick/nitpick_nut.ML	Sat Apr 24 16:33:01 2010 +0200
    10.3 @@ -205,7 +205,6 @@
    10.4  
    10.5  exception NUT of string * nut list
    10.6  
    10.7 -(* cst -> string *)
    10.8  fun string_for_cst Unity = "Unity"
    10.9    | string_for_cst False = "False"
   10.10    | string_for_cst True = "True"
   10.11 @@ -225,7 +224,6 @@
   10.12    | string_for_cst NatToInt = "NatToInt"
   10.13    | string_for_cst IntToNat = "IntToNat"
   10.14  
   10.15 -(* op1 -> string *)
   10.16  fun string_for_op1 Not = "Not"
   10.17    | string_for_op1 Finite = "Finite"
   10.18    | string_for_op1 Converse = "Converse"
   10.19 @@ -237,7 +235,6 @@
   10.20    | string_for_op1 Second = "Second"
   10.21    | string_for_op1 Cast = "Cast"
   10.22  
   10.23 -(* op2 -> string *)
   10.24  fun string_for_op2 All = "All"
   10.25    | string_for_op2 Exist = "Exist"
   10.26    | string_for_op2 Or = "Or"
   10.27 @@ -258,14 +255,11 @@
   10.28    | string_for_op2 Apply = "Apply"
   10.29    | string_for_op2 Lambda = "Lambda"
   10.30  
   10.31 -(* op3 -> string *)
   10.32  fun string_for_op3 Let = "Let"
   10.33    | string_for_op3 If = "If"
   10.34  
   10.35 -(* int -> Proof.context -> nut -> string *)
   10.36  fun basic_string_for_nut indent ctxt u =
   10.37    let
   10.38 -    (* nut -> string *)
   10.39      val sub = basic_string_for_nut (indent + 1) ctxt
   10.40    in
   10.41      (if indent = 0 then "" else "\n" ^ implode (replicate (2 * indent) " ")) ^
   10.42 @@ -313,17 +307,14 @@
   10.43         Syntax.string_of_typ ctxt T ^ " " ^ string_for_rep R) ^
   10.44      ")"
   10.45    end
   10.46 -(* Proof.context -> nut -> string *)
   10.47  val string_for_nut = basic_string_for_nut 0
   10.48  
   10.49 -(* nut -> bool *)
   10.50  fun inline_nut (Op1 _) = false
   10.51    | inline_nut (Op2 _) = false
   10.52    | inline_nut (Op3 _) = false
   10.53    | inline_nut (Tuple (_, _, us)) = forall inline_nut us
   10.54    | inline_nut _ = true
   10.55  
   10.56 -(* nut -> typ *)
   10.57  fun type_of (Cst (_, T, _)) = T
   10.58    | type_of (Op1 (_, T, _, _)) = T
   10.59    | type_of (Op2 (_, T, _, _, _)) = T
   10.60 @@ -338,7 +329,6 @@
   10.61    | type_of (RelReg (_, T, _)) = T
   10.62    | type_of (FormulaReg (_, T, _)) = T
   10.63  
   10.64 -(* nut -> rep *)
   10.65  fun rep_of (Cst (_, _, R)) = R
   10.66    | rep_of (Op1 (_, _, R, _)) = R
   10.67    | rep_of (Op2 (_, _, R, _, _)) = R
   10.68 @@ -353,7 +343,6 @@
   10.69    | rep_of (RelReg (_, _, R)) = R
   10.70    | rep_of (FormulaReg (_, _, R)) = R
   10.71  
   10.72 -(* nut -> string *)
   10.73  fun nickname_of (BoundName (_, _, _, nick)) = nick
   10.74    | nickname_of (FreeName (s, _, _)) = s
   10.75    | nickname_of (ConstName (s, _, _)) = s
   10.76 @@ -361,7 +350,6 @@
   10.77    | nickname_of (FreeRel (_, _, _, nick)) = nick
   10.78    | nickname_of u = raise NUT ("Nitpick_Nut.nickname_of", [u])
   10.79  
   10.80 -(* nut -> bool *)
   10.81  fun is_skolem_name u =
   10.82    space_explode name_sep (nickname_of u)
   10.83    |> exists (String.isPrefix skolem_prefix)
   10.84 @@ -369,11 +357,9 @@
   10.85  fun is_eval_name u =
   10.86    String.isPrefix eval_prefix (nickname_of u)
   10.87    handle NUT ("Nitpick_Nut.nickname_of", _) => false
   10.88 -(* cst -> nut -> bool *)
   10.89  fun is_Cst cst (Cst (cst', _, _)) = (cst = cst')
   10.90    | is_Cst _ _ = false
   10.91  
   10.92 -(* (nut -> 'a -> 'a) -> nut -> 'a -> 'a *)
   10.93  fun fold_nut f u =
   10.94    case u of
   10.95      Op1 (_, _, _, u1) => fold_nut f u1
   10.96 @@ -382,7 +368,6 @@
   10.97    | Tuple (_, _, us) => fold (fold_nut f) us
   10.98    | Construct (us', _, _, us) => fold (fold_nut f) us #> fold (fold_nut f) us'
   10.99    | _ => f u
  10.100 -(* (nut -> nut) -> nut -> nut *)
  10.101  fun map_nut f u =
  10.102    case u of
  10.103      Op1 (oper, T, R, u1) => Op1 (oper, T, R, map_nut f u1)
  10.104 @@ -394,7 +379,6 @@
  10.105      Construct (map (map_nut f) us', T, R, map (map_nut f) us)
  10.106    | _ => f u
  10.107  
  10.108 -(* nut * nut -> order *)
  10.109  fun name_ord (BoundName (j1, _, _, _), BoundName (j2, _, _, _)) =
  10.110      int_ord (j1, j2)
  10.111    | name_ord (BoundName _, _) = LESS
  10.112 @@ -411,24 +395,19 @@
  10.113       | ord => ord)
  10.114    | name_ord (u1, u2) = raise NUT ("Nitpick_Nut.name_ord", [u1, u2])
  10.115  
  10.116 -(* nut -> nut -> int *)
  10.117  fun num_occs_in_nut needle_u stack_u =
  10.118    fold_nut (fn u => if u = needle_u then Integer.add 1 else I) stack_u 0
  10.119 -(* nut -> nut -> bool *)
  10.120  val is_subterm_of = not_equal 0 oo num_occs_in_nut
  10.121  
  10.122 -(* nut -> nut -> nut -> nut *)
  10.123  fun substitute_in_nut needle_u needle_u' =
  10.124    map_nut (fn u => if u = needle_u then needle_u' else u)
  10.125  
  10.126 -(* nut -> nut list * nut list -> nut list * nut list *)
  10.127  val add_free_and_const_names =
  10.128    fold_nut (fn u => case u of
  10.129                        FreeName _ => apfst (insert (op =) u)
  10.130                      | ConstName _ => apsnd (insert (op =) u)
  10.131                      | _ => I)
  10.132  
  10.133 -(* nut -> rep -> nut *)
  10.134  fun modify_name_rep (BoundName (j, T, _, nick)) R = BoundName (j, T, R, nick)
  10.135    | modify_name_rep (FreeName (s, T, _)) R = FreeName (s, T, R)
  10.136    | modify_name_rep (ConstName (s, T, _)) R = ConstName (s, T, R)
  10.137 @@ -436,18 +415,15 @@
  10.138  
  10.139  structure NameTable = Table(type key = nut val ord = name_ord)
  10.140  
  10.141 -(* 'a NameTable.table -> nut -> 'a *)
  10.142  fun the_name table name =
  10.143    case NameTable.lookup table name of
  10.144      SOME u => u
  10.145    | NONE => raise NUT ("Nitpick_Nut.the_name", [name])
  10.146 -(* nut NameTable.table -> nut -> KK.n_ary_index *)
  10.147  fun the_rel table name =
  10.148    case the_name table name of
  10.149      FreeRel (x, _, _, _) => x
  10.150    | u => raise NUT ("Nitpick_Nut.the_rel", [u])
  10.151  
  10.152 -(* typ * term -> typ * term *)
  10.153  fun mk_fst (_, Const (@{const_name Pair}, T) $ t1 $ _) = (domain_type T, t1)
  10.154    | mk_fst (T, t) =
  10.155      let val res_T = fst (HOLogic.dest_prodT T) in
  10.156 @@ -459,23 +435,17 @@
  10.157      let val res_T = snd (HOLogic.dest_prodT T) in
  10.158        (res_T, Const (@{const_name snd}, T --> res_T) $ t)
  10.159      end
  10.160 -(* typ * term -> (typ * term) list *)
  10.161  fun factorize (z as (Type (@{type_name "*"}, _), _)) =
  10.162      maps factorize [mk_fst z, mk_snd z]
  10.163    | factorize z = [z]
  10.164  
  10.165 -(* hol_context -> op2 -> term -> nut *)
  10.166  fun nut_from_term (hol_ctxt as {thy, stds, fast_descrs, ...}) eq =
  10.167    let
  10.168 -    (* string list -> typ list -> term -> nut *)
  10.169      fun aux eq ss Ts t =
  10.170        let
  10.171 -        (* term -> nut *)
  10.172          val sub = aux Eq ss Ts
  10.173          val sub' = aux eq ss Ts
  10.174 -        (* string -> typ -> term -> nut *)
  10.175          fun sub_abs s T = aux eq (s :: ss) (T :: Ts)
  10.176 -        (* typ -> term -> term -> nut *)
  10.177          fun sub_equals T t1 t2 =
  10.178            let
  10.179              val (binder_Ts, body_T) = strip_type (domain_type T)
  10.180 @@ -498,7 +468,6 @@
  10.181              else
  10.182                Op2 (eq, bool_T, Any, aux Eq ss Ts t1, aux Eq ss Ts t2)
  10.183            end
  10.184 -        (* op2 -> string -> typ -> term -> nut *)
  10.185          fun do_quantifier quant s T t1 =
  10.186            let
  10.187              val bound_u = BoundName (length Ts, T, Any, s)
  10.188 @@ -509,21 +478,18 @@
  10.189              else
  10.190                body_u
  10.191            end
  10.192 -        (* term -> term list -> nut *)
  10.193          fun do_apply t0 ts =
  10.194            let
  10.195              val (ts', t2) = split_last ts
  10.196              val t1 = list_comb (t0, ts')
  10.197              val T1 = fastype_of1 (Ts, t1)
  10.198            in Op2 (Apply, range_type T1, Any, sub t1, sub t2) end
  10.199 -        (* op2 -> string -> styp -> term -> nut *)
  10.200          fun do_description_operator oper undef_s (x as (_, T)) t1 =
  10.201            if fast_descrs then
  10.202              Op2 (oper, range_type T, Any, sub t1,
  10.203                   sub (Const (undef_s, range_type T)))
  10.204            else
  10.205              do_apply (Const x) [t1]
  10.206 -        (* styp -> term list -> nut *)
  10.207          fun do_construct (x as (_, T)) ts =
  10.208            case num_binder_types T - length ts of
  10.209              0 => Construct (map ((fn (s', T') => ConstName (s', T', Any))
  10.210 @@ -716,21 +682,16 @@
  10.211        end
  10.212    in aux eq [] [] end
  10.213  
  10.214 -(* scope -> typ -> rep *)
  10.215  fun rep_for_abs_fun scope T =
  10.216    let val (R1, R2) = best_non_opt_symmetric_reps_for_fun_type scope T in
  10.217      Func (R1, (card_of_rep R1 <> card_of_rep R2 ? Opt) R2)
  10.218    end
  10.219  
  10.220 -(* scope -> nut -> nut list * rep NameTable.table
  10.221 -   -> nut list * rep NameTable.table *)
  10.222  fun choose_rep_for_free_var scope v (vs, table) =
  10.223    let
  10.224      val R = best_non_opt_set_rep_for_type scope (type_of v)
  10.225      val v = modify_name_rep v R
  10.226    in (v :: vs, NameTable.update (v, R) table) end
  10.227 -(* scope -> bool -> nut -> nut list * rep NameTable.table
  10.228 -   -> nut list * rep NameTable.table *)
  10.229  fun choose_rep_for_const (scope as {hol_ctxt = {thy, ...}, ...}) all_exact v
  10.230                           (vs, table) =
  10.231    let
  10.232 @@ -756,16 +717,11 @@
  10.233      val v = modify_name_rep v R
  10.234    in (v :: vs, NameTable.update (v, R) table) end
  10.235  
  10.236 -(* scope -> nut list -> rep NameTable.table -> nut list * rep NameTable.table *)
  10.237  fun choose_reps_for_free_vars scope vs table =
  10.238    fold (choose_rep_for_free_var scope) vs ([], table)
  10.239 -(* scope -> bool -> nut list -> rep NameTable.table
  10.240 -   -> nut list * rep NameTable.table *)
  10.241  fun choose_reps_for_consts scope all_exact vs table =
  10.242    fold (choose_rep_for_const scope all_exact) vs ([], table)
  10.243  
  10.244 -(* scope -> styp -> int -> nut list * rep NameTable.table
  10.245 -   -> nut list * rep NameTable.table *)
  10.246  fun choose_rep_for_nth_sel_for_constr (scope as {hol_ctxt, binarize, ...})
  10.247                                        (x as (_, T)) n (vs, table) =
  10.248    let
  10.249 @@ -778,21 +734,15 @@
  10.250                 best_opt_set_rep_for_type scope T' |> unopt_rep
  10.251      val v = ConstName (s', T', R')
  10.252    in (v :: vs, NameTable.update (v, R') table) end
  10.253 -(* scope -> styp -> nut list * rep NameTable.table
  10.254 -   -> nut list * rep NameTable.table *)
  10.255  fun choose_rep_for_sels_for_constr scope (x as (_, T)) =
  10.256    fold_rev (choose_rep_for_nth_sel_for_constr scope x)
  10.257             (~1 upto num_sels_for_constr_type T - 1)
  10.258 -(* scope -> dtype_spec -> nut list * rep NameTable.table
  10.259 -   -> nut list * rep NameTable.table *)
  10.260  fun choose_rep_for_sels_of_datatype _ ({deep = false, ...} : dtype_spec) = I
  10.261    | choose_rep_for_sels_of_datatype scope {constrs, ...} =
  10.262      fold_rev (choose_rep_for_sels_for_constr scope o #const) constrs
  10.263 -(* scope -> rep NameTable.table -> nut list * rep NameTable.table *)
  10.264  fun choose_reps_for_all_sels (scope as {datatypes, ...}) =
  10.265    fold (choose_rep_for_sels_of_datatype scope) datatypes o pair []
  10.266  
  10.267 -(* scope -> nut -> rep NameTable.table -> rep NameTable.table *)
  10.268  fun choose_rep_for_bound_var scope v table =
  10.269    let val R = best_one_rep_for_type scope (type_of v) in
  10.270      NameTable.update (v, R) table
  10.271 @@ -802,7 +752,6 @@
  10.272     three-valued logic, it would evaluate to a unrepresentable value ("Unrep")
  10.273     according to the HOL semantics. For example, "Suc n" is constructive if "n"
  10.274     is representable or "Unrep", because unknown implies "Unrep". *)
  10.275 -(* nut -> bool *)
  10.276  fun is_constructive u =
  10.277    is_Cst Unrep u orelse
  10.278    (not (is_fun_type (type_of u)) andalso not (is_opt_rep (rep_of u))) orelse
  10.279 @@ -817,14 +766,11 @@
  10.280    | Construct (_, _, _, us) => forall is_constructive us
  10.281    | _ => false
  10.282  
  10.283 -(* nut -> nut *)
  10.284  fun optimize_unit u =
  10.285    if rep_of u = Unit then Cst (Unity, type_of u, Unit) else u
  10.286 -(* typ -> rep -> nut *)
  10.287  fun unknown_boolean T R =
  10.288    Cst (case R of Formula Pos => False | Formula Neg => True | _ => Unknown,
  10.289         T, R)
  10.290 -(* nut -> bool *)
  10.291  fun is_fully_representable_set u =
  10.292    not (is_opt_rep (rep_of u)) andalso
  10.293    case u of
  10.294 @@ -835,7 +781,6 @@
  10.295      forall is_fully_representable_set [u1, u2]
  10.296    | _ => false
  10.297  
  10.298 -(* op1 -> typ -> rep -> nut -> nut *)
  10.299  fun s_op1 oper T R u1 =
  10.300    ((if oper = Not then
  10.301        if is_Cst True u1 then Cst (False, T, R)
  10.302 @@ -845,7 +790,6 @@
  10.303        raise SAME ())
  10.304     handle SAME () => Op1 (oper, T, R, u1))
  10.305    |> optimize_unit
  10.306 -(* op2 -> typ -> rep -> nut -> nut -> nut *)
  10.307  fun s_op2 oper T R u1 u2 =
  10.308    ((case oper of
  10.309        Or =>
  10.310 @@ -886,7 +830,6 @@
  10.311      | _ => raise SAME ())
  10.312     handle SAME () => Op2 (oper, T, R, u1, u2))
  10.313    |> optimize_unit
  10.314 -(* op3 -> typ -> rep -> nut -> nut -> nut -> nut *)
  10.315  fun s_op3 oper T R u1 u2 u3 =
  10.316    ((case oper of
  10.317        Let =>
  10.318 @@ -897,12 +840,10 @@
  10.319      | _ => raise SAME ())
  10.320     handle SAME () => Op3 (oper, T, R, u1, u2, u3))
  10.321    |> optimize_unit
  10.322 -(* typ -> rep -> nut list -> nut *)
  10.323  fun s_tuple T R us =
  10.324    (if exists (is_Cst Unrep) us then Cst (Unrep, T, R) else Tuple (T, R, us))
  10.325    |> optimize_unit
  10.326  
  10.327 -(* theory -> nut -> nut *)
  10.328  fun optimize_nut u =
  10.329    case u of
  10.330      Op1 (oper, T, R, u1) => s_op1 oper T R (optimize_nut u1)
  10.331 @@ -914,35 +855,26 @@
  10.332    | Construct (us', T, R, us) => Construct (us', T, R, map optimize_nut us)
  10.333    | _ => optimize_unit u
  10.334  
  10.335 -(* (nut -> 'a) -> nut -> 'a list *)
  10.336  fun untuple f (Tuple (_, _, us)) = maps (untuple f) us
  10.337    | untuple f u = if rep_of u = Unit then [] else [f u]
  10.338  
  10.339 -(* scope -> bool -> rep NameTable.table -> bool -> nut -> nut *)
  10.340  fun choose_reps_in_nut (scope as {card_assigns, bits, datatypes, ofs, ...})
  10.341                         unsound table def =
  10.342    let
  10.343      val bool_atom_R = Atom (2, offset_of_type ofs bool_T)
  10.344 -    (* polarity -> bool -> rep *)
  10.345      fun bool_rep polar opt =
  10.346        if polar = Neut andalso opt then Opt bool_atom_R else Formula polar
  10.347 -    (* nut -> nut -> nut *)
  10.348      fun triad u1 u2 = s_op2 Triad (type_of u1) (Opt bool_atom_R) u1 u2
  10.349 -    (* (polarity -> nut) -> nut *)
  10.350      fun triad_fn f = triad (f Pos) (f Neg)
  10.351 -    (* rep NameTable.table -> bool -> polarity -> nut -> nut -> nut *)
  10.352      fun unrepify_nut_in_nut table def polar needle_u =
  10.353        let val needle_T = type_of needle_u in
  10.354          substitute_in_nut needle_u (Cst (if is_fun_type needle_T then Unknown
  10.355                                           else Unrep, needle_T, Any))
  10.356          #> aux table def polar
  10.357        end
  10.358 -    (* rep NameTable.table -> bool -> polarity -> nut -> nut *)
  10.359      and aux table def polar u =
  10.360        let
  10.361 -        (* bool -> polarity -> nut -> nut *)
  10.362          val gsub = aux table
  10.363 -        (* nut -> nut *)
  10.364          val sub = gsub false Neut
  10.365        in
  10.366          case u of
  10.367 @@ -1050,15 +982,12 @@
  10.368            let
  10.369              val u1' = sub u1
  10.370              val u2' = sub u2
  10.371 -            (* unit -> nut *)
  10.372              fun non_opt_case () = s_op2 Eq T (Formula polar) u1' u2'
  10.373 -            (* unit -> nut *)
  10.374              fun opt_opt_case () =
  10.375                if polar = Neut then
  10.376                  triad_fn (fn polar => s_op2 Eq T (Formula polar) u1' u2')
  10.377                else
  10.378                  non_opt_case ()
  10.379 -            (* nut -> nut *)
  10.380              fun hybrid_case u =
  10.381                (* hackish optimization *)
  10.382                if is_constructive u then s_op2 Eq T (Formula Neut) u1' u2'
  10.383 @@ -1275,35 +1204,27 @@
  10.384        |> optimize_unit
  10.385    in aux table def Pos end
  10.386  
  10.387 -(* int -> KK.n_ary_index list -> KK.n_ary_index list
  10.388 -   -> int * KK.n_ary_index list *)
  10.389  fun fresh_n_ary_index n [] ys = (0, (n, 1) :: ys)
  10.390    | fresh_n_ary_index n ((m, j) :: xs) ys =
  10.391      if m = n then (j, ys @ ((m, j + 1) :: xs))
  10.392      else fresh_n_ary_index n xs ((m, j) :: ys)
  10.393 -(* int -> name_pool -> int * name_pool *)
  10.394  fun fresh_rel n {rels, vars, formula_reg, rel_reg} =
  10.395    let val (j, rels') = fresh_n_ary_index n rels [] in
  10.396      (j, {rels = rels', vars = vars, formula_reg = formula_reg,
  10.397           rel_reg = rel_reg})
  10.398    end
  10.399 -(* int -> name_pool -> int * name_pool *)
  10.400  fun fresh_var n {rels, vars, formula_reg, rel_reg} =
  10.401    let val (j, vars') = fresh_n_ary_index n vars [] in
  10.402      (j, {rels = rels, vars = vars', formula_reg = formula_reg,
  10.403           rel_reg = rel_reg})
  10.404    end
  10.405 -(* int -> name_pool -> int * name_pool *)
  10.406  fun fresh_formula_reg {rels, vars, formula_reg, rel_reg} =
  10.407    (formula_reg, {rels = rels, vars = vars, formula_reg = formula_reg + 1,
  10.408                   rel_reg = rel_reg})
  10.409 -(* int -> name_pool -> int * name_pool *)
  10.410  fun fresh_rel_reg {rels, vars, formula_reg, rel_reg} =
  10.411    (rel_reg, {rels = rels, vars = vars, formula_reg = formula_reg,
  10.412               rel_reg = rel_reg + 1})
  10.413  
  10.414 -(* nut -> nut list * name_pool * nut NameTable.table
  10.415 -   -> nut list * name_pool * nut NameTable.table *)
  10.416  fun rename_plain_var v (ws, pool, table) =
  10.417    let
  10.418      val is_formula = (rep_of v = Formula Neut)
  10.419 @@ -1313,7 +1234,6 @@
  10.420      val w = constr (j, type_of v, rep_of v)
  10.421    in (w :: ws, pool, NameTable.update (v, w) table) end
  10.422  
  10.423 -(* typ -> rep -> nut list -> nut *)
  10.424  fun shape_tuple (T as Type (@{type_name "*"}, [T1, T2])) (R as Struct [R1, R2])
  10.425                  us =
  10.426      let val arity1 = arity_of_rep R1 in
  10.427 @@ -1327,8 +1247,6 @@
  10.428    | shape_tuple T Unit [] = Cst (Unity, T, Unit)
  10.429    | shape_tuple _ _ us = raise NUT ("Nitpick_Nut.shape_tuple", us)
  10.430  
  10.431 -(* bool -> nut -> nut list * name_pool * nut NameTable.table
  10.432 -   -> nut list * name_pool * nut NameTable.table *)
  10.433  fun rename_n_ary_var rename_free v (ws, pool, table) =
  10.434    let
  10.435      val T = type_of v
  10.436 @@ -1370,15 +1288,12 @@
  10.437        in (w :: ws, pool, NameTable.update (v, w) table) end
  10.438    end
  10.439  
  10.440 -(* nut list -> name_pool -> nut NameTable.table
  10.441 -  -> nut list * name_pool * nut NameTable.table *)
  10.442  fun rename_free_vars vs pool table =
  10.443    let
  10.444      val vs = filter (not_equal Unit o rep_of) vs
  10.445      val (vs, pool, table) = fold (rename_n_ary_var true) vs ([], pool, table)
  10.446    in (rev vs, pool, table) end
  10.447  
  10.448 -(* name_pool -> nut NameTable.table -> nut -> nut *)
  10.449  fun rename_vars_in_nut pool table u =
  10.450    case u of
  10.451      Cst _ => u
    11.1 --- a/src/HOL/Tools/Nitpick/nitpick_peephole.ML	Sat Apr 24 16:17:30 2010 +0200
    11.2 +++ b/src/HOL/Tools/Nitpick/nitpick_peephole.ML	Sat Apr 24 16:33:01 2010 +0200
    11.3 @@ -125,40 +125,31 @@
    11.4  val lcm_rel = (3, 11)
    11.5  val norm_frac_rel = (4, 0)
    11.6  
    11.7 -(* int -> bool -> rel_expr *)
    11.8  fun atom_for_bool j0 = Atom o Integer.add j0 o int_from_bool
    11.9 -(* bool -> formula *)
   11.10  fun formula_for_bool b = if b then True else False
   11.11  
   11.12 -(* int * int -> int -> int *)
   11.13  fun atom_for_nat (k, j0) n = if n < 0 orelse n >= k then ~1 else n + j0
   11.14 -(* int -> int *)
   11.15  fun min_int_for_card k = ~k div 2 + 1
   11.16  fun max_int_for_card k = k div 2
   11.17 -(* int * int -> int -> int *)
   11.18  fun int_for_atom (k, j0) j =
   11.19    let val j = j - j0 in if j <= max_int_for_card k then j else j - k end
   11.20  fun atom_for_int (k, j0) n =
   11.21    if n < min_int_for_card k orelse n > max_int_for_card k then ~1
   11.22    else if n < 0 then n + k + j0
   11.23    else n + j0
   11.24 -(* int -> int -> bool *)
   11.25  fun is_twos_complement_representable bits n =
   11.26    let val max = reasonable_power 2 bits in n >= ~ max andalso n < max end
   11.27  
   11.28 -(* rel_expr -> bool *)
   11.29  fun is_none_product (Product (r1, r2)) =
   11.30      is_none_product r1 orelse is_none_product r2
   11.31    | is_none_product None = true
   11.32    | is_none_product _ = false
   11.33  
   11.34 -(* rel_expr -> bool *)
   11.35  fun is_one_rel_expr (Atom _) = true
   11.36    | is_one_rel_expr (AtomSeq (1, _)) = true
   11.37    | is_one_rel_expr (Var _) = true
   11.38    | is_one_rel_expr _ = false
   11.39  
   11.40 -(* rel_expr -> bool *)
   11.41  fun inline_rel_expr (Product (r1, r2)) =
   11.42      inline_rel_expr r1 andalso inline_rel_expr r2
   11.43    | inline_rel_expr Iden = true
   11.44 @@ -172,7 +163,6 @@
   11.45    | inline_rel_expr (RelReg _) = true
   11.46    | inline_rel_expr _ = false
   11.47  
   11.48 -(* rel_expr -> rel_expr -> bool option *)
   11.49  fun rel_expr_equal None (Atom _) = SOME false
   11.50    | rel_expr_equal None (AtomSeq (k, _)) = SOME (k = 0)
   11.51    | rel_expr_equal (Atom _) None = SOME false
   11.52 @@ -183,7 +173,6 @@
   11.53    | rel_expr_equal (AtomSeq x1) (AtomSeq x2) = SOME (x1 = x2)
   11.54    | rel_expr_equal r1 r2 = if r1 = r2 then SOME true else NONE
   11.55  
   11.56 -(* rel_expr -> rel_expr -> bool option *)
   11.57  fun rel_expr_intersects (Atom j1) (Atom j2) = SOME (j1 = j2)
   11.58    | rel_expr_intersects (Atom j) (AtomSeq (k, j0)) = SOME (j < j0 + k)
   11.59    | rel_expr_intersects (AtomSeq (k, j0)) (Atom j) = SOME (j < j0 + k)
   11.60 @@ -192,30 +181,23 @@
   11.61    | rel_expr_intersects r1 r2 =
   11.62      if is_none_product r1 orelse is_none_product r2 then SOME false else NONE
   11.63  
   11.64 -(* int -> rel_expr *)
   11.65  fun empty_n_ary_rel 0 = raise ARG ("Nitpick_Peephole.empty_n_ary_rel", "0")
   11.66    | empty_n_ary_rel n = funpow (n - 1) (curry Product None) None
   11.67  
   11.68 -(* decl -> rel_expr *)
   11.69  fun decl_one_set (DeclOne (_, r)) = r
   11.70    | decl_one_set _ =
   11.71      raise ARG ("Nitpick_Peephole.decl_one_set", "not \"DeclOne\"")
   11.72  
   11.73 -(* int_expr -> bool *)
   11.74  fun is_Num (Num _) = true
   11.75    | is_Num _ = false
   11.76 -(* int_expr -> int *)
   11.77  fun dest_Num (Num k) = k
   11.78    | dest_Num _ = raise ARG ("Nitpick_Peephole.dest_Num", "not \"Num\"")
   11.79 -(* int -> int -> int_expr list *)
   11.80  fun num_seq j0 n = map Num (index_seq j0 n)
   11.81  
   11.82 -(* rel_expr -> rel_expr -> bool *)
   11.83  fun occurs_in_union r (Union (r1, r2)) =
   11.84      occurs_in_union r r1 orelse occurs_in_union r r2
   11.85    | occurs_in_union r r' = (r = r')
   11.86  
   11.87 -(* rel_expr -> rel_expr -> rel_expr *)
   11.88  fun s_and True f2 = f2
   11.89    | s_and False _ = False
   11.90    | s_and f1 True = f1
   11.91 @@ -258,18 +240,13 @@
   11.92  
   11.93  (* We assume throughout that Kodkod variables have a "one" constraint. This is
   11.94     always the case if Kodkod's skolemization is disabled. *)
   11.95 -(* bool -> int -> int -> int -> kodkod_constrs *)
   11.96  fun kodkod_constrs optim nat_card int_card main_j0 =
   11.97    let
   11.98 -    (* bool -> int *)
   11.99      val from_bool = atom_for_bool main_j0
  11.100 -    (* int -> rel_expr *)
  11.101      fun from_nat n = Atom (n + main_j0)
  11.102 -    (* int -> int *)
  11.103      fun to_nat j = j - main_j0
  11.104      val to_int = int_for_atom (int_card, main_j0)
  11.105  
  11.106 -    (* decl list -> formula -> formula *)
  11.107      fun s_all _ True = True
  11.108        | s_all _ False = False
  11.109        | s_all [] f = f
  11.110 @@ -281,12 +258,10 @@
  11.111        | s_exist ds (Exist (ds', f)) = Exist (ds @ ds', f)
  11.112        | s_exist ds f = Exist (ds, f)
  11.113  
  11.114 -    (* expr_assign list -> formula -> formula *)
  11.115      fun s_formula_let _ True = True
  11.116        | s_formula_let _ False = False
  11.117        | s_formula_let assigns f = FormulaLet (assigns, f)
  11.118  
  11.119 -    (* formula -> formula *)
  11.120      fun s_not True = False
  11.121        | s_not False = True
  11.122        | s_not (All (ds, f)) = Exist (ds, s_not f)
  11.123 @@ -299,7 +274,6 @@
  11.124        | s_not (Some r) = No r
  11.125        | s_not f = Not f
  11.126  
  11.127 -    (* formula -> formula -> formula *)
  11.128      fun s_or True _ = True
  11.129        | s_or False f2 = f2
  11.130        | s_or _ True = True
  11.131 @@ -316,7 +290,6 @@
  11.132        | s_implies f1 False = s_not f1
  11.133        | s_implies f1 f2 = if f1 = f2 then True else Implies (f1, f2)
  11.134  
  11.135 -    (* formula -> formula -> formula -> formula *)
  11.136      fun s_formula_if True f2 _ = f2
  11.137        | s_formula_if False _ f3 = f3
  11.138        | s_formula_if f1 True f3 = s_or f1 f3
  11.139 @@ -325,7 +298,6 @@
  11.140        | s_formula_if f1 f2 False = s_and f1 f2
  11.141        | s_formula_if f f1 f2 = FormulaIf (f, f1, f2)
  11.142  
  11.143 -    (* rel_expr -> int_expr list -> rel_expr *)
  11.144      fun s_project r is =
  11.145        (case r of
  11.146           Project (r1, is') =>
  11.147 @@ -340,7 +312,6 @@
  11.148                 else Project (r, is)
  11.149               end
  11.150  
  11.151 -    (* (rel_expr -> formula) -> rel_expr -> formula *)
  11.152      fun s_xone xone r =
  11.153        if is_one_rel_expr r then
  11.154          True
  11.155 @@ -348,7 +319,6 @@
  11.156          1 => xone r
  11.157        | arity => foldl1 And (map (xone o s_project r o single o Num)
  11.158                                   (index_seq 0 arity))
  11.159 -    (* rel_expr -> formula *)
  11.160      fun s_no None = True
  11.161        | s_no (Product (r1, r2)) = s_or (s_no r1) (s_no r2)
  11.162        | s_no (Intersect (Closure (Rel x), Iden)) = Acyclic x
  11.163 @@ -362,13 +332,11 @@
  11.164        | s_some (Product (r1, r2)) = s_and (s_some r1) (s_some r2)
  11.165        | s_some r = if is_one_rel_expr r then True else Some r
  11.166  
  11.167 -    (* rel_expr -> rel_expr *)
  11.168      fun s_not3 (Atom j) = Atom (if j = main_j0 then j + 1 else j - 1)
  11.169        | s_not3 (r as Join (r1, r2)) =
  11.170          if r2 = Rel not3_rel then r1 else Join (r, Rel not3_rel)
  11.171        | s_not3 r = Join (r, Rel not3_rel)
  11.172  
  11.173 -    (* rel_expr -> rel_expr -> formula *)
  11.174      fun s_rel_eq r1 r2 =
  11.175        (case (r1, r2) of
  11.176           (Join (r11, Rel x), _) =>
  11.177 @@ -427,12 +395,10 @@
  11.178          else if forall is_one_rel_expr [r1, r2] then s_rel_eq r1 r2
  11.179          else Subset (r1, r2)
  11.180  
  11.181 -    (* expr_assign list -> rel_expr -> rel_expr *)
  11.182      fun s_rel_let [b as AssignRelReg (x', r')] (r as RelReg x) =
  11.183          if x = x' then r' else RelLet ([b], r)
  11.184        | s_rel_let bs r = RelLet (bs, r)
  11.185  
  11.186 -    (* formula -> rel_expr -> rel_expr -> rel_expr *)
  11.187      fun s_rel_if f r1 r2 =
  11.188        (case (f, r1, r2) of
  11.189           (True, _, _) => r1
  11.190 @@ -443,7 +409,6 @@
  11.191         | _ => raise SAME ())
  11.192        handle SAME () => if r1 = r2 then r1 else RelIf (f, r1, r2)
  11.193  
  11.194 -    (* rel_expr -> rel_expr -> rel_expr *)
  11.195      fun s_union r1 (Union (r21, r22)) = s_union (s_union r1 r21) r22
  11.196        | s_union r1 r2 =
  11.197          if is_none_product r1 then r2
  11.198 @@ -561,14 +526,12 @@
  11.199           handle SAME () => List.foldr Join r22 [r1, r21])
  11.200        | s_join r1 r2 = Join (r1, r2)
  11.201  
  11.202 -    (* rel_expr -> rel_expr *)
  11.203      fun s_closure Iden = Iden
  11.204        | s_closure r = if is_none_product r then r else Closure r
  11.205      fun s_reflexive_closure Iden = Iden
  11.206        | s_reflexive_closure r =
  11.207          if is_none_product r then Iden else ReflexiveClosure r
  11.208  
  11.209 -    (* decl list -> formula -> rel_expr *)
  11.210      fun s_comprehension ds False = empty_n_ary_rel (length ds)
  11.211        | s_comprehension ds True = fold1 s_product (map decl_one_set ds)
  11.212        | s_comprehension [d as DeclOne ((1, j1), r)]
  11.213 @@ -579,10 +542,8 @@
  11.214            Comprehension ([d], f)
  11.215        | s_comprehension ds f = Comprehension (ds, f)
  11.216  
  11.217 -    (* rel_expr -> int -> int -> rel_expr *)
  11.218      fun s_project_seq r =
  11.219        let
  11.220 -        (* int -> rel_expr -> int -> int -> rel_expr *)
  11.221          fun aux arity r j0 n =
  11.222            if j0 = 0 andalso arity = n then
  11.223              r
  11.224 @@ -595,7 +556,6 @@
  11.225                val arity1 = arity - arity2
  11.226                val n1 = Int.min (nat_minus arity1 j0, n)
  11.227                val n2 = n - n1
  11.228 -              (* unit -> rel_expr *)
  11.229                fun one () = aux arity1 r1 j0 n1
  11.230                fun two () = aux arity2 r2 (nat_minus j0 arity1) n2
  11.231              in
  11.232 @@ -607,17 +567,13 @@
  11.233            | _ => s_project r (num_seq j0 n)
  11.234        in aux (arity_of_rel_expr r) r end
  11.235  
  11.236 -    (* rel_expr -> rel_expr -> rel_expr *)
  11.237      fun s_nat_less (Atom j1) (Atom j2) = from_bool (j1 < j2)
  11.238        | s_nat_less r1 r2 = fold s_join [r1, r2] (Rel nat_less_rel)
  11.239      fun s_int_less (Atom j1) (Atom j2) = from_bool (to_int j1 < to_int j2)
  11.240        | s_int_less r1 r2 = fold s_join [r1, r2] (Rel int_less_rel)
  11.241  
  11.242 -    (* rel_expr -> int -> int -> rel_expr *)
  11.243      fun d_project_seq r j0 n = Project (r, num_seq j0 n)
  11.244 -    (* rel_expr -> rel_expr *)
  11.245      fun d_not3 r = Join (r, Rel not3_rel)
  11.246 -    (* rel_expr -> rel_expr -> rel_expr *)
  11.247      fun d_nat_less r1 r2 = List.foldl Join (Rel nat_less_rel) [r1, r2]
  11.248      fun d_int_less r1 r2 = List.foldl Join (Rel int_less_rel) [r1, r2]
  11.249    in
    12.1 --- a/src/HOL/Tools/Nitpick/nitpick_preproc.ML	Sat Apr 24 16:17:30 2010 +0200
    12.2 +++ b/src/HOL/Tools/Nitpick/nitpick_preproc.ML	Sat Apr 24 16:33:01 2010 +0200
    12.3 @@ -21,7 +21,6 @@
    12.4  open Nitpick_HOL
    12.5  open Nitpick_Mono
    12.6  
    12.7 -(* polarity -> string -> bool *)
    12.8  fun is_positive_existential polar quant_s =
    12.9    (polar = Pos andalso quant_s = @{const_name Ex}) orelse
   12.10    (polar = Neg andalso quant_s <> @{const_name Ex})
   12.11 @@ -33,10 +32,8 @@
   12.12     binary coding. *)
   12.13  val binary_int_threshold = 3
   12.14  
   12.15 -(* bool -> term -> bool *)
   12.16  val may_use_binary_ints =
   12.17    let
   12.18 -    (* bool -> term -> bool *)
   12.19      fun aux def (Const (@{const_name "=="}, _) $ t1 $ t2) =
   12.20          aux def t1 andalso aux false t2
   12.21        | aux def (@{const "==>"} $ t1 $ t2) = aux false t1 andalso aux def t2
   12.22 @@ -52,10 +49,8 @@
   12.23        | aux def (Abs (_, _, t')) = aux def t'
   12.24        | aux _ _ = true
   12.25    in aux end
   12.26 -(* term -> bool *)
   12.27  val should_use_binary_ints =
   12.28    let
   12.29 -    (* term -> bool *)
   12.30      fun aux (t1 $ t2) = aux t1 orelse aux t2
   12.31        | aux (Const (s, T)) =
   12.32          ((s = @{const_name times} orelse s = @{const_name div}) andalso
   12.33 @@ -70,10 +65,8 @@
   12.34  
   12.35  (** Uncurrying **)
   12.36  
   12.37 -(* theory -> term -> int Termtab.tab -> int Termtab.tab *)
   12.38  fun add_to_uncurry_table thy t =
   12.39    let
   12.40 -    (* term -> term list -> int Termtab.tab -> int Termtab.tab *)
   12.41      fun aux (t1 $ t2) args table =
   12.42          let val table = aux t2 [] table in aux t1 (t2 :: args) table end
   12.43        | aux (Abs (_, _, t')) _ table = aux t' [] table
   12.44 @@ -87,14 +80,11 @@
   12.45        | aux _ _ table = table
   12.46    in aux t [] end
   12.47  
   12.48 -(* int -> int -> string *)
   12.49  fun uncurry_prefix_for k j =
   12.50    uncurry_prefix ^ string_of_int k ^ "@" ^ string_of_int j ^ name_sep
   12.51  
   12.52 -(* int Termtab.tab term -> term *)
   12.53  fun uncurry_term table t =
   12.54    let
   12.55 -    (* term -> term list -> term *)
   12.56      fun aux (t1 $ t2) args = aux t1 (aux t2 [] :: args)
   12.57        | aux (Abs (s, T, t')) args = betapplys (Abs (s, T, aux t' []), args)
   12.58        | aux (t as Const (s, T)) args =
   12.59 @@ -131,17 +121,14 @@
   12.60  
   12.61  (** Boxing **)
   12.62  
   12.63 -(* hol_context -> bool -> term -> term *)
   12.64  fun box_fun_and_pair_in_term (hol_ctxt as {thy, stds, fast_descrs, ...}) def
   12.65                               orig_t =
   12.66    let
   12.67 -    (* typ -> typ *)
   12.68      fun box_relational_operator_type (Type (@{type_name fun}, Ts)) =
   12.69          Type (@{type_name fun}, map box_relational_operator_type Ts)
   12.70        | box_relational_operator_type (Type (@{type_name "*"}, Ts)) =
   12.71          Type (@{type_name "*"}, map (box_type hol_ctxt InPair) Ts)
   12.72        | box_relational_operator_type T = T
   12.73 -    (* indexname * typ -> typ * term -> typ option list -> typ option list *)
   12.74      fun add_boxed_types_for_var (z as (_, T)) (T', t') =
   12.75        case t' of
   12.76          Var z' => z' = z ? insert (op =) T'
   12.77 @@ -152,7 +139,6 @@
   12.78           | _ => raise TYPE ("Nitpick_Preproc.box_fun_and_pair_in_term.\
   12.79                              \add_boxed_types_for_var", [T'], []))
   12.80        | _ => exists_subterm (curry (op =) (Var z)) t' ? insert (op =) T
   12.81 -    (* typ list -> typ list -> term -> indexname * typ -> typ *)
   12.82      fun box_var_in_def new_Ts old_Ts t (z as (_, T)) =
   12.83        case t of
   12.84          @{const Trueprop} $ t1 => box_var_in_def new_Ts old_Ts t1 z
   12.85 @@ -170,8 +156,6 @@
   12.86          else
   12.87            T
   12.88        | _ => T
   12.89 -    (* typ list -> typ list -> polarity -> string -> typ -> string -> typ
   12.90 -       -> term -> term *)
   12.91      and do_quantifier new_Ts old_Ts polar quant_s quant_T abs_s abs_T t =
   12.92        let
   12.93          val abs_T' =
   12.94 @@ -185,7 +169,6 @@
   12.95          $ Abs (abs_s, abs_T',
   12.96                 t |> do_term (abs_T' :: new_Ts) (abs_T :: old_Ts) polar)
   12.97        end
   12.98 -    (* typ list -> typ list -> string -> typ -> term -> term -> term *)
   12.99      and do_equals new_Ts old_Ts s0 T0 t1 t2 =
  12.100        let
  12.101          val (t1, t2) = pairself (do_term new_Ts old_Ts Neut) (t1, t2)
  12.102 @@ -195,12 +178,10 @@
  12.103          list_comb (Const (s0, T --> T --> body_type T0),
  12.104                     map2 (coerce_term hol_ctxt new_Ts T) [T1, T2] [t1, t2])
  12.105        end
  12.106 -    (* string -> typ -> term *)
  12.107      and do_description_operator s T =
  12.108        let val T1 = box_type hol_ctxt InFunLHS (range_type T) in
  12.109          Const (s, (T1 --> bool_T) --> T1)
  12.110        end
  12.111 -    (* typ list -> typ list -> polarity -> term -> term *)
  12.112      and do_term new_Ts old_Ts polar t =
  12.113        case t of
  12.114          Const (s0 as @{const_name all}, T0) $ Abs (s1, T1, t1) =>
  12.115 @@ -302,21 +283,16 @@
  12.116  
  12.117  val val_var_prefix = nitpick_prefix ^ "v"
  12.118  
  12.119 -(* typ list -> int -> int -> int -> term -> term *)
  12.120  fun fresh_value_var Ts k n j t =
  12.121    Var ((val_var_prefix ^ nat_subscript (n - j), k), fastype_of1 (Ts, t))
  12.122  
  12.123 -(* typ list -> term -> bool *)
  12.124  fun has_heavy_bounds_or_vars Ts t =
  12.125    let
  12.126 -    (* typ list -> bool *)
  12.127      fun aux [] = false
  12.128        | aux [T] = is_fun_type T orelse is_pair_type T
  12.129        | aux _ = true
  12.130    in aux (map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t)) end
  12.131  
  12.132 -(* hol_context -> typ list -> bool -> int -> int -> term -> term list
  12.133 -   -> term list -> term * term list *)
  12.134  fun pull_out_constr_comb ({thy, stds, ...} : hol_context) Ts relax k level t
  12.135                           args seen =
  12.136    let val t_comb = list_comb (t, args) in
  12.137 @@ -336,18 +312,15 @@
  12.138      | _ => (t_comb, seen)
  12.139    end
  12.140  
  12.141 -(* (term -> term) -> typ list -> int -> term list -> term list *)
  12.142  fun equations_for_pulled_out_constrs mk_eq Ts k seen =
  12.143    let val n = length seen in
  12.144      map2 (fn j => fn t => mk_eq (fresh_value_var Ts k n j t, t))
  12.145           (index_seq 0 n) seen
  12.146    end
  12.147  
  12.148 -(* hol_context -> bool -> term -> term *)
  12.149  fun pull_out_universal_constrs hol_ctxt def t =
  12.150    let
  12.151      val k = maxidx_of_term t + 1
  12.152 -    (* typ list -> bool -> term -> term list -> term list -> term * term list *)
  12.153      fun do_term Ts def t args seen =
  12.154        case t of
  12.155          (t0 as Const (@{const_name "=="}, _)) $ t1 $ t2 =>
  12.156 @@ -367,8 +340,6 @@
  12.157            do_term Ts def t1 (t2 :: args) seen
  12.158          end
  12.159        | _ => pull_out_constr_comb hol_ctxt Ts def k 0 t args seen
  12.160 -    (* typ list -> bool -> bool -> term -> term -> term -> term list
  12.161 -       -> term * term list *)
  12.162      and do_eq_or_imp Ts eq def t0 t1 t2 seen =
  12.163        let
  12.164          val (t2, seen) = if eq andalso def then (t2, seen)
  12.165 @@ -381,22 +352,18 @@
  12.166                                                           seen, concl)
  12.167    end
  12.168  
  12.169 -(* term -> term -> term *)
  12.170  fun mk_exists v t =
  12.171    HOLogic.exists_const (fastype_of v) $ lambda v (incr_boundvars 1 t)
  12.172  
  12.173 -(* hol_context -> term -> term *)
  12.174  fun pull_out_existential_constrs hol_ctxt t =
  12.175    let
  12.176      val k = maxidx_of_term t + 1
  12.177 -    (* typ list -> int -> term -> term list -> term list -> term * term list *)
  12.178      fun aux Ts num_exists t args seen =
  12.179        case t of
  12.180          (t0 as Const (@{const_name Ex}, _)) $ Abs (s1, T1, t1) =>
  12.181          let
  12.182            val (t1, seen') = aux (T1 :: Ts) (num_exists + 1) t1 [] []
  12.183            val n = length seen'
  12.184 -          (* unit -> term list *)
  12.185            fun vars () = map2 (fresh_value_var Ts k n) (index_seq 0 n) seen'
  12.186          in
  12.187            (equations_for_pulled_out_constrs HOLogic.mk_eq Ts k seen'
  12.188 @@ -421,7 +388,6 @@
  12.189  val let_var_prefix = nitpick_prefix ^ "l"
  12.190  val let_inline_threshold = 32
  12.191  
  12.192 -(* int -> typ -> term -> (term -> term) -> term *)
  12.193  fun hol_let n abs_T body_T f t =
  12.194    if n * size_of_term t <= let_inline_threshold then
  12.195      f t
  12.196 @@ -431,14 +397,11 @@
  12.197        $ t $ abs_var z (incr_boundvars 1 (f (Var z)))
  12.198      end
  12.199  
  12.200 -(* hol_context -> bool -> term -> term *)
  12.201  fun destroy_pulled_out_constrs (hol_ctxt as {thy, stds, ...}) axiom t =
  12.202    let
  12.203 -    (* styp -> int *)
  12.204      val num_occs_of_var =
  12.205        fold_aterms (fn Var z => (fn f => fn z' => f z' |> z = z' ? Integer.add 1)
  12.206                      | _ => I) t (K 0)
  12.207 -    (* bool -> term -> term *)
  12.208      fun aux careful ((t0 as Const (@{const_name "=="}, _)) $ t1 $ t2) =
  12.209          aux_eq careful true t0 t1 t2
  12.210        | aux careful ((t0 as @{const "==>"}) $ t1 $ t2) =
  12.211 @@ -450,7 +413,6 @@
  12.212        | aux careful (Abs (s, T, t')) = Abs (s, T, aux careful t')
  12.213        | aux careful (t1 $ t2) = aux careful t1 $ aux careful t2
  12.214        | aux _ t = t
  12.215 -    (* bool -> bool -> term -> term -> term -> term *)
  12.216      and aux_eq careful pass1 t0 t1 t2 =
  12.217        ((if careful then
  12.218            raise SAME ()
  12.219 @@ -485,7 +447,6 @@
  12.220         |> body_type (type_of t0) = prop_T ? HOLogic.mk_Trueprop)
  12.221        handle SAME () => if pass1 then aux_eq careful false t0 t2 t1
  12.222                          else t0 $ aux false t2 $ aux false t1
  12.223 -    (* styp -> term -> int -> typ -> term -> term *)
  12.224      and sel_eq x t n nth_T nth_t =
  12.225        HOLogic.eq_const nth_T $ nth_t
  12.226                               $ select_nth_constr_arg thy stds x t n nth_T
  12.227 @@ -494,7 +455,6 @@
  12.228  
  12.229  (** Destruction of universal and existential equalities **)
  12.230  
  12.231 -(* term -> term *)
  12.232  fun curry_assms (@{const "==>"} $ (@{const Trueprop}
  12.233                                     $ (@{const "op &"} $ t1 $ t2)) $ t3) =
  12.234      curry_assms (Logic.list_implies ([t1, t2] |> map HOLogic.mk_Trueprop, t3))
  12.235 @@ -502,15 +462,12 @@
  12.236      @{const "==>"} $ curry_assms t1 $ curry_assms t2
  12.237    | curry_assms t = t
  12.238  
  12.239 -(* term -> term *)
  12.240  val destroy_universal_equalities =
  12.241    let
  12.242 -    (* term list -> (indexname * typ) list -> term -> term *)
  12.243      fun aux prems zs t =
  12.244        case t of
  12.245          @{const "==>"} $ t1 $ t2 => aux_implies prems zs t1 t2
  12.246        | _ => Logic.list_implies (rev prems, t)
  12.247 -    (* term list -> (indexname * typ) list -> term -> term -> term *)
  12.248      and aux_implies prems zs t1 t2 =
  12.249        case t1 of
  12.250          Const (@{const_name "=="}, _) $ Var z $ t' => aux_eq prems zs z t' t1 t2
  12.251 @@ -519,8 +476,6 @@
  12.252        | @{const Trueprop} $ (Const (@{const_name "op ="}, _) $ t' $ Var z) =>
  12.253          aux_eq prems zs z t' t1 t2
  12.254        | _ => aux (t1 :: prems) (Term.add_vars t1 zs) t2
  12.255 -    (* term list -> (indexname * typ) list -> indexname * typ -> term -> term
  12.256 -       -> term -> term *)
  12.257      and aux_eq prems zs z t' t1 t2 =
  12.258        if not (member (op =) zs z) andalso
  12.259           not (exists_subterm (curry (op =) (Var z)) t') then
  12.260 @@ -529,15 +484,11 @@
  12.261          aux (t1 :: prems) (Term.add_vars t1 zs) t2
  12.262    in aux [] [] end
  12.263  
  12.264 -(* theory -> (typ option * bool) list -> int -> term list -> term list
  12.265 -   -> (term * term list) option *)
  12.266  fun find_bound_assign thy stds j =
  12.267    let
  12.268 -    (* term list -> term list -> (term * term list) option *)
  12.269      fun do_term _ [] = NONE
  12.270        | do_term seen (t :: ts) =
  12.271          let
  12.272 -          (* bool -> term -> term -> (term * term list) option *)
  12.273            fun do_eq pass1 t1 t2 =
  12.274              (if loose_bvar1 (t2, j) then
  12.275                 if pass1 then do_eq false t2 t1 else raise SAME ()
  12.276 @@ -559,10 +510,8 @@
  12.277          end
  12.278    in do_term end
  12.279  
  12.280 -(* int -> term -> term -> term *)
  12.281  fun subst_one_bound j arg t =
  12.282    let
  12.283 -    (* term * int -> term *)
  12.284      fun aux (Bound i, lev) =
  12.285          if i < lev then raise SAME ()
  12.286          else if i = lev then incr_boundvars (lev - j) arg
  12.287 @@ -574,10 +523,8 @@
  12.288        | aux _ = raise SAME ()
  12.289    in aux (t, j) handle SAME () => t end
  12.290  
  12.291 -(* hol_context -> term -> term *)
  12.292  fun destroy_existential_equalities ({thy, stds, ...} : hol_context) =
  12.293    let
  12.294 -    (* string list -> typ list -> term list -> term *)
  12.295      fun kill [] [] ts = foldr1 s_conj ts
  12.296        | kill (s :: ss) (T :: Ts) ts =
  12.297          (case find_bound_assign thy stds (length ss) [] ts of
  12.298 @@ -589,7 +536,6 @@
  12.299             Const (@{const_name Ex}, (T --> bool_T) --> bool_T)
  12.300             $ Abs (s, T, kill ss Ts ts))
  12.301        | kill _ _ _ = raise UnequalLengths
  12.302 -    (* string list -> typ list -> term -> term *)
  12.303      fun gather ss Ts (Const (@{const_name Ex}, _) $ Abs (s1, T1, t1)) =
  12.304          gather (ss @ [s1]) (Ts @ [T1]) t1
  12.305        | gather [] [] (Abs (s, T, t1)) = Abs (s, T, gather [] [] t1)
  12.306 @@ -600,20 +546,15 @@
  12.307  
  12.308  (** Skolemization **)
  12.309  
  12.310 -(* int -> int -> string *)
  12.311  fun skolem_prefix_for k j =
  12.312    skolem_prefix ^ string_of_int k ^ "@" ^ string_of_int j ^ name_sep
  12.313  
  12.314 -(* hol_context -> int -> term -> term *)
  12.315  fun skolemize_term_and_more (hol_ctxt as {thy, def_table, skolems, ...})
  12.316                              skolem_depth =
  12.317    let
  12.318 -    (* int list -> int list *)
  12.319      val incrs = map (Integer.add 1)
  12.320 -    (* string list -> typ list -> int list -> int -> polarity -> term -> term *)
  12.321      fun aux ss Ts js depth polar t =
  12.322        let
  12.323 -        (* string -> typ -> string -> typ -> term -> term *)
  12.324          fun do_quantifier quant_s quant_T abs_s abs_T t =
  12.325            if not (loose_bvar1 (t, 0)) then
  12.326              aux ss Ts js depth polar (incr_boundvars ~1 t)
  12.327 @@ -679,7 +620,6 @@
  12.328                  else
  12.329                    (ubfp_prefix, @{const "op &"},
  12.330                     @{const_name semilattice_inf_class.inf})
  12.331 -              (* unit -> term *)
  12.332                fun pos () = unrolled_inductive_pred_const hol_ctxt gfp x
  12.333                             |> aux ss Ts js depth polar
  12.334                fun neg () = Const (pref ^ s, T)
  12.335 @@ -693,7 +633,6 @@
  12.336                       val ((trunk_arg_Ts, rump_arg_T), body_T) =
  12.337                         T |> strip_type |>> split_last
  12.338                       val set_T = rump_arg_T --> body_T
  12.339 -                     (* (unit -> term) -> term *)
  12.340                       fun app f =
  12.341                         list_comb (f (),
  12.342                                    map Bound (length trunk_arg_Ts - 1 downto 0))
  12.343 @@ -717,21 +656,18 @@
  12.344  
  12.345  (** Function specialization **)
  12.346  
  12.347 -(* term -> term list *)
  12.348  fun params_in_equation (@{const "==>"} $ _ $ t2) = params_in_equation t2
  12.349    | params_in_equation (@{const Trueprop} $ t1) = params_in_equation t1
  12.350    | params_in_equation (Const (@{const_name "op ="}, _) $ t1 $ _) =
  12.351      snd (strip_comb t1)
  12.352    | params_in_equation _ = []
  12.353  
  12.354 -(* styp -> styp -> int list -> term list -> term list -> term -> term *)
  12.355  fun specialize_fun_axiom x x' fixed_js fixed_args extra_args t =
  12.356    let
  12.357      val k = fold Integer.max (map maxidx_of_term (fixed_args @ extra_args)) 0
  12.358              + 1
  12.359      val t = map_aterms (fn Var ((s, i), T) => Var ((s, k + i), T) | t' => t') t
  12.360      val fixed_params = filter_indices fixed_js (params_in_equation t)
  12.361 -    (* term list -> term -> term *)
  12.362      fun aux args (Abs (s, T, t)) = list_comb (Abs (s, T, aux [] t), args)
  12.363        | aux args (t1 $ t2) = aux (aux [] t2 :: args) t1
  12.364        | aux args t =
  12.365 @@ -743,10 +679,8 @@
  12.366            end
  12.367    in aux [] t end
  12.368  
  12.369 -(* hol_context -> styp -> (int * term option) list *)
  12.370  fun static_args_in_term ({ersatz_table, ...} : hol_context) x t =
  12.371    let
  12.372 -    (* term -> term list -> term list -> term list list *)
  12.373      fun fun_calls (Abs (_, _, t)) _ = fun_calls t []
  12.374        | fun_calls (t1 $ t2) args = fun_calls t2 [] #> fun_calls t1 (t2 :: args)
  12.375        | fun_calls t args =
  12.376 @@ -756,7 +690,6 @@
  12.377                              SOME s'' => x = (s'', T')
  12.378                            | NONE => false)
  12.379           | _ => false) ? cons args
  12.380 -    (* term list list -> term list list -> term list -> term list list *)
  12.381      fun call_sets [] [] vs = [vs]
  12.382        | call_sets [] uss vs = vs :: call_sets uss [] []
  12.383        | call_sets ([] :: _) _ _ = []
  12.384 @@ -773,12 +706,10 @@
  12.385                   | [t as Free _] => cons (j, SOME t)
  12.386                   | _ => I) indexed_sets []
  12.387    end
  12.388 -(* hol_context -> styp -> term list -> (int * term option) list *)
  12.389  fun static_args_in_terms hol_ctxt x =
  12.390    map (static_args_in_term hol_ctxt x)
  12.391    #> fold1 (OrdList.inter (prod_ord int_ord (option_ord Term_Ord.term_ord)))
  12.392  
  12.393 -(* (int * term option) list -> (int * term) list -> int list *)
  12.394  fun overlapping_indices [] _ = []
  12.395    | overlapping_indices _ [] = []
  12.396    | overlapping_indices (ps1 as (j1, t1) :: ps1') (ps2 as (j2, t2) :: ps2') =
  12.397 @@ -786,7 +717,6 @@
  12.398      else if j1 > j2 then overlapping_indices ps1 ps2'
  12.399      else overlapping_indices ps1' ps2' |> the_default t2 t1 = t2 ? cons j1
  12.400  
  12.401 -(* typ list -> term -> bool *)
  12.402  fun is_eligible_arg Ts t =
  12.403    let val bad_Ts = map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t) in
  12.404      null bad_Ts orelse
  12.405 @@ -794,7 +724,6 @@
  12.406       forall (not o is_higher_order_type) bad_Ts)
  12.407    end
  12.408  
  12.409 -(* int -> string *)
  12.410  fun special_prefix_for j = special_prefix ^ string_of_int j ^ name_sep
  12.411  
  12.412  (* If a constant's definition is picked up deeper than this threshold, we
  12.413 @@ -803,7 +732,6 @@
  12.414  
  12.415  val bound_var_prefix = "b"
  12.416  
  12.417 -(* hol_context -> int -> term -> term *)
  12.418  fun specialize_consts_in_term (hol_ctxt as {specialize, simp_table,
  12.419                                              special_funs, ...}) depth t =
  12.420    if not specialize orelse depth > special_max_depth then
  12.421 @@ -812,7 +740,6 @@
  12.422      let
  12.423        val blacklist = if depth = 0 then []
  12.424                        else case term_under_def t of Const x => [x] | _ => []
  12.425 -      (* term list -> typ list -> term -> term *)
  12.426        fun aux args Ts (Const (x as (s, T))) =
  12.427            ((if not (member (op =) blacklist x) andalso not (null args) andalso
  12.428                 not (String.isPrefix special_prefix s) andalso
  12.429 @@ -836,7 +763,6 @@
  12.430                  val extra_args = map Var vars @ map Bound bound_js @ live_args
  12.431                  val extra_Ts = map snd vars @ filter_indices bound_js Ts
  12.432                  val k = maxidx_of_term t + 1
  12.433 -                (* int -> term *)
  12.434                  fun var_for_bound_no j =
  12.435                    Var ((bound_var_prefix ^
  12.436                          nat_subscript (find_index (curry (op =) j) bound_js
  12.437 @@ -880,7 +806,6 @@
  12.438  
  12.439  val cong_var_prefix = "c"
  12.440  
  12.441 -(* typ -> special_triple -> special_triple -> term *)
  12.442  fun special_congruence_axiom T (js1, ts1, x1) (js2, ts2, x2) =
  12.443    let
  12.444      val (bounds1, bounds2) = pairself (map Var o special_bounds) (ts1, ts2)
  12.445 @@ -905,7 +830,6 @@
  12.446      |> close_form (* TODO: needed? *)
  12.447    end
  12.448  
  12.449 -(* hol_context -> styp list -> term list *)
  12.450  fun special_congruence_axioms (hol_ctxt as {special_funs, ...}) xs =
  12.451    let
  12.452      val groups =
  12.453 @@ -914,14 +838,10 @@
  12.454        |> AList.group (op =)
  12.455        |> filter_out (is_equational_fun_surely_complete hol_ctxt o fst)
  12.456        |> map (fn (x, zs) => (x, zs |> member (op =) xs x ? cons ([], [], x)))
  12.457 -    (* special_triple -> int *)
  12.458      fun generality (js, _, _) = ~(length js)
  12.459 -    (* special_triple -> special_triple -> bool *)
  12.460      fun is_more_specific (j1, t1, x1) (j2, t2, x2) =
  12.461        x1 <> x2 andalso OrdList.subset (prod_ord int_ord Term_Ord.term_ord)
  12.462                                        (j2 ~~ t2, j1 ~~ t1)
  12.463 -    (* typ -> special_triple list -> special_triple list -> special_triple list
  12.464 -       -> term list -> term list *)
  12.465      fun do_pass_1 _ [] [_] [_] = I
  12.466        | do_pass_1 T skipped _ [] = do_pass_2 T skipped
  12.467        | do_pass_1 T skipped all (z :: zs) =
  12.468 @@ -930,7 +850,6 @@
  12.469            [] => do_pass_1 T (z :: skipped) all zs
  12.470          | (z' :: _) => cons (special_congruence_axiom T z z')
  12.471                         #> do_pass_1 T skipped all zs
  12.472 -    (* typ -> special_triple list -> term list -> term list *)
  12.473      and do_pass_2 _ [] = I
  12.474        | do_pass_2 T (z :: zs) =
  12.475          fold (cons o special_congruence_axiom T z) zs #> do_pass_2 T zs
  12.476 @@ -938,32 +857,23 @@
  12.477  
  12.478  (** Axiom selection **)
  12.479  
  12.480 -(* 'a Symtab.table -> 'a list *)
  12.481  fun all_table_entries table = Symtab.fold (append o snd) table []
  12.482 -(* const_table -> string -> const_table *)
  12.483  fun extra_table table s = Symtab.make [(s, all_table_entries table)]
  12.484  
  12.485 -(* int -> term -> term *)
  12.486  fun eval_axiom_for_term j t =
  12.487    Logic.mk_equals (Const (eval_prefix ^ string_of_int j, fastype_of t), t)
  12.488  
  12.489 -(* term -> bool *)
  12.490  val is_trivial_equation = the_default false o try (op aconv o Logic.dest_equals)
  12.491  
  12.492  (* Prevents divergence in case of cyclic or infinite axiom dependencies. *)
  12.493  val axioms_max_depth = 255
  12.494  
  12.495 -(* hol_context -> term -> term list * term list * bool * bool *)
  12.496  fun axioms_for_term
  12.497          (hol_ctxt as {thy, ctxt, max_bisim_depth, stds, user_axioms,
  12.498                        fast_descrs, evals, def_table, nondef_table,
  12.499                        choice_spec_table, user_nondefs, ...}) t =
  12.500    let
  12.501      type accumulator = styp list * (term list * term list)
  12.502 -    (* (term list * term list -> term list)
  12.503 -       -> ((term list -> term list) -> term list * term list
  12.504 -           -> term list * term list)
  12.505 -       -> int -> term -> accumulator -> accumulator *)
  12.506      fun add_axiom get app depth t (accum as (xs, axs)) =
  12.507        let
  12.508          val t = t |> unfold_defs_in_term hol_ctxt
  12.509 @@ -977,7 +887,6 @@
  12.510              else add_axioms_for_term (depth + 1) t' (xs, app (cons t') axs)
  12.511            end
  12.512        end
  12.513 -    (* int -> term -> accumulator -> accumulator *)
  12.514      and add_def_axiom depth = add_axiom fst apfst depth
  12.515      and add_nondef_axiom depth = add_axiom snd apsnd depth
  12.516      and add_maybe_def_axiom depth t =
  12.517 @@ -986,7 +895,6 @@
  12.518      and add_eq_axiom depth t =
  12.519        (if is_constr_pattern_formula thy t then add_def_axiom
  12.520         else add_nondef_axiom) depth t
  12.521 -    (* int -> term -> accumulator -> accumulator *)
  12.522      and add_axioms_for_term depth t (accum as (xs, axs)) =
  12.523        case t of
  12.524          t1 $ t2 => accum |> fold (add_axioms_for_term depth) [t1, t2]
  12.525 @@ -1058,7 +966,6 @@
  12.526        | Bound _ => accum
  12.527        | Abs (_, T, t) => accum |> add_axioms_for_term depth t
  12.528                                 |> add_axioms_for_type depth T
  12.529 -    (* int -> typ -> accumulator -> accumulator *)
  12.530      and add_axioms_for_type depth T =
  12.531        case T of
  12.532          Type (@{type_name fun}, Ts) => fold (add_axioms_for_type depth) Ts
  12.533 @@ -1080,7 +987,6 @@
  12.534                     (codatatype_bisim_axioms hol_ctxt T)
  12.535              else
  12.536                I)
  12.537 -    (* int -> typ -> sort -> accumulator -> accumulator *)
  12.538      and add_axioms_for_sort depth T S =
  12.539        let
  12.540          val supers = Sign.complete_sort thy S
  12.541 @@ -1112,15 +1018,12 @@
  12.542  
  12.543  (** Simplification of constructor/selector terms **)
  12.544  
  12.545 -(* theory -> term -> term *)
  12.546  fun simplify_constrs_and_sels thy t =
  12.547    let
  12.548 -    (* term -> int -> term *)
  12.549      fun is_nth_sel_on t' n (Const (s, _) $ t) =
  12.550          (t = t' andalso is_sel_like_and_no_discr s andalso
  12.551           sel_no_from_name s = n)
  12.552        | is_nth_sel_on _ _ _ = false
  12.553 -    (* term -> term list -> term *)
  12.554      fun do_term (Const (@{const_name Rep_Frac}, _)
  12.555                   $ (Const (@{const_name Abs_Frac}, _) $ t1)) [] = do_term t1 []
  12.556        | do_term (Const (@{const_name Abs_Frac}, _)
  12.557 @@ -1160,7 +1063,6 @@
  12.558  
  12.559  (** Quantifier massaging: Distributing quantifiers **)
  12.560  
  12.561 -(* term -> term *)
  12.562  fun distribute_quantifiers t =
  12.563    case t of
  12.564      (t0 as Const (@{const_name All}, T0)) $ Abs (s, T1, t1) =>
  12.565 @@ -1199,7 +1101,6 @@
  12.566  
  12.567  (** Quantifier massaging: Pushing quantifiers inward **)
  12.568  
  12.569 -(* int -> int -> (int -> int) -> term -> term *)
  12.570  fun renumber_bounds j n f t =
  12.571    case t of
  12.572      t1 $ t2 => renumber_bounds j n f t1 $ renumber_bounds j n f t2
  12.573 @@ -1214,10 +1115,8 @@
  12.574     paper). *)
  12.575  val quantifier_cluster_threshold = 7
  12.576  
  12.577 -(* term -> term *)
  12.578  val push_quantifiers_inward =
  12.579    let
  12.580 -    (* string -> string list -> typ list -> term -> term *)
  12.581      fun aux quant_s ss Ts t =
  12.582        (case t of
  12.583           Const (s0, _) $ Abs (s1, T1, t1 as _ $ _) =>
  12.584 @@ -1237,7 +1136,6 @@
  12.585                 else
  12.586                   let
  12.587                     val typical_card = 4
  12.588 -                   (* ('a -> ''b list) -> 'a list -> ''b list *)
  12.589                     fun big_union proj ps =
  12.590                       fold (fold (insert (op =)) o proj) ps []
  12.591                     val (ts, connective) = strip_any_connective t
  12.592 @@ -1245,11 +1143,8 @@
  12.593                       map (bounded_card_of_type 65536 typical_card []) Ts
  12.594                     val t_costs = map size_of_term ts
  12.595                     val num_Ts = length Ts
  12.596 -                   (* int -> int *)
  12.597                     val flip = curry (op -) (num_Ts - 1)
  12.598                     val t_boundss = map (map flip o loose_bnos) ts
  12.599 -                   (* (int list * int) list -> int list
  12.600 -                      -> (int list * int) list *)
  12.601                     fun merge costly_boundss [] = costly_boundss
  12.602                       | merge costly_boundss (j :: js) =
  12.603                         let
  12.604 @@ -1261,9 +1156,7 @@
  12.605                           val yeas_cost = Integer.sum (map snd yeas)
  12.606                                           * nth T_costs j
  12.607                         in merge ((yeas_bounds, yeas_cost) :: nays) js end
  12.608 -                   (* (int list * int) list -> int list -> int *)
  12.609                     val cost = Integer.sum o map snd oo merge
  12.610 -                   (* (int list * int) list -> int list -> int list *)
  12.611                     fun heuristically_best_permutation _ [] = []
  12.612                       | heuristically_best_permutation costly_boundss js =
  12.613                         let
  12.614 @@ -1287,14 +1180,12 @@
  12.615                                       (index_seq 0 num_Ts)
  12.616                     val ts = map (renumber_bounds 0 num_Ts (nth back_js o flip))
  12.617                                  ts
  12.618 -                   (* (term * int list) list -> term *)
  12.619                     fun mk_connection [] =
  12.620                         raise ARG ("Nitpick_Preproc.push_quantifiers_inward.aux.\
  12.621                                    \mk_connection", "")
  12.622                       | mk_connection ts_cum_bounds =
  12.623                         ts_cum_bounds |> map fst
  12.624                         |> foldr1 (fn (t1, t2) => connective $ t1 $ t2)
  12.625 -                   (* (term * int list) list -> int list -> term *)
  12.626                     fun build ts_cum_bounds [] = ts_cum_bounds |> mk_connection
  12.627                       | build ts_cum_bounds (j :: js) =
  12.628                         let
  12.629 @@ -1321,9 +1212,6 @@
  12.630  
  12.631  (** Inference of finite functions **)
  12.632  
  12.633 -(* hol_context -> bool -> (typ option * bool option) list
  12.634 -   -> (typ option * bool option) list -> term list * term list
  12.635 -   -> term list * term list *)
  12.636  fun finitize_all_types_of_funs (hol_ctxt as {thy, ...}) binarize finitizes monos
  12.637                                 (nondef_ts, def_ts) =
  12.638    let
  12.639 @@ -1338,9 +1226,6 @@
  12.640  
  12.641  (** Preprocessor entry point **)
  12.642  
  12.643 -(* hol_context -> (typ option * bool option) list
  12.644 -   -> (typ option * bool option) list -> term
  12.645 -   -> term list * term list * bool * bool * bool *)
  12.646  fun preprocess_term (hol_ctxt as {thy, stds, binary_ints, destroy_constrs,
  12.647                                    boxes, skolemize, uncurry, ...})
  12.648                      finitizes monos t =
  12.649 @@ -1365,7 +1250,6 @@
  12.650      val table =
  12.651        Termtab.empty
  12.652        |> uncurry ? fold (add_to_uncurry_table thy) (nondef_ts @ def_ts)
  12.653 -    (* bool -> term -> term *)
  12.654      fun do_rest def =
  12.655        binarize ? binarize_nat_and_int_in_term
  12.656        #> uncurry ? uncurry_term table
    13.1 --- a/src/HOL/Tools/Nitpick/nitpick_rep.ML	Sat Apr 24 16:17:30 2010 +0200
    13.2 +++ b/src/HOL/Tools/Nitpick/nitpick_rep.ML	Sat Apr 24 16:33:01 2010 +0200
    13.3 @@ -77,18 +77,15 @@
    13.4  
    13.5  exception REP of string * rep list
    13.6  
    13.7 -(* polarity -> string *)
    13.8  fun string_for_polarity Pos = "+"
    13.9    | string_for_polarity Neg = "-"
   13.10    | string_for_polarity Neut = "="
   13.11  
   13.12 -(* rep -> string *)
   13.13  fun atomic_string_for_rep rep =
   13.14    let val s = string_for_rep rep in
   13.15      if String.isPrefix "[" s orelse not (is_substring_of " " s) then s
   13.16      else "(" ^ s ^ ")"
   13.17    end
   13.18 -(* rep -> string *)
   13.19  and string_for_rep Any = "X"
   13.20    | string_for_rep (Formula polar) = "F" ^ string_for_polarity polar
   13.21    | string_for_rep Unit = "U"
   13.22 @@ -101,7 +98,6 @@
   13.23      atomic_string_for_rep R1 ^ " => " ^ string_for_rep R2
   13.24    | string_for_rep (Opt R) = atomic_string_for_rep R ^ "?"
   13.25  
   13.26 -(* rep -> bool *)
   13.27  fun is_Func (Func _) = true
   13.28    | is_Func _ = false
   13.29  fun is_Opt (Opt _) = true
   13.30 @@ -110,7 +106,6 @@
   13.31    | is_opt_rep (Opt _) = true
   13.32    | is_opt_rep _ = false
   13.33  
   13.34 -(* rep -> int *)
   13.35  fun card_of_rep Any = raise REP ("Nitpick_Rep.card_of_rep", [Any])
   13.36    | card_of_rep (Formula _) = 2
   13.37    | card_of_rep Unit = 1
   13.38 @@ -140,7 +135,6 @@
   13.39      Int.max (min_univ_card_of_rep R1, min_univ_card_of_rep R2)
   13.40    | min_univ_card_of_rep (Opt R) = min_univ_card_of_rep R
   13.41  
   13.42 -(* rep -> bool *)
   13.43  fun is_one_rep Unit = true
   13.44    | is_one_rep (Atom _) = true
   13.45    | is_one_rep (Struct _) = true
   13.46 @@ -149,10 +143,8 @@
   13.47  fun is_lone_rep (Opt R) = is_one_rep R
   13.48    | is_lone_rep R = is_one_rep R
   13.49  
   13.50 -(* rep -> rep * rep *)
   13.51  fun dest_Func (Func z) = z
   13.52    | dest_Func R = raise REP ("Nitpick_Rep.dest_Func", [R])
   13.53 -(* int Typtab.table -> typ -> (unit -> int) -> rep -> rep *)
   13.54  fun lazy_range_rep _ _ _ Unit = Unit
   13.55    | lazy_range_rep _ _ _ (Vect (_, R)) = R
   13.56    | lazy_range_rep _ _ _ (Func (_, R2)) = R2
   13.57 @@ -164,19 +156,15 @@
   13.58      Atom (ran_card (), offset_of_type ofs T2)
   13.59    | lazy_range_rep _ _ _ R = raise REP ("Nitpick_Rep.lazy_range_rep", [R])
   13.60  
   13.61 -(* rep -> rep list *)
   13.62  fun binder_reps (Func (R1, R2)) = R1 :: binder_reps R2
   13.63    | binder_reps _ = []
   13.64 -(* rep -> rep *)
   13.65  fun body_rep (Func (_, R2)) = body_rep R2
   13.66    | body_rep R = R
   13.67  
   13.68 -(* rep -> rep *)
   13.69  fun flip_rep_polarity (Formula polar) = Formula (flip_polarity polar)
   13.70    | flip_rep_polarity (Func (R1, R2)) = Func (R1, flip_rep_polarity R2)
   13.71    | flip_rep_polarity R = R
   13.72  
   13.73 -(* int Typtab.table -> rep -> rep *)
   13.74  fun one_rep _ _ Any = raise REP ("Nitpick_Rep.one_rep", [Any])
   13.75    | one_rep _ _ (Atom x) = Atom x
   13.76    | one_rep _ _ (Struct Rs) = Struct Rs
   13.77 @@ -189,12 +177,10 @@
   13.78  fun opt_rep ofs (Type (@{type_name fun}, [_, T2])) (Func (R1, R2)) =
   13.79      Func (R1, opt_rep ofs T2 R2)
   13.80    | opt_rep ofs T R = Opt (optable_rep ofs T R)
   13.81 -(* rep -> rep *)
   13.82  fun unopt_rep (Func (R1, R2)) = Func (R1, unopt_rep R2)
   13.83    | unopt_rep (Opt R) = R
   13.84    | unopt_rep R = R
   13.85  
   13.86 -(* polarity -> polarity -> polarity *)
   13.87  fun min_polarity polar1 polar2 =
   13.88    if polar1 = polar2 then
   13.89      polar1
   13.90 @@ -208,7 +194,6 @@
   13.91  
   13.92  (* It's important that Func is before Vect, because if the range is Opt we
   13.93     could lose information by converting a Func to a Vect. *)
   13.94 -(* rep -> rep -> rep *)
   13.95  fun min_rep (Opt R1) (Opt R2) = Opt (min_rep R1 R2)
   13.96    | min_rep (Opt R) _ = Opt R
   13.97    | min_rep _ (Opt R) = Opt R
   13.98 @@ -237,7 +222,6 @@
   13.99      else if k1 > k2 then Vect (k2, R2)
  13.100      else Vect (k1, min_rep R1 R2)
  13.101    | min_rep R1 R2 = raise REP ("Nitpick_Rep.min_rep", [R1, R2])
  13.102 -(* rep list -> rep list -> rep list *)
  13.103  and min_reps [] _ = []
  13.104    | min_reps _ [] = []
  13.105    | min_reps (R1 :: Rs1) (R2 :: Rs2) =
  13.106 @@ -245,7 +229,6 @@
  13.107      else if min_rep R1 R2 = R1 then R1 :: Rs1
  13.108      else R2 :: Rs2
  13.109  
  13.110 -(* int -> rep -> int *)
  13.111  fun card_of_domain_from_rep ran_card R =
  13.112    case R of
  13.113      Unit => 1
  13.114 @@ -255,14 +238,12 @@
  13.115    | Opt R => card_of_domain_from_rep ran_card R
  13.116    | _ => raise REP ("Nitpick_Rep.card_of_domain_from_rep", [R])
  13.117  
  13.118 -(* int Typtab.table -> typ -> rep -> rep *)
  13.119  fun rep_to_binary_rel_rep ofs T R =
  13.120    let
  13.121      val k = exact_root 2 (card_of_domain_from_rep 2 R)
  13.122      val j0 = offset_of_type ofs (fst (HOLogic.dest_prodT (domain_type T)))
  13.123    in Func (Struct [Atom (k, j0), Atom (k, j0)], Formula Neut) end
  13.124  
  13.125 -(* scope -> typ -> rep *)
  13.126  fun best_one_rep_for_type (scope as {card_assigns, ...} : scope)
  13.127                            (Type (@{type_name fun}, [T1, T2])) =
  13.128      (case best_one_rep_for_type scope T2 of
  13.129 @@ -283,7 +264,6 @@
  13.130  
  13.131  (* Datatypes are never represented by Unit, because it would confuse
  13.132     "nfa_transitions_for_ctor". *)
  13.133 -(* scope -> typ -> rep *)
  13.134  fun best_opt_set_rep_for_type scope (Type (@{type_name fun}, [T1, T2])) =
  13.135      Func (best_one_rep_for_type scope T1, best_opt_set_rep_for_type scope T2)
  13.136    | best_opt_set_rep_for_type (scope as {ofs, ...}) T =
  13.137 @@ -308,7 +288,6 @@
  13.138    | best_non_opt_symmetric_reps_for_fun_type _ T =
  13.139      raise TYPE ("Nitpick_Rep.best_non_opt_symmetric_reps_for_fun_type", [T], [])
  13.140  
  13.141 -(* rep -> (int * int) list *)
  13.142  fun atom_schema_of_rep Any = raise REP ("Nitpick_Rep.atom_schema_of_rep", [Any])
  13.143    | atom_schema_of_rep (Formula _) = []
  13.144    | atom_schema_of_rep Unit = []
  13.145 @@ -318,10 +297,8 @@
  13.146    | atom_schema_of_rep (Func (R1, R2)) =
  13.147      atom_schema_of_rep R1 @ atom_schema_of_rep R2
  13.148    | atom_schema_of_rep (Opt R) = atom_schema_of_rep R
  13.149 -(* rep list -> (int * int) list *)
  13.150  and atom_schema_of_reps Rs = maps atom_schema_of_rep Rs
  13.151  
  13.152 -(* typ -> rep -> typ list *)
  13.153  fun type_schema_of_rep _ (Formula _) = []
  13.154    | type_schema_of_rep _ Unit = []
  13.155    | type_schema_of_rep T (Atom _) = [T]
  13.156 @@ -333,12 +310,9 @@
  13.157      type_schema_of_rep T1 R1 @ type_schema_of_rep T2 R2
  13.158    | type_schema_of_rep T (Opt R) = type_schema_of_rep T R
  13.159    | type_schema_of_rep _ R = raise REP ("Nitpick_Rep.type_schema_of_rep", [R])
  13.160 -(* typ list -> rep list -> typ list *)
  13.161  and type_schema_of_reps Ts Rs = flat (map2 type_schema_of_rep Ts Rs)
  13.162  
  13.163 -(* rep -> int list list *)
  13.164  val all_combinations_for_rep = all_combinations o atom_schema_of_rep
  13.165 -(* rep list -> int list list *)
  13.166  val all_combinations_for_reps = all_combinations o atom_schema_of_reps
  13.167  
  13.168  end;
    14.1 --- a/src/HOL/Tools/Nitpick/nitpick_scope.ML	Sat Apr 24 16:17:30 2010 +0200
    14.2 +++ b/src/HOL/Tools/Nitpick/nitpick_scope.ML	Sat Apr 24 16:33:01 2010 +0200
    14.3 @@ -93,11 +93,9 @@
    14.4  type row = row_kind * int list
    14.5  type block = row list
    14.6  
    14.7 -(* dtype_spec list -> typ -> dtype_spec option *)
    14.8  fun datatype_spec (dtypes : dtype_spec list) T =
    14.9    List.find (curry (op =) T o #typ) dtypes
   14.10  
   14.11 -(* dtype_spec list -> styp -> constr_spec *)
   14.12  fun constr_spec [] x = raise TERM ("Nitpick_Scope.constr_spec", [Const x])
   14.13    | constr_spec ({constrs, ...} :: dtypes : dtype_spec list) (x as (s, T)) =
   14.14      case List.find (curry (op =) (s, body_type T) o (apsnd body_type o #const))
   14.15 @@ -105,7 +103,6 @@
   14.16        SOME c => c
   14.17      | NONE => constr_spec dtypes x
   14.18  
   14.19 -(* dtype_spec list -> bool -> typ -> bool *)
   14.20  fun is_complete_type dtypes facto (Type (@{type_name fun}, [T1, T2])) =
   14.21      is_concrete_type dtypes facto T1 andalso is_complete_type dtypes facto T2
   14.22    | is_complete_type dtypes facto (Type (@{type_name fin_fun}, [T1, T2])) =
   14.23 @@ -128,19 +125,15 @@
   14.24  and is_exact_type dtypes facto =
   14.25    is_complete_type dtypes facto andf is_concrete_type dtypes facto
   14.26  
   14.27 -(* int Typtab.table -> typ -> int *)
   14.28  fun offset_of_type ofs T =
   14.29    case Typtab.lookup ofs T of
   14.30      SOME j0 => j0
   14.31    | NONE => Typtab.lookup ofs dummyT |> the_default 0
   14.32  
   14.33 -(* scope -> typ -> int * int *)
   14.34  fun spec_of_type ({card_assigns, ofs, ...} : scope) T =
   14.35    (card_of_type card_assigns T
   14.36     handle TYPE ("Nitpick_HOL.card_of_type", _, _) => ~1, offset_of_type ofs T)
   14.37  
   14.38 -(* (string -> string) -> scope
   14.39 -   -> string list * string list * string list * string list * string list *)
   14.40  fun quintuple_for_scope quote
   14.41          ({hol_ctxt = {thy, ctxt, stds, ...}, card_assigns, bits, bisim_depth,
   14.42           datatypes, ...} : scope) =
   14.43 @@ -180,7 +173,6 @@
   14.44                     maxes (), iters (), miscs ())) ()
   14.45    end
   14.46  
   14.47 -(* scope -> bool -> Pretty.T list *)
   14.48  fun pretties_for_scope scope verbose =
   14.49    let
   14.50      val (primary_cards, secondary_cards, maxes, iters, bisim_depths) =
   14.51 @@ -198,7 +190,6 @@
   14.52      else serial_commas "and" ss |> map Pretty.str |> Pretty.breaks
   14.53    end
   14.54  
   14.55 -(* scope -> string *)
   14.56  fun multiline_string_for_scope scope =
   14.57    let
   14.58      val (primary_cards, secondary_cards, maxes, iters, bisim_depths) =
   14.59 @@ -213,47 +204,35 @@
   14.60      | lines => space_implode "\n" lines
   14.61    end
   14.62  
   14.63 -(* scope * scope -> bool *)
   14.64  fun scopes_equivalent (s1 : scope, s2 : scope) =
   14.65    #datatypes s1 = #datatypes s2 andalso #card_assigns s1 = #card_assigns s2
   14.66  fun scope_less_eq (s1 : scope) (s2 : scope) =
   14.67    (s1, s2) |> pairself (map snd o #card_assigns) |> op ~~ |> forall (op <=)
   14.68  
   14.69 -(* row -> int *)
   14.70  fun rank_of_row (_, ks) = length ks
   14.71 -(* block -> int *)
   14.72  fun rank_of_block block = fold Integer.max (map rank_of_row block) 1
   14.73 -(* int -> typ * int list -> typ * int list *)
   14.74  fun project_row column (y, ks) = (y, [nth ks (Int.min (column, length ks - 1))])
   14.75 -(* int -> block -> block *)
   14.76  fun project_block (column, block) = map (project_row column) block
   14.77  
   14.78 -(* (''a * ''a -> bool) -> (''a option * int list) list -> ''a -> int list *)
   14.79  fun lookup_ints_assign eq assigns key =
   14.80    case triple_lookup eq assigns key of
   14.81      SOME ks => ks
   14.82    | NONE => raise ARG ("Nitpick_Scope.lookup_ints_assign", "")
   14.83 -(* theory -> (typ option * int list) list -> typ -> int list *)
   14.84  fun lookup_type_ints_assign thy assigns T =
   14.85    map (Integer.max 1) (lookup_ints_assign (type_match thy) assigns T)
   14.86    handle ARG ("Nitpick_Scope.lookup_ints_assign", _) =>
   14.87           raise TYPE ("Nitpick_Scope.lookup_type_ints_assign", [T], [])
   14.88 -(* theory -> (styp option * int list) list -> styp -> int list *)
   14.89  fun lookup_const_ints_assign thy assigns x =
   14.90    lookup_ints_assign (const_match thy) assigns x
   14.91    handle ARG ("Nitpick_Scope.lookup_ints_assign", _) =>
   14.92           raise TERM ("Nitpick_Scope.lookup_const_ints_assign", [Const x])
   14.93  
   14.94 -(* theory -> (styp option * int list) list -> styp -> row option *)
   14.95  fun row_for_constr thy maxes_assigns constr =
   14.96    SOME (Max constr, lookup_const_ints_assign thy maxes_assigns constr)
   14.97    handle TERM ("lookup_const_ints_assign", _) => NONE
   14.98  
   14.99  val max_bits = 31 (* Kodkod limit *)
  14.100  
  14.101 -(* hol_context -> bool -> (typ option * int list) list
  14.102 -   -> (styp option * int list) list -> (styp option * int list) list -> int list
  14.103 -   -> int list -> typ -> block *)
  14.104  fun block_for_type (hol_ctxt as {thy, ...}) binarize cards_assigns maxes_assigns
  14.105                     iters_assigns bitss bisim_depths T =
  14.106    if T = @{typ unsigned_bit} then
  14.107 @@ -276,13 +255,9 @@
  14.108         [_] => []
  14.109       | constrs => map_filter (row_for_constr thy maxes_assigns) constrs)
  14.110  
  14.111 -(* hol_context -> bool -> (typ option * int list) list
  14.112 -   -> (styp option * int list) list -> (styp option * int list) list -> int list
  14.113 -   -> int list -> typ list -> typ list -> block list *)
  14.114  fun blocks_for_types hol_ctxt binarize cards_assigns maxes_assigns iters_assigns
  14.115                       bitss bisim_depths mono_Ts nonmono_Ts =
  14.116    let
  14.117 -    (* typ -> block *)
  14.118      val block_for = block_for_type hol_ctxt binarize cards_assigns maxes_assigns
  14.119                                     iters_assigns bitss bisim_depths
  14.120      val mono_block = maps block_for mono_Ts
  14.121 @@ -291,10 +266,8 @@
  14.122  
  14.123  val sync_threshold = 5
  14.124  
  14.125 -(* int list -> int list list *)
  14.126  fun all_combinations_ordered_smartly ks =
  14.127    let
  14.128 -    (* int list -> int *)
  14.129      fun cost_with_monos [] = 0
  14.130        | cost_with_monos (k :: ks) =
  14.131          if k < sync_threshold andalso forall (curry (op =) k) ks then
  14.132 @@ -315,16 +288,13 @@
  14.133         |> sort (int_ord o pairself fst) |> map snd
  14.134    end
  14.135  
  14.136 -(* typ -> bool *)
  14.137  fun is_self_recursive_constr_type T =
  14.138    exists (exists_subtype (curry (op =) (body_type T))) (binder_types T)
  14.139  
  14.140 -(* (styp * int) list -> styp -> int *)
  14.141  fun constr_max maxes x = the_default ~1 (AList.lookup (op =) maxes x)
  14.142  
  14.143  type scope_desc = (typ * int) list * (styp * int) list
  14.144  
  14.145 -(* hol_context -> bool -> scope_desc -> typ * int -> bool *)
  14.146  fun is_surely_inconsistent_card_assign hol_ctxt binarize
  14.147                                         (card_assigns, max_assigns) (T, k) =
  14.148    case binarized_and_boxed_datatype_constrs hol_ctxt binarize T of
  14.149 @@ -335,22 +305,17 @@
  14.150          map (Integer.prod o map (bounded_card_of_type k ~1 card_assigns)
  14.151               o binder_types o snd) xs
  14.152        val maxes = map (constr_max max_assigns) xs
  14.153 -      (* int -> int -> int *)
  14.154        fun effective_max card ~1 = card
  14.155          | effective_max card max = Int.min (card, max)
  14.156        val max = map2 effective_max dom_cards maxes |> Integer.sum
  14.157      in max < k end
  14.158 -(* hol_context -> bool -> (typ * int) list -> (typ * int) list
  14.159 -   -> (styp * int) list -> bool *)
  14.160  fun is_surely_inconsistent_scope_description hol_ctxt binarize seen rest
  14.161                                               max_assigns =
  14.162    exists (is_surely_inconsistent_card_assign hol_ctxt binarize
  14.163                                               (seen @ rest, max_assigns)) seen
  14.164  
  14.165 -(* hol_context -> bool -> scope_desc -> (typ * int) list option *)
  14.166  fun repair_card_assigns hol_ctxt binarize (card_assigns, max_assigns) =
  14.167    let
  14.168 -    (* (typ * int) list -> (typ * int) list -> (typ * int) list option *)
  14.169      fun aux seen [] = SOME seen
  14.170        | aux _ ((_, 0) :: _) = NONE
  14.171        | aux seen ((T, k) :: rest) =
  14.172 @@ -364,7 +329,6 @@
  14.173          handle SAME () => aux seen ((T, k - 1) :: rest)
  14.174    in aux [] (rev card_assigns) end
  14.175  
  14.176 -(* theory -> (typ * int) list -> typ * int -> typ * int *)
  14.177  fun repair_iterator_assign thy assigns (T as Type (_, Ts), k) =
  14.178      (T, if T = @{typ bisim_iterator} then
  14.179            let
  14.180 @@ -378,15 +342,12 @@
  14.181            k)
  14.182    | repair_iterator_assign _ _ assign = assign
  14.183  
  14.184 -(* row -> scope_desc -> scope_desc *)
  14.185  fun add_row_to_scope_descriptor (kind, ks) (card_assigns, max_assigns) =
  14.186    case kind of
  14.187      Card T => ((T, the_single ks) :: card_assigns, max_assigns)
  14.188    | Max x => (card_assigns, (x, the_single ks) :: max_assigns)
  14.189 -(* block -> scope_desc *)
  14.190  fun scope_descriptor_from_block block =
  14.191    fold_rev add_row_to_scope_descriptor block ([], [])
  14.192 -(* hol_context -> bool -> block list -> int list -> scope_desc option *)
  14.193  fun scope_descriptor_from_combination (hol_ctxt as {thy, ...}) binarize blocks
  14.194                                        columns =
  14.195    let
  14.196 @@ -400,11 +361,8 @@
  14.197    end
  14.198    handle Option.Option => NONE
  14.199  
  14.200 -(* (typ * int) list -> dtype_spec list -> int Typtab.table *)
  14.201  fun offset_table_for_card_assigns assigns dtypes =
  14.202    let
  14.203 -    (* int -> (int * int) list -> (typ * int) list -> int Typtab.table
  14.204 -       -> int Typtab.table *)
  14.205      fun aux next _ [] = Typtab.update_new (dummyT, next)
  14.206        | aux next reusable ((T, k) :: assigns) =
  14.207          if k = 1 orelse is_iterator_type T orelse is_integer_type T
  14.208 @@ -420,18 +378,14 @@
  14.209                      #> aux (next + k) ((k, next) :: reusable) assigns
  14.210    in aux 0 [] assigns Typtab.empty end
  14.211  
  14.212 -(* int -> (typ * int) list -> typ -> int *)
  14.213  fun domain_card max card_assigns =
  14.214    Integer.prod o map (bounded_card_of_type max max card_assigns) o binder_types
  14.215  
  14.216 -(* scope_desc -> bool -> int -> (int -> int) -> int -> int -> bool * styp
  14.217 -   -> constr_spec list -> constr_spec list *)
  14.218  fun add_constr_spec (card_assigns, max_assigns) co card sum_dom_cards
  14.219                      num_self_recs num_non_self_recs (self_rec, x as (_, T))
  14.220                      constrs =
  14.221    let
  14.222      val max = constr_max max_assigns x
  14.223 -    (* unit -> int *)
  14.224      fun next_delta () = if null constrs then 0 else #epsilon (hd constrs)
  14.225      val {delta, epsilon, exclusive, total} =
  14.226        if max = 0 then
  14.227 @@ -467,7 +421,6 @@
  14.228       explicit_max = max, total = total} :: constrs
  14.229    end
  14.230  
  14.231 -(* hol_context -> bool -> typ list -> (typ * int) list -> typ -> bool *)
  14.232  fun has_exact_card hol_ctxt facto finitizable_dataTs card_assigns T =
  14.233    let val card = card_of_type card_assigns T in
  14.234      card = bounded_exact_card_of_type hol_ctxt
  14.235 @@ -475,8 +428,6 @@
  14.236                 card_assigns T
  14.237    end
  14.238  
  14.239 -(* hol_context -> bool -> typ list -> typ list -> scope_desc -> typ * int
  14.240 -   -> dtype_spec *)
  14.241  fun datatype_spec_from_scope_descriptor (hol_ctxt as {thy, stds, ...}) binarize
  14.242          deep_dataTs finitizable_dataTs (desc as (card_assigns, _)) (T, card) =
  14.243    let
  14.244 @@ -487,7 +438,6 @@
  14.245      val self_recs = map (is_self_recursive_constr_type o snd) xs
  14.246      val (num_self_recs, num_non_self_recs) =
  14.247        List.partition I self_recs |> pairself length
  14.248 -    (* bool -> bool *)
  14.249      fun is_complete facto =
  14.250        has_exact_card hol_ctxt facto finitizable_dataTs card_assigns T
  14.251      fun is_concrete facto =
  14.252 @@ -497,7 +447,6 @@
  14.253                                     card_assigns)
  14.254      val complete = pair_from_fun is_complete
  14.255      val concrete = pair_from_fun is_concrete
  14.256 -    (* int -> int *)
  14.257      fun sum_dom_cards max =
  14.258        map (domain_card max card_assigns o snd) xs |> Integer.sum
  14.259      val constrs =
  14.260 @@ -509,7 +458,6 @@
  14.261       concrete = concrete, deep = deep, constrs = constrs}
  14.262    end
  14.263  
  14.264 -(* hol_context -> bool -> int -> typ list -> typ list -> scope_desc -> scope *)
  14.265  fun scope_from_descriptor (hol_ctxt as {thy, stds, ...}) binarize sym_break
  14.266                            deep_dataTs finitizable_dataTs
  14.267                            (desc as (card_assigns, _)) =
  14.268 @@ -530,8 +478,6 @@
  14.269             else offset_table_for_card_assigns card_assigns datatypes}
  14.270    end
  14.271  
  14.272 -(* theory -> typ list -> (typ option * int list) list
  14.273 -   -> (typ option * int list) list *)
  14.274  fun repair_cards_assigns_wrt_boxing_etc _ _ [] = []
  14.275    | repair_cards_assigns_wrt_boxing_etc thy Ts ((SOME T, ks) :: cards_assigns) =
  14.276      (if is_fun_type T orelse is_pair_type T then
  14.277 @@ -545,9 +491,6 @@
  14.278  val max_scopes = 4096
  14.279  val distinct_threshold = 512
  14.280  
  14.281 -(* hol_context -> bool -> int -> (typ option * int list) list
  14.282 -   -> (styp option * int list) list -> (styp option * int list) list -> int list
  14.283 -   -> typ list -> typ list -> typ list ->typ list -> int * scope list *)
  14.284  fun all_scopes (hol_ctxt as {thy, ...}) binarize sym_break cards_assigns
  14.285                 maxes_assigns iters_assigns bitss bisim_depths mono_Ts nonmono_Ts
  14.286                 deep_dataTs finitizable_dataTs =
    15.1 --- a/src/HOL/Tools/Nitpick/nitpick_tests.ML	Sat Apr 24 16:17:30 2010 +0200
    15.2 +++ b/src/HOL/Tools/Nitpick/nitpick_tests.ML	Sat Apr 24 16:33:01 2010 +0200
    15.3 @@ -292,7 +292,6 @@
    15.4  *)
    15.5    ]
    15.6  
    15.7 -(* Proof.context -> string * nut -> Kodkod.problem *)
    15.8  fun problem_for_nut ctxt (name, u) =
    15.9    let
   15.10      val debug = false
   15.11 @@ -319,7 +318,6 @@
   15.12       formula = formula}
   15.13    end
   15.14  
   15.15 -(* unit -> unit *)
   15.16  fun run_all_tests () =
   15.17    case Kodkod.solve_any_problem false NONE 0 1
   15.18                                  (map (problem_for_nut @{context}) tests) of
    16.1 --- a/src/HOL/Tools/Nitpick/nitpick_util.ML	Sat Apr 24 16:17:30 2010 +0200
    16.2 +++ b/src/HOL/Tools/Nitpick/nitpick_util.ML	Sat Apr 24 16:33:01 2010 +0200
    16.3 @@ -85,24 +85,18 @@
    16.4  
    16.5  val nitpick_prefix = "Nitpick."
    16.6  
    16.7 -(* ('a * 'b * 'c -> 'd) -> 'a -> 'b -> 'c -> 'd *)
    16.8  fun curry3 f = fn x => fn y => fn z => f (x, y, z)
    16.9  
   16.10  fun pairf f g x = (f x, g x)
   16.11  
   16.12 -(* (bool -> 'a) -> 'a * 'a *)
   16.13  fun pair_from_fun f = (f false, f true)
   16.14 -(* 'a * 'a -> bool -> 'a *)
   16.15  fun fun_from_pair (f, t) b = if b then t else f
   16.16  
   16.17 -(* bool -> int *)
   16.18  fun int_from_bool b = if b then 1 else 0
   16.19 -(* int -> int -> int *)
   16.20  fun nat_minus i j = if i > j then i - j else 0
   16.21  
   16.22  val max_exponent = 16384
   16.23  
   16.24 -(* int -> int -> int *)
   16.25  fun reasonable_power _ 0 = 1
   16.26    | reasonable_power a 1 = a
   16.27    | reasonable_power 0 _ = 0
   16.28 @@ -119,7 +113,6 @@
   16.29          c * c * reasonable_power a (b mod 2)
   16.30        end
   16.31  
   16.32 -(* int -> int -> int *)
   16.33  fun exact_log m n =
   16.34    let
   16.35      val r = Math.ln (Real.fromInt n) / Math.ln (Real.fromInt m) |> Real.round
   16.36 @@ -131,7 +124,6 @@
   16.37                   commas (map signed_string_of_int [m, n]))
   16.38    end
   16.39  
   16.40 -(* int -> int -> int *)
   16.41  fun exact_root m n =
   16.42    let val r = Math.pow (Real.fromInt n, 1.0 / (Real.fromInt m)) |> Real.round in
   16.43      if reasonable_power r m = n then
   16.44 @@ -141,22 +133,16 @@
   16.45                   commas (map signed_string_of_int [m, n]))
   16.46    end
   16.47  
   16.48 -(* ('a -> 'a -> 'a) -> 'a list -> 'a *)
   16.49  fun fold1 f = foldl1 (uncurry f)
   16.50  
   16.51 -(* int -> 'a list -> 'a list *)
   16.52  fun replicate_list 0 _ = []
   16.53    | replicate_list n xs = xs @ replicate_list (n - 1) xs
   16.54  
   16.55 -(* int list -> int list *)
   16.56  fun offset_list ns = rev (tl (fold (fn x => fn xs => (x + hd xs) :: xs) ns [0]))
   16.57 -(* int -> int -> int list *)
   16.58  fun index_seq j0 n = if j0 < 0 then j0 downto j0 - n + 1 else j0 upto j0 + n - 1
   16.59  
   16.60 -(* int list -> 'a list -> 'a list *)
   16.61  fun filter_indices js xs =
   16.62    let
   16.63 -    (* int -> int list -> 'a list -> 'a list *)
   16.64      fun aux _ [] _ = []
   16.65        | aux i (j :: js) (x :: xs) =
   16.66          if i = j then x :: aux (i + 1) js xs else aux (i + 1) (j :: js) xs
   16.67 @@ -165,7 +151,6 @@
   16.68    in aux 0 js xs end
   16.69  fun filter_out_indices js xs =
   16.70    let
   16.71 -    (* int -> int list -> 'a list -> 'a list *)
   16.72      fun aux _ [] xs = xs
   16.73        | aux i (j :: js) (x :: xs) =
   16.74          if i = j then aux (i + 1) js xs else x :: aux (i + 1) (j :: js) xs
   16.75 @@ -173,86 +158,66 @@
   16.76                                 "indices unordered or out of range")
   16.77    in aux 0 js xs end
   16.78  
   16.79 -(* 'a list -> 'a list list -> 'a list list *)
   16.80  fun cartesian_product [] _ = []
   16.81    | cartesian_product (x :: xs) yss =
   16.82      map (cons x) yss @ cartesian_product xs yss
   16.83 -(* 'a list list -> 'a list list *)
   16.84  fun n_fold_cartesian_product xss = fold_rev cartesian_product xss [[]]
   16.85 -(* ''a list -> (''a * ''a) list *)
   16.86  fun all_distinct_unordered_pairs_of [] = []
   16.87    | all_distinct_unordered_pairs_of (x :: xs) =
   16.88      map (pair x) xs @ all_distinct_unordered_pairs_of xs
   16.89  
   16.90 -(* (int * int) list -> int -> int list *)
   16.91  val nth_combination =
   16.92    let
   16.93 -    (* (int * int) list -> int -> int list * int *)
   16.94      fun aux [] n = ([], n)
   16.95        | aux ((k, j0) :: xs) n =
   16.96          let val (js, n) = aux xs n in ((n mod k) + j0 :: js, n div k) end
   16.97    in fst oo aux end
   16.98  
   16.99 -(* (int * int) list -> int list list *)
  16.100  val all_combinations = n_fold_cartesian_product o map (uncurry index_seq o swap)
  16.101  
  16.102 -(* 'a list -> 'a list list *)
  16.103  fun all_permutations [] = [[]]
  16.104    | all_permutations xs =
  16.105      maps (fn j => map (cons (nth xs j)) (all_permutations (nth_drop j xs)))
  16.106           (index_seq 0 (length xs))
  16.107  
  16.108 -(* int -> 'a list -> 'a list list *)
  16.109  fun batch_list _ [] = []
  16.110    | batch_list k xs =
  16.111      if length xs <= k then [xs]
  16.112      else List.take (xs, k) :: batch_list k (List.drop (xs, k))
  16.113  
  16.114 -(* int list -> 'a list -> 'a list list *)
  16.115  fun chunk_list_unevenly _ [] = []
  16.116    | chunk_list_unevenly [] ys = map single ys
  16.117    | chunk_list_unevenly (k :: ks) ys =
  16.118      let val (ys1, ys2) = chop k ys in ys1 :: chunk_list_unevenly ks ys2 end
  16.119  
  16.120 -(* ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list *)
  16.121  fun map3 _ [] [] [] = []
  16.122    | map3 f (x :: xs) (y :: ys) (z :: zs) = f x y z :: map3 f xs ys zs
  16.123    | map3 _ _ _ _ = raise UnequalLengths
  16.124  
  16.125 -(* ('a * 'a -> bool) -> ('a option * 'b) list -> 'a -> 'b option *)
  16.126  fun double_lookup eq ps key =
  16.127    case AList.lookup (fn (SOME x, SOME y) => eq (x, y) | _ => false) ps
  16.128                      (SOME key) of
  16.129      SOME z => SOME z
  16.130    | NONE => ps |> find_first (is_none o fst) |> Option.map snd
  16.131 -(* (''a * ''a -> bool) -> (''a option * 'b) list -> ''a -> 'b option *)
  16.132  fun triple_lookup _ [(NONE, z)] _ = SOME z
  16.133    | triple_lookup eq ps key =
  16.134      case AList.lookup (op =) ps (SOME key) of
  16.135        SOME z => SOME z
  16.136      | NONE => double_lookup eq ps key
  16.137  
  16.138 -(* string -> string -> bool *)
  16.139  fun is_substring_of needle stack =
  16.140    not (Substring.isEmpty (snd (Substring.position needle
  16.141                                                    (Substring.full stack))))
  16.142  
  16.143 -(* int -> string *)
  16.144  val plural_s = Sledgehammer_Util.plural_s
  16.145 -(* 'a list -> string *)
  16.146  fun plural_s_for_list xs = plural_s (length xs)
  16.147  
  16.148 -(* string -> string list -> string list *)
  16.149  val serial_commas = Sledgehammer_Util.serial_commas
  16.150  
  16.151 -(* unit -> string *)
  16.152  val timestamp = Sledgehammer_Util.timestamp
  16.153 -(* bool -> string -> string -> bool option *)
  16.154  val parse_bool_option = Sledgehammer_Util.parse_bool_option
  16.155 -(* string -> string -> Time.time option *)
  16.156  val parse_time_option = Sledgehammer_Util.parse_time_option
  16.157  
  16.158 -(* polarity -> polarity *)
  16.159  fun flip_polarity Pos = Neg
  16.160    | flip_polarity Neg = Pos
  16.161    | flip_polarity Neut = Neut
  16.162 @@ -262,42 +227,32 @@
  16.163  val nat_T = @{typ nat}
  16.164  val int_T = @{typ int}
  16.165  
  16.166 -(* string -> string *)
  16.167  val subscript = implode o map (prefix "\<^isub>") o explode
  16.168 -(* int -> string *)
  16.169  fun nat_subscript n =
  16.170    (* cheap trick to ensure proper alphanumeric ordering for one- and two-digit
  16.171       numbers *)
  16.172    if n <= 9 then "\<^bsub>" ^ signed_string_of_int n ^ "\<^esub>"
  16.173    else subscript (string_of_int n)
  16.174  
  16.175 -(* Time.time option -> ('a -> 'b) -> 'a -> 'b *)
  16.176  fun time_limit NONE = I
  16.177    | time_limit (SOME delay) = TimeLimit.timeLimit delay
  16.178  
  16.179 -(* Time.time option -> tactic -> tactic *)
  16.180  fun DETERM_TIMEOUT delay tac st =
  16.181    Seq.of_list (the_list (time_limit delay (fn () => SINGLE tac st) ()))
  16.182  
  16.183 -(* ('a -> 'b) -> 'a -> 'b *)
  16.184  fun setmp_show_all_types f =
  16.185    setmp_CRITICAL show_all_types
  16.186                   (! show_types orelse ! show_sorts orelse ! show_all_types) f
  16.187  
  16.188  val indent_size = 2
  16.189  
  16.190 -(* string -> Pretty.T list *)
  16.191  val pstrs = Pretty.breaks o map Pretty.str o space_explode " "
  16.192  
  16.193 -(* XML.tree -> string *)
  16.194  fun plain_string_from_xml_tree t =
  16.195    Buffer.empty |> XML.add_content t |> Buffer.content
  16.196 -(* string -> string *)
  16.197  val unyxml = plain_string_from_xml_tree o YXML.parse
  16.198  
  16.199 -(* string -> bool *)
  16.200  val is_long_identifier = forall Syntax.is_identifier o space_explode "."
  16.201 -(* string -> string *)
  16.202  fun maybe_quote y =
  16.203    let val s = unyxml y in
  16.204      y |> ((not (is_long_identifier (perhaps (try (unprefix "'")) s)) andalso
  16.205 @@ -308,11 +263,8 @@
  16.206  (* This hash function is recommended in Compilers: Principles, Techniques, and
  16.207     Tools, by Aho, Sethi and Ullman. The hashpjw function, which they
  16.208     particularly recommend, triggers a bug in versions of Poly/ML up to 4.2.0. *)
  16.209 -(* word * word -> word *)
  16.210  fun hashw (u, w) = Word.+ (u, Word.* (0w65599, w))
  16.211 -(* Char.char * word -> word *)
  16.212  fun hashw_char (c, w) = hashw (Word.fromInt (Char.ord c), w)
  16.213 -(* string * word -> word *)
  16.214  fun hashw_string (s:string, w) = CharVector.foldl hashw_char w s
  16.215  
  16.216  end;