tuned whitespace;
authorwenzelm
Wed Feb 12 13:33:05 2014 +0100 (2014-02-12)
changeset 554373fd63b92ea3b
parent 55436 9781e17dcc23
child 55438 3b95e70c5cb3
tuned whitespace;
src/HOL/Tools/Predicate_Compile/code_prolog.ML
src/HOL/Tools/Predicate_Compile/core_data.ML
src/HOL/Tools/Predicate_Compile/mode_inference.ML
src/HOL/Tools/Predicate_Compile/predicate_compile.ML
src/HOL/Tools/Predicate_Compile/predicate_compile_aux.ML
src/HOL/Tools/Predicate_Compile/predicate_compile_compilations.ML
src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML
src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML
src/HOL/Tools/Predicate_Compile/predicate_compile_fun.ML
src/HOL/Tools/Predicate_Compile/predicate_compile_pred.ML
src/HOL/Tools/Predicate_Compile/predicate_compile_proof.ML
src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML
src/HOL/Tools/Predicate_Compile/predicate_compile_specialisation.ML
     1.1 --- a/src/HOL/Tools/Predicate_Compile/code_prolog.ML	Wed Feb 12 13:31:18 2014 +0100
     1.2 +++ b/src/HOL/Tools/Predicate_Compile/code_prolog.ML	Wed Feb 12 13:33:05 2014 +0100
     1.3 @@ -18,9 +18,9 @@
     1.4    val set_ensure_groundness : code_options -> code_options
     1.5    val map_limit_predicates : ((string list * int) list -> (string list * int) list)
     1.6      -> code_options -> code_options
     1.7 -  val code_options_of : theory -> code_options 
     1.8 +  val code_options_of : theory -> code_options
     1.9    val map_code_options : (code_options -> code_options) -> theory -> theory
    1.10 -  
    1.11 +
    1.12    datatype arith_op = Plus | Minus
    1.13    datatype prol_term = Var of string | Cons of string | AppF of string * prol_term list
    1.14      | Number of int | ArithOp of arith_op * prol_term list;
    1.15 @@ -33,20 +33,20 @@
    1.16    type clause = ((string * prol_term list) * prem);
    1.17    type logic_program = clause list;
    1.18    type constant_table = (string * string) list
    1.19 -  
    1.20 +
    1.21    val generate : Predicate_Compile_Aux.mode option * bool ->
    1.22      Proof.context -> string -> (logic_program * constant_table)
    1.23    val write_program : logic_program -> string
    1.24    val run : (Time.time * prolog_system) -> logic_program -> (string * prol_term list) ->
    1.25      string list -> int option -> prol_term list list
    1.26 -  
    1.27 +
    1.28    val active : bool Config.T
    1.29    val test_goals :
    1.30      Proof.context -> bool -> (string * typ) list -> (term * term list) list ->
    1.31        Quickcheck.result list
    1.32  
    1.33    val trace : bool Unsynchronized.ref
    1.34 -  
    1.35 +
    1.36    val replace : ((string * string) * string) -> logic_program -> logic_program
    1.37  end;
    1.38  
    1.39 @@ -57,11 +57,11 @@
    1.40  
    1.41  val trace = Unsynchronized.ref false
    1.42  
    1.43 -fun tracing s = if !trace then Output.tracing s else () 
    1.44 +fun tracing s = if !trace then Output.tracing s else ()
    1.45 +
    1.46  
    1.47  (* code generation options *)
    1.48  
    1.49 -
    1.50  type code_options =
    1.51    {ensure_groundness : bool,
    1.52     limit_globally : int option,
    1.53 @@ -79,15 +79,15 @@
    1.54  
    1.55  fun map_limit_predicates f {ensure_groundness, limit_globally, limited_types, limited_predicates,
    1.56    replacing, manual_reorder} =
    1.57 -  {ensure_groundness = ensure_groundness, limit_globally = limit_globally, limited_types = limited_types,
    1.58 -   limited_predicates = f limited_predicates, replacing = replacing,
    1.59 -   manual_reorder = manual_reorder}
    1.60 +  {ensure_groundness = ensure_groundness, limit_globally = limit_globally,
    1.61 +   limited_types = limited_types, limited_predicates = f limited_predicates,
    1.62 +   replacing = replacing, manual_reorder = manual_reorder}
    1.63  
    1.64  fun merge_global_limit (NONE, NONE) = NONE
    1.65    | merge_global_limit (NONE, SOME n) = SOME n
    1.66    | merge_global_limit (SOME n, NONE) = SOME n
    1.67    | merge_global_limit (SOME n, SOME m) = SOME (Int.max (n, m))  (* FIXME odd merge *)
    1.68 -   
    1.69 +
    1.70  structure Options = Theory_Data
    1.71  (
    1.72    type T = code_options
    1.73 @@ -113,6 +113,7 @@
    1.74  
    1.75  val map_code_options = Options.map
    1.76  
    1.77 +
    1.78  (* system configuration *)
    1.79  
    1.80  datatype prolog_system = SWI_PROLOG | YAP
    1.81 @@ -121,7 +122,7 @@
    1.82    | string_of_system YAP = "yap"
    1.83  
    1.84  type system_configuration = {timeout : Time.time, prolog_system : prolog_system}
    1.85 -                                                
    1.86 +
    1.87  structure System_Config = Generic_Data
    1.88  (
    1.89    type T = system_configuration
    1.90 @@ -130,11 +131,13 @@
    1.91    fun merge (a, _) = a
    1.92  )
    1.93  
    1.94 +
    1.95  (* general string functions *)
    1.96  
    1.97  val first_upper = implode o nth_map 0 Symbol.to_ascii_upper o raw_explode;
    1.98  val first_lower = implode o nth_map 0 Symbol.to_ascii_lower o raw_explode;
    1.99  
   1.100 +
   1.101  (* internal program representation *)
   1.102  
   1.103  datatype arith_op = Plus | Minus
   1.104 @@ -153,7 +156,7 @@
   1.105    | map_vars f (ArithOp (opr, ts)) = ArithOp (opr, map (map_vars f) ts)
   1.106    | map_vars f (AppF (fs, ts)) = AppF (fs, map (map_vars f) ts)
   1.107    | map_vars f t = t
   1.108 -  
   1.109 +
   1.110  fun maybe_AppF (c, []) = Cons c
   1.111    | maybe_AppF (c, xs) = AppF (c, xs)
   1.112  
   1.113 @@ -167,7 +170,7 @@
   1.114  
   1.115  fun string_of_prol_term (Var s) = "Var " ^ s
   1.116    | string_of_prol_term (Cons s) = "Cons " ^ s
   1.117 -  | string_of_prol_term (AppF (f, args)) = f ^ "(" ^ commas (map string_of_prol_term args) ^ ")" 
   1.118 +  | string_of_prol_term (AppF (f, args)) = f ^ "(" ^ commas (map string_of_prol_term args) ^ ")"
   1.119    | string_of_prol_term (Number n) = "Number " ^ string_of_int n
   1.120  
   1.121  datatype prem = Conj of prem list
   1.122 @@ -195,11 +198,12 @@
   1.123    | fold_prem_terms f (ArithEq (l, r)) = f l #> f r
   1.124    | fold_prem_terms f (NotArithEq (l, r)) = f l #> f r
   1.125    | fold_prem_terms f (Ground (v, T)) = f (Var v)
   1.126 -  
   1.127 +
   1.128  type clause = ((string * prol_term list) * prem);
   1.129  
   1.130  type logic_program = clause list;
   1.131 - 
   1.132 +
   1.133 +
   1.134  (* translation from introduction rules to internal representation *)
   1.135  
   1.136  fun mk_conform f empty avoid name =
   1.137 @@ -211,6 +215,7 @@
   1.138      val name'' = f (if name' = "" then empty else name')
   1.139    in if member (op =) avoid name'' then singleton (Name.variant_list avoid) name'' else name'' end
   1.140  
   1.141 +
   1.142  (** constant table **)
   1.143  
   1.144  type constant_table = (string * string) list
   1.145 @@ -227,11 +232,11 @@
   1.146    in
   1.147      fold update' consts constant_table
   1.148    end
   1.149 -  
   1.150 +
   1.151  fun translate_const constant_table c =
   1.152 -  case AList.lookup (op =) constant_table c of
   1.153 +  (case AList.lookup (op =) constant_table c of
   1.154      SOME c' => c'
   1.155 -  | NONE => error ("No such constant: " ^ c)
   1.156 +  | NONE => error ("No such constant: " ^ c))
   1.157  
   1.158  fun inv_lookup _ [] _ = NONE
   1.159    | inv_lookup eq ((key, value)::xs) value' =
   1.160 @@ -239,9 +244,10 @@
   1.161        else inv_lookup eq xs value';
   1.162  
   1.163  fun restore_const constant_table c =
   1.164 -  case inv_lookup (op =) constant_table c of
   1.165 +  (case inv_lookup (op =) constant_table c of
   1.166      SOME c' => c'
   1.167 -  | NONE => error ("No constant corresponding to "  ^ c)
   1.168 +  | NONE => error ("No constant corresponding to "  ^ c))
   1.169 +
   1.170  
   1.171  (** translation of terms, literals, premises, and clauses **)
   1.172  
   1.173 @@ -256,52 +262,53 @@
   1.174    in funpow n (fn t => AppF (Suc, [t])) (Cons zero) end
   1.175  
   1.176  fun translate_term ctxt constant_table t =
   1.177 -  case try HOLogic.dest_number t of
   1.178 +  (case try HOLogic.dest_number t of
   1.179      SOME (@{typ "int"}, n) => Number n
   1.180    | SOME (@{typ "nat"}, n) => mk_nat_term constant_table n
   1.181    | NONE =>
   1.182        (case strip_comb t of
   1.183 -        (Free (v, T), []) => Var v 
   1.184 +        (Free (v, T), []) => Var v
   1.185        | (Const (c, _), []) => Cons (translate_const constant_table c)
   1.186        | (Const (c, _), args) =>
   1.187 -        (case translate_arith_const c of
   1.188 -          SOME aop => ArithOp (aop, map (translate_term ctxt constant_table) args)
   1.189 -        | NONE =>                                                             
   1.190 -            AppF (translate_const constant_table c, map (translate_term ctxt constant_table) args))
   1.191 -      | _ => error ("illegal term for translation: " ^ Syntax.string_of_term ctxt t))
   1.192 +          (case translate_arith_const c of
   1.193 +            SOME aop => ArithOp (aop, map (translate_term ctxt constant_table) args)
   1.194 +          | NONE =>
   1.195 +              AppF (translate_const constant_table c, map (translate_term ctxt constant_table) args))
   1.196 +      | _ => error ("illegal term for translation: " ^ Syntax.string_of_term ctxt t)))
   1.197  
   1.198  fun translate_literal ctxt constant_table t =
   1.199 -  case strip_comb t of
   1.200 +  (case strip_comb t of
   1.201      (Const (@{const_name HOL.eq}, _), [l, r]) =>
   1.202        let
   1.203          val l' = translate_term ctxt constant_table l
   1.204          val r' = translate_term ctxt constant_table r
   1.205        in
   1.206 -        (if is_Var l' andalso is_arith_term r' andalso not (is_Var r') then ArithEq else Eq) (l', r')
   1.207 +        (if is_Var l' andalso is_arith_term r' andalso not (is_Var r') then ArithEq else Eq)
   1.208 +          (l', r')
   1.209        end
   1.210    | (Const (c, _), args) =>
   1.211        Rel (translate_const constant_table c, map (translate_term ctxt constant_table) args)
   1.212 -  | _ => error ("illegal literal for translation: " ^ Syntax.string_of_term ctxt t)
   1.213 +  | _ => error ("illegal literal for translation: " ^ Syntax.string_of_term ctxt t))
   1.214  
   1.215  fun NegRel_of (Rel lit) = NotRel lit
   1.216    | NegRel_of (Eq eq) = NotEq eq
   1.217    | NegRel_of (ArithEq eq) = NotArithEq eq
   1.218  
   1.219  fun mk_groundness_prems t = map Ground (Term.add_frees t [])
   1.220 -  
   1.221 -fun translate_prem ensure_groundness ctxt constant_table t =  
   1.222 -    case try HOLogic.dest_not t of
   1.223 -      SOME t =>
   1.224 -        if ensure_groundness then
   1.225 -          Conj (mk_groundness_prems t @ [NegRel_of (translate_literal ctxt constant_table t)])
   1.226 -        else
   1.227 -          NegRel_of (translate_literal ctxt constant_table t)
   1.228 -    | NONE => translate_literal ctxt constant_table t
   1.229 -    
   1.230 +
   1.231 +fun translate_prem ensure_groundness ctxt constant_table t =
   1.232 +  (case try HOLogic.dest_not t of
   1.233 +    SOME t =>
   1.234 +      if ensure_groundness then
   1.235 +        Conj (mk_groundness_prems t @ [NegRel_of (translate_literal ctxt constant_table t)])
   1.236 +      else
   1.237 +        NegRel_of (translate_literal ctxt constant_table t)
   1.238 +  | NONE => translate_literal ctxt constant_table t)
   1.239 +
   1.240  fun imp_prems_conv cv ct =
   1.241 -  case Thm.term_of ct of
   1.242 +  (case Thm.term_of ct of
   1.243      Const ("==>", _) $ _ $ _ => Conv.combination_conv (Conv.arg_conv cv) (imp_prems_conv cv) ct
   1.244 -  | _ => Conv.all_conv ct
   1.245 +  | _ => Conv.all_conv ct)
   1.246  
   1.247  fun preprocess_intro thy rule =
   1.248    Conv.fconv_rule
   1.249 @@ -330,17 +337,17 @@
   1.250  
   1.251  fun add_edges edges_of key G =
   1.252    let
   1.253 -    fun extend' key (G, visited) = 
   1.254 -      case try (Graph.get_node G) key of
   1.255 -          SOME v =>
   1.256 -            let
   1.257 -              val new_edges = filter (fn k => is_some (try (Graph.get_node G) k)) (edges_of (key, v))
   1.258 -              val (G', visited') = fold extend'
   1.259 -                (subtract (op =) (key :: visited) new_edges) (G, key :: visited)
   1.260 -            in
   1.261 -              (fold (Graph.add_edge o (pair key)) new_edges G', visited')
   1.262 -            end
   1.263 -        | NONE => (G, visited)
   1.264 +    fun extend' key (G, visited) =
   1.265 +      (case try (Graph.get_node G) key of
   1.266 +        SOME v =>
   1.267 +          let
   1.268 +            val new_edges = filter (fn k => is_some (try (Graph.get_node G) k)) (edges_of (key, v))
   1.269 +            val (G', visited') = fold extend'
   1.270 +              (subtract (op =) (key :: visited) new_edges) (G, key :: visited)
   1.271 +          in
   1.272 +            (fold (Graph.add_edge o (pair key)) new_edges G', visited')
   1.273 +          end
   1.274 +      | NONE => (G, visited))
   1.275    in
   1.276      fst (extend' key (G, []))
   1.277    end
   1.278 @@ -350,6 +357,7 @@
   1.279      "Constant " ^ const ^ "has intros:\n" ^
   1.280      cat_lines (map (Display.string_of_thm ctxt) (Graph.get_node gr const))) consts))
   1.281  
   1.282 +
   1.283  (* translation of moded predicates *)
   1.284  
   1.285  (** generating graph of moded predicates **)
   1.286 @@ -361,15 +369,20 @@
   1.287        (case fst (strip_comb t) of
   1.288          Const (c, _) => SOME (c, (pol, Predicate_Compile_Core.head_mode_of derivation))
   1.289        | _ => NONE)
   1.290 -    fun req (Predicate_Compile_Aux.Prem t, derivation) = req_mode_of polarity (t, derivation)
   1.291 -      | req (Predicate_Compile_Aux.Negprem t, derivation) = req_mode_of (not polarity) (t, derivation)
   1.292 +    fun req (Predicate_Compile_Aux.Prem t, derivation) =
   1.293 +          req_mode_of polarity (t, derivation)
   1.294 +      | req (Predicate_Compile_Aux.Negprem t, derivation) =
   1.295 +          req_mode_of (not polarity) (t, derivation)
   1.296        | req _ = NONE
   1.297 -  in      
   1.298 +  in
   1.299      maps (fn (_, prems) => map_filter req prems) cls
   1.300    end
   1.301 - 
   1.302 -structure Mode_Graph = Graph(type key = string * (bool * Predicate_Compile_Aux.mode)
   1.303 -  val ord = prod_ord fast_string_ord (prod_ord bool_ord Predicate_Compile_Aux.mode_ord));
   1.304 +
   1.305 +structure Mode_Graph =
   1.306 +  Graph(
   1.307 +    type key = string * (bool * Predicate_Compile_Aux.mode)
   1.308 +    val ord = prod_ord fast_string_ord (prod_ord bool_ord Predicate_Compile_Aux.mode_ord)
   1.309 +  )
   1.310  
   1.311  fun mk_moded_clauses_graph ctxt scc gr =
   1.312    let
   1.313 @@ -386,14 +399,16 @@
   1.314            Predicate_Compile_Core.prepare_intrs options ctxt prednames
   1.315              (maps (Core_Data.intros_of ctxt) prednames)
   1.316          val ((moded_clauses, random'), _) =
   1.317 -          Mode_Inference.infer_modes mode_analysis_options options 
   1.318 +          Mode_Inference.infer_modes mode_analysis_options options
   1.319              (lookup_modes, lookup_neg_modes, needs_random) ctxt preds all_modes param_vs clauses
   1.320          val modes = map (fn (p, mps) => (p, map fst mps)) moded_clauses
   1.321          val pos_modes' = map (apsnd (map_filter (fn (true, m) => SOME m | _ => NONE))) modes
   1.322          val neg_modes' = map (apsnd (map_filter (fn (false, m) => SOME m | _ => NONE))) modes
   1.323 -        val _ = tracing ("Inferred modes:\n" ^
   1.324 -          cat_lines (map (fn (s, ms) => s ^ ": " ^ commas (map
   1.325 -            (fn (p, m) => Predicate_Compile_Aux.string_of_mode m ^ (if p then "pos" else "neg")) ms)) modes))
   1.326 +        val _ =
   1.327 +          tracing ("Inferred modes:\n" ^
   1.328 +            cat_lines (map (fn (s, ms) => s ^ ": " ^ commas (map
   1.329 +              (fn (p, m) =>
   1.330 +                Predicate_Compile_Aux.string_of_mode m ^ (if p then "pos" else "neg")) ms)) modes))
   1.331          val gr' = gr
   1.332            |> fold (fn (p, mps) => fold (fn (mode, cls) =>
   1.333                  Mode_Graph.new_node ((p, mode), cls)) mps)
   1.334 @@ -406,8 +421,8 @@
   1.335            AList.merge (op =) (op =) (neg_modes, neg_modes'),
   1.336            AList.merge (op =) (op =) (random, random')))
   1.337        end
   1.338 -  in  
   1.339 -    fst (fold infer (rev scc) (Mode_Graph.empty, ([], [], []))) 
   1.340 +  in
   1.341 +    fst (fold infer (rev scc) (Mode_Graph.empty, ([], [], [])))
   1.342    end
   1.343  
   1.344  fun declare_moded_predicate moded_preds table =
   1.345 @@ -431,32 +446,34 @@
   1.346      fun mk_literal pol derivation constant_table' t =
   1.347        let
   1.348          val (p, args) = strip_comb t
   1.349 -        val mode = Predicate_Compile_Core.head_mode_of derivation 
   1.350 +        val mode = Predicate_Compile_Core.head_mode_of derivation
   1.351          val name = fst (dest_Const p)
   1.352 -        
   1.353 +
   1.354          val p' = the (AList.lookup (op =) moded_pred_table' (name, (pol, mode)))
   1.355          val args' = map (translate_term ctxt constant_table') args
   1.356        in
   1.357          Rel (p', args')
   1.358        end
   1.359      fun mk_prem pol (indprem, derivation) constant_table =
   1.360 -      case indprem of
   1.361 +      (case indprem of
   1.362          Predicate_Compile_Aux.Generator (s, T) => (Ground (s, T), constant_table)
   1.363        | _ =>
   1.364 -        declare_consts (Term.add_const_names (Predicate_Compile_Aux.dest_indprem indprem) []) constant_table
   1.365 +        declare_consts (Term.add_const_names (Predicate_Compile_Aux.dest_indprem indprem) [])
   1.366 +          constant_table
   1.367          |> (fn constant_table' =>
   1.368            (case indprem of Predicate_Compile_Aux.Negprem t =>
   1.369              NegRel_of (mk_literal (not pol) derivation constant_table' t)
   1.370            | _ =>
   1.371 -            mk_literal pol derivation constant_table' (Predicate_Compile_Aux.dest_indprem indprem), constant_table'))
   1.372 +            mk_literal pol derivation constant_table' (Predicate_Compile_Aux.dest_indprem indprem),
   1.373 +              constant_table')))
   1.374      fun mk_clause pred_name pol (ts, prems) (prog, constant_table) =
   1.375 -    let
   1.376 -      val constant_table' = declare_consts (fold Term.add_const_names ts []) constant_table
   1.377 -      val args = map (translate_term ctxt constant_table') ts
   1.378 -      val (prems', constant_table'') = fold_map (mk_prem pol) prems constant_table'
   1.379 -    in
   1.380 -      (((pred_name, args), Conj prems') :: prog, constant_table'')
   1.381 -    end
   1.382 +      let
   1.383 +        val constant_table' = declare_consts (fold Term.add_const_names ts []) constant_table
   1.384 +        val args = map (translate_term ctxt constant_table') ts
   1.385 +        val (prems', constant_table'') = fold_map (mk_prem pol) prems constant_table'
   1.386 +      in
   1.387 +        (((pred_name, args), Conj prems') :: prog, constant_table'')
   1.388 +      end
   1.389      fun mk_clauses (pred, mode as (pol, _)) =
   1.390        let
   1.391          val clauses = Mode_Graph.get_node moded_gr (pred, mode)
   1.392 @@ -469,35 +486,37 @@
   1.393    end
   1.394  
   1.395  fun generate (use_modes, ensure_groundness) ctxt const =
   1.396 -  let 
   1.397 +  let
   1.398      fun strong_conn_of gr keys =
   1.399        Graph.strong_conn (Graph.restrict (member (op =) (Graph.all_succs gr keys)) gr)
   1.400      val gr = Core_Data.intros_graph_of ctxt
   1.401      val gr' = add_edges depending_preds_of const gr
   1.402      val scc = strong_conn_of gr' [const]
   1.403 -    val initial_constant_table = 
   1.404 +    val initial_constant_table =
   1.405        declare_consts [@{const_name "Groups.zero_class.zero"}, @{const_name "Suc"}] []
   1.406    in
   1.407 -    case use_modes of
   1.408 +    (case use_modes of
   1.409        SOME mode =>
   1.410          let
   1.411            val moded_gr = mk_moded_clauses_graph ctxt scc gr
   1.412            val moded_gr' = Mode_Graph.restrict
   1.413              (member (op =) (Mode_Graph.all_succs moded_gr [(const, (true, mode))])) moded_gr
   1.414 -          val scc = Mode_Graph.strong_conn moded_gr' 
   1.415 +          val scc = Mode_Graph.strong_conn moded_gr'
   1.416          in
   1.417            apfst rev (apsnd snd
   1.418              (fold (mk_program ctxt moded_gr') (rev scc) ([], ([], initial_constant_table))))
   1.419          end
   1.420 -      | NONE =>
   1.421 -        let 
   1.422 +    | NONE =>
   1.423 +        let
   1.424            val _ = print_intros ctxt gr (flat scc)
   1.425            val constant_table = declare_consts (flat scc) initial_constant_table
   1.426          in
   1.427 -          apfst flat (fold_map (translate_intros ensure_groundness ctxt gr) (flat scc) constant_table)
   1.428 -        end
   1.429 +          apfst flat
   1.430 +            (fold_map (translate_intros ensure_groundness ctxt gr) (flat scc) constant_table)
   1.431 +        end)
   1.432    end
   1.433 -  
   1.434 +
   1.435 +
   1.436  (* implementation for fully enumerating predicates and
   1.437    for size-limited predicates for enumerating the values of a datatype upto a specific size *)
   1.438  
   1.439 @@ -506,7 +525,7 @@
   1.440    | add_ground_typ _ = I
   1.441  
   1.442  fun mk_relname (Type (Tcon, Targs)) =
   1.443 -  first_lower (Long_Name.base_name Tcon) ^ space_implode "_" (map mk_relname Targs)
   1.444 +      first_lower (Long_Name.base_name Tcon) ^ space_implode "_" (map mk_relname Targs)
   1.445    | mk_relname _ = raise Fail "unexpected type"
   1.446  
   1.447  fun mk_lim_relname T = "lim_" ^  mk_relname T
   1.448 @@ -519,14 +538,15 @@
   1.449    | inst_constrs_of thy T = raise TYPE ("inst_constrs_of", [T], [])
   1.450  
   1.451  fun is_recursive_constr T (Const (constr_name, T')) = member (op =) (binder_types T') T
   1.452 -  
   1.453 +
   1.454  fun mk_ground_impl ctxt limited_types (T as Type (Tcon, Targs)) (seen, constant_table) =
   1.455    if member (op =) seen T then ([], (seen, constant_table))
   1.456    else
   1.457      let
   1.458 -      val (limited, size) = case AList.lookup (op =) limited_types T of
   1.459 -        SOME s => (true, s)
   1.460 -      | NONE => (false, 0)      
   1.461 +      val (limited, size) =
   1.462 +        (case AList.lookup (op =) limited_types T of
   1.463 +          SOME s => (true, s)
   1.464 +        | NONE => (false, 0))
   1.465        val rel_name = (if limited then mk_lim_relname else mk_relname) T
   1.466        fun mk_impl (Const (constr_name, cT), recursive) (seen, constant_table) =
   1.467          let
   1.468 @@ -537,9 +557,9 @@
   1.469            val vars = map (fn i => Var ("x" ^ string_of_int i)) (1 upto (length Ts))
   1.470            val lim_var =
   1.471              if limited then
   1.472 -              if recursive then [AppF ("suc", [Var "Lim"])]              
   1.473 +              if recursive then [AppF ("suc", [Var "Lim"])]
   1.474                else [Var "Lim"]
   1.475 -            else [] 
   1.476 +            else []
   1.477            fun mk_prem v T' =
   1.478              if limited andalso T' = T then Rel (mk_lim_relname T', [Var "Lim", v])
   1.479              else Rel (mk_relname T', [v])
   1.480 @@ -565,18 +585,20 @@
   1.481  
   1.482  fun replace_ground (Conj prems) = Conj (map replace_ground prems)
   1.483    | replace_ground (Ground (x, T)) =
   1.484 -    Rel (mk_relname T, [Var x])  
   1.485 +    Rel (mk_relname T, [Var x])
   1.486    | replace_ground p = p
   1.487 -  
   1.488 +
   1.489  fun add_ground_predicates ctxt limited_types (p, constant_table) =
   1.490    let
   1.491      val ground_typs = fold (add_ground_typ o snd) p []
   1.492 -    val (grs, (_, constant_table')) = fold_map (mk_ground_impl ctxt limited_types) ground_typs ([], constant_table)
   1.493 +    val (grs, (_, constant_table')) =
   1.494 +      fold_map (mk_ground_impl ctxt limited_types) ground_typs ([], constant_table)
   1.495      val p' = map (apsnd replace_ground) p
   1.496    in
   1.497      ((flat grs) @ p', constant_table')
   1.498    end
   1.499  
   1.500 +
   1.501  (* make depth-limited version of predicate *)
   1.502  
   1.503  fun mk_lim_rel_name rel_name = "lim_" ^ rel_name
   1.504 @@ -600,8 +622,8 @@
   1.505  fun nat_term_of n = funpow n (fn t => AppF ("suc", [t])) (Cons "zero")
   1.506  
   1.507  fun add_limited_predicates limited_predicates (p, constant_table) =
   1.508 -  let                                     
   1.509 -    fun add (rel_names, limit) p = 
   1.510 +  let
   1.511 +    fun add (rel_names, limit) p =
   1.512        let
   1.513          val clauses = filter (fn ((rel, _), _) => member (op =) rel_names rel) p
   1.514          val clauses' = map (mk_depth_limited rel_names) clauses
   1.515 @@ -609,7 +631,7 @@
   1.516            let
   1.517              val nargs = length (snd (fst
   1.518                (the (find_first (fn ((rel, _), _) => rel = rel_name) clauses))))
   1.519 -            val vars = map (fn i => Var ("x" ^ string_of_int i)) (1 upto nargs)        
   1.520 +            val vars = map (fn i => Var ("x" ^ string_of_int i)) (1 upto nargs)
   1.521            in
   1.522              (("limited_" ^ rel_name, vars), Rel ("lim_" ^ rel_name, nat_term_of limit :: vars))
   1.523            end
   1.524 @@ -629,10 +651,12 @@
   1.525            if rel = from then Rel (to, ts) else r
   1.526        | replace_prem r = r
   1.527    in
   1.528 -    map (fn ((rel, args), prem) => ((rel, args), (if rel = location then replace_prem else I) prem)) p
   1.529 +    map
   1.530 +      (fn ((rel, args), prem) => ((rel, args), (if rel = location then replace_prem else I) prem))
   1.531 +      p
   1.532    end
   1.533  
   1.534 -  
   1.535 +
   1.536  (* reorder manually : reorder premises of ith clause of predicate p by a permutation perm *)
   1.537  
   1.538  fun reorder_manually reorder p =
   1.539 @@ -642,14 +666,16 @@
   1.540          val seen' = AList.map_default (op =) (rel, 0) (fn x => x + 1) seen
   1.541          val i = the (AList.lookup (op =) seen' rel)
   1.542          val perm = AList.lookup (op =) reorder (rel, i)
   1.543 -        val prem' = (case perm of 
   1.544 -          SOME p => (case prem of Conj prems => Conj (map (nth prems) p) | _ => prem)
   1.545 -        | NONE => prem)
   1.546 +        val prem' =
   1.547 +          (case perm of
   1.548 +            SOME p => (case prem of Conj prems => Conj (map (nth prems) p) | _ => prem)
   1.549 +          | NONE => prem)
   1.550        in (((rel, args), prem'), seen') end
   1.551    in
   1.552      fst (fold_map reorder' p [])
   1.553    end
   1.554  
   1.555 +
   1.556  (* rename variables to prolog-friendly names *)
   1.557  
   1.558  fun rename_vars_term renaming = map_vars (fn v => the (AList.lookup (op =) renaming v))
   1.559 @@ -658,7 +684,7 @@
   1.560  
   1.561  fun is_prolog_conform v =
   1.562    forall (fn s => Symbol.is_ascii_letter s orelse Symbol.is_ascii_digit s) (Symbol.explode v)
   1.563 -  
   1.564 +
   1.565  fun mk_renaming v renaming =
   1.566    (v, mk_conform first_upper "Var" (map snd renaming) v) :: renaming
   1.567  
   1.568 @@ -667,9 +693,10 @@
   1.569      val vars = fold_prem_terms add_vars prem (fold add_vars args [])
   1.570      val renaming = fold mk_renaming vars []
   1.571    in ((rel, map (rename_vars_term renaming) args), rename_vars_prem renaming prem) end
   1.572 -  
   1.573 +
   1.574  val rename_vars_program = map rename_vars_clause
   1.575  
   1.576 +
   1.577  (* limit computation globally by some threshold *)
   1.578  
   1.579  fun limit_globally ctxt limit const_name (p, constant_table) =
   1.580 @@ -686,6 +713,7 @@
   1.581      (entry_clause :: p' @ p'', constant_table)
   1.582    end
   1.583  
   1.584 +
   1.585  (* post processing of generated prolog program *)
   1.586  
   1.587  fun post_process ctxt options const_name (p, constant_table) =
   1.588 @@ -703,6 +731,7 @@
   1.589    |> apfst (reorder_manually (#manual_reorder options))
   1.590    |> apfst rename_vars_program
   1.591  
   1.592 +
   1.593  (* code printer *)
   1.594  
   1.595  fun write_arith_op Plus = "+"
   1.596 @@ -710,15 +739,17 @@
   1.597  
   1.598  fun write_term (Var v) = v
   1.599    | write_term (Cons c) = c
   1.600 -  | write_term (AppF (f, args)) = f ^ "(" ^ space_implode ", " (map write_term args) ^ ")"
   1.601 -  | write_term (ArithOp (oper, [a1, a2])) = write_term a1 ^ " " ^ write_arith_op oper ^ " " ^ write_term a2
   1.602 +  | write_term (AppF (f, args)) =
   1.603 +      f ^ "(" ^ space_implode ", " (map write_term args) ^ ")"
   1.604 +  | write_term (ArithOp (oper, [a1, a2])) =
   1.605 +      write_term a1 ^ " " ^ write_arith_op oper ^ " " ^ write_term a2
   1.606    | write_term (Number n) = string_of_int n
   1.607  
   1.608  fun write_rel (pred, args) =
   1.609 -  pred ^ "(" ^ space_implode ", " (map write_term args) ^ ")" 
   1.610 +  pred ^ "(" ^ space_implode ", " (map write_term args) ^ ")"
   1.611  
   1.612  fun write_prem (Conj prems) = space_implode ", " (map write_prem prems)
   1.613 -  | write_prem (Rel p) = write_rel p  
   1.614 +  | write_prem (Rel p) = write_rel p
   1.615    | write_prem (NotRel p) = "not(" ^ write_rel p ^ ")"
   1.616    | write_prem (Eq (l, r)) = write_term l ^ " = " ^ write_term r
   1.617    | write_prem (NotEq (l, r)) = write_term l ^ " \\= " ^ write_term r
   1.618 @@ -730,7 +761,8 @@
   1.619    write_rel head ^ (if prem = Conj [] then "." else " :- " ^ write_prem prem ^ ".")
   1.620  
   1.621  fun write_program p =
   1.622 -  cat_lines (map write_clause p) 
   1.623 +  cat_lines (map write_clause p)
   1.624 +
   1.625  
   1.626  (* query templates *)
   1.627  
   1.628 @@ -740,7 +772,7 @@
   1.629    "eval :- once("  ^ rel ^ "(" ^ space_implode ", " (map write_term args) ^ ")),\n" ^
   1.630    "writef('" ^ space_implode ";" (map (fn v => v ^ " = %w") vnames) ^
   1.631    "\\n', [" ^ space_implode ", " vnames ^ "]).\n"
   1.632 -  
   1.633 +
   1.634  fun swi_prolog_query_firstn n (rel, args) vnames =
   1.635    "eval :- findnsols(" ^ string_of_int n ^ ", (" ^ space_implode ", " vnames ^ "), " ^
   1.636      rel ^ "(" ^ space_implode ", " (map write_term args) ^ "), Sols), writelist(Sols).\n" ^
   1.637 @@ -748,7 +780,7 @@
   1.638      "writelist([(" ^ space_implode ", " vnames ^ ")|SolutionTail]) :- " ^
   1.639      "writef('" ^ space_implode ";" (map (fn v => v ^ " = %w") vnames) ^
   1.640      "\\n', [" ^ space_implode ", " vnames ^ "]), writelist(SolutionTail).\n"
   1.641 -  
   1.642 +
   1.643  val swi_prolog_prelude =
   1.644    ":- use_module(library('dialect/ciao/aggregates')).\n" ^
   1.645    ":- style_check(-singleton).\n" ^
   1.646 @@ -757,6 +789,7 @@
   1.647    "main :- catch(eval, E, (print_message(error, E), fail)), halt.\n" ^
   1.648    "main :- halt(1).\n"
   1.649  
   1.650 +
   1.651  (** query and prelude for yap **)
   1.652  
   1.653  fun yap_query_first (rel, args) vnames =
   1.654 @@ -767,18 +800,25 @@
   1.655  val yap_prelude =
   1.656    ":- initialization(eval).\n"
   1.657  
   1.658 +
   1.659  (* system-dependent query, prelude and invocation *)
   1.660  
   1.661 -fun query system nsols = 
   1.662 -  case system of
   1.663 +fun query system nsols =
   1.664 +  (case system of
   1.665      SWI_PROLOG =>
   1.666 -      (case nsols of NONE => swi_prolog_query_first | SOME n => swi_prolog_query_firstn n)
   1.667 +      (case nsols of
   1.668 +        NONE => swi_prolog_query_first
   1.669 +      | SOME n => swi_prolog_query_firstn n)
   1.670    | YAP =>
   1.671 -      case nsols of NONE => yap_query_first | SOME n =>
   1.672 -        error "No support for querying multiple solutions in the prolog system yap"
   1.673 +      (case nsols of
   1.674 +        NONE => yap_query_first
   1.675 +      | SOME n =>
   1.676 +          error "No support for querying multiple solutions in the prolog system yap"))
   1.677  
   1.678  fun prelude system =
   1.679 -  case system of SWI_PROLOG => swi_prolog_prelude | YAP => yap_prelude
   1.680 +  (case system of
   1.681 +    SWI_PROLOG => swi_prolog_prelude
   1.682 +  | YAP => yap_prelude)
   1.683  
   1.684  fun invoke system file =
   1.685    let
   1.686 @@ -804,7 +844,8 @@
   1.687    Scan.many1 Symbol.is_ascii_digit
   1.688  
   1.689  val scan_atom =
   1.690 -  Scan.many1 (fn s => Symbol.is_ascii_lower s orelse Symbol.is_ascii_digit s orelse Symbol.is_ascii_quasi s)
   1.691 +  Scan.many1
   1.692 +    (fn s => Symbol.is_ascii_lower s orelse Symbol.is_ascii_digit s orelse Symbol.is_ascii_quasi s)
   1.693  
   1.694  val scan_var =
   1.695    Scan.many1
   1.696 @@ -821,7 +862,8 @@
   1.697  val is_atom_ident = forall Symbol.is_ascii_lower
   1.698  
   1.699  val is_var_ident =
   1.700 -  forall (fn s => Symbol.is_ascii_upper s orelse Symbol.is_ascii_digit s orelse Symbol.is_ascii_quasi s)
   1.701 +  forall (fn s =>
   1.702 +    Symbol.is_ascii_upper s orelse Symbol.is_ascii_digit s orelse Symbol.is_ascii_quasi s)
   1.703  
   1.704  fun int_of_symbol_list xs = fold (fn x => fn s => s * 10 + (ord x - ord "0")) xs 0
   1.705  
   1.706 @@ -837,23 +879,25 @@
   1.707  val parse_term = fst o Scan.finite Symbol.stopper
   1.708      (Scan.error (!! (fn _ => raise Fail "parsing prolog output failed")) scan_term)
   1.709    o raw_explode
   1.710 -  
   1.711 +
   1.712  fun parse_solutions sol =
   1.713    let
   1.714 -    fun dest_eq s = case space_explode "=" s of
   1.715 +    fun dest_eq s =
   1.716 +      (case space_explode "=" s of
   1.717          (l :: r :: []) => parse_term (unprefix " " r)
   1.718 -      | _ => raise Fail "unexpected equation in prolog output"
   1.719 +      | _ => raise Fail "unexpected equation in prolog output")
   1.720      fun parse_solution s = map dest_eq (space_explode ";" s)
   1.721 -    val sols = case space_explode "\n" sol of [] => [] | s => fst (split_last s)  
   1.722 +    val sols = (case space_explode "\n" sol of [] => [] | s => fst (split_last s))
   1.723    in
   1.724      map parse_solution sols
   1.725 -  end 
   1.726 -  
   1.727 +  end
   1.728 +
   1.729 +
   1.730  (* calling external interpreter and getting results *)
   1.731  
   1.732  fun run (timeout, system) p (query_rel, args) vnames nsols =
   1.733    let
   1.734 -    val renaming = fold mk_renaming (fold add_vars args vnames) [] 
   1.735 +    val renaming = fold mk_renaming (fold add_vars args vnames) []
   1.736      val vnames' = map (fn v => the (AList.lookup (op =) renaming v)) vnames
   1.737      val args' = map (rename_vars_term renaming) args
   1.738      val prog = prelude system ^ query system nsols (query_rel, args') vnames' ^ write_program p
   1.739 @@ -867,26 +911,27 @@
   1.740      tss
   1.741    end
   1.742  
   1.743 +
   1.744  (* restoring types in terms *)
   1.745  
   1.746  fun restore_term ctxt constant_table (Var s, T) = Free (s, T)
   1.747    | restore_term ctxt constant_table (Number n, @{typ "int"}) = HOLogic.mk_number @{typ "int"} n
   1.748 -  | restore_term ctxt constant_table (Number n, _) = raise (Fail "unexpected type for number") 
   1.749 +  | restore_term ctxt constant_table (Number n, _) = raise (Fail "unexpected type for number")
   1.750    | restore_term ctxt constant_table (Cons s, T) = Const (restore_const constant_table s, T)
   1.751    | restore_term ctxt constant_table (AppF (f, args), T) =
   1.752 -    let
   1.753 -      val thy = Proof_Context.theory_of ctxt
   1.754 -      val c = restore_const constant_table f
   1.755 -      val cT = Sign.the_const_type thy c
   1.756 -      val (argsT, resT) = strip_type cT
   1.757 -      val subst = Sign.typ_match thy (resT, T) Vartab.empty
   1.758 -      val argsT' = map (Envir.subst_type subst) argsT
   1.759 -    in
   1.760 -      list_comb (Const (c, Envir.subst_type subst cT),
   1.761 -        map (restore_term ctxt constant_table) (args ~~ argsT'))
   1.762 -    end
   1.763 +      let
   1.764 +        val thy = Proof_Context.theory_of ctxt
   1.765 +        val c = restore_const constant_table f
   1.766 +        val cT = Sign.the_const_type thy c
   1.767 +        val (argsT, resT) = strip_type cT
   1.768 +        val subst = Sign.typ_match thy (resT, T) Vartab.empty
   1.769 +        val argsT' = map (Envir.subst_type subst) argsT
   1.770 +      in
   1.771 +        list_comb (Const (c, Envir.subst_type subst cT),
   1.772 +          map (restore_term ctxt constant_table) (args ~~ argsT'))
   1.773 +      end
   1.774  
   1.775 -    
   1.776 +
   1.777  (* restore numerals in natural numbers *)
   1.778  
   1.779  fun restore_nat_numerals t =
   1.780 @@ -894,9 +939,10 @@
   1.781      HOLogic.mk_number @{typ nat} (HOLogic.dest_nat t)
   1.782    else
   1.783      (case t of
   1.784 -        t1 $ t2 => restore_nat_numerals t1 $ restore_nat_numerals t2
   1.785 -      | t => t)
   1.786 -  
   1.787 +      t1 $ t2 => restore_nat_numerals t1 $ restore_nat_numerals t2
   1.788 +    | t => t)
   1.789 +
   1.790 +
   1.791  (* values command *)
   1.792  
   1.793  val preprocess_options = Predicate_Compile_Aux.Options {
   1.794 @@ -926,17 +972,19 @@
   1.795  fun values ctxt soln t_compr =
   1.796    let
   1.797      val options = code_options_of (Proof_Context.theory_of ctxt)
   1.798 -    val split = case t_compr of (Const (@{const_name Collect}, _) $ t) => t
   1.799 -      | _ => error ("Not a set comprehension: " ^ Syntax.string_of_term ctxt t_compr);
   1.800 -    val (body, Ts, fp) = HOLogic.strip_psplits split;
   1.801 +    val split =
   1.802 +      (case t_compr of
   1.803 +        (Const (@{const_name Collect}, _) $ t) => t
   1.804 +      | _ => error ("Not a set comprehension: " ^ Syntax.string_of_term ctxt t_compr))
   1.805 +    val (body, Ts, fp) = HOLogic.strip_psplits split
   1.806      val output_names = Name.variant_list (Term.add_free_names body [])
   1.807        (map (fn i => "x" ^ string_of_int i) (1 upto length Ts))
   1.808      val output_frees = rev (map2 (curry Free) output_names Ts)
   1.809      val body = subst_bounds (output_frees, body)
   1.810      val (pred as Const (name, T), all_args) =
   1.811 -      case strip_comb body of
   1.812 +      (case strip_comb body of
   1.813          (Const (name, T), all_args) => (Const (name, T), all_args)
   1.814 -      | (head, _) => error ("Not a constant: " ^ Syntax.string_of_term ctxt head)
   1.815 +      | (head, _) => error ("Not a constant: " ^ Syntax.string_of_term ctxt head))
   1.816      val _ = tracing "Preprocessing specification..."
   1.817      val T = Sign.the_const_type (Proof_Context.theory_of ctxt) name
   1.818      val t = Const (name, T)
   1.819 @@ -956,7 +1004,7 @@
   1.820      val _ = tracing "Restoring terms..."
   1.821      val empty = Const(@{const_name bot}, fastype_of t_compr)
   1.822      fun mk_insert x S =
   1.823 -      Const (@{const_name "Set.insert"}, fastype_of x --> fastype_of S --> fastype_of S) $ x $ S 
   1.824 +      Const (@{const_name "Set.insert"}, fastype_of x --> fastype_of S --> fastype_of S) $ x $ S
   1.825      fun mk_set_compr in_insert [] xs =
   1.826         rev ((Free ("dots", fastype_of t_compr)) ::  (* FIXME proper name!? *)
   1.827          (if null in_insert then xs else (fold mk_insert in_insert empty) :: xs))
   1.828 @@ -968,19 +1016,22 @@
   1.829              mk_set_compr (t :: in_insert) ts xs
   1.830            else
   1.831              let
   1.832 -              val uu as (uuN, uuT) = singleton (Variable.variant_frees ctxt' [t]) ("uu", fastype_of t)
   1.833 +              val uu as (uuN, uuT) =
   1.834 +                singleton (Variable.variant_frees ctxt' [t]) ("uu", fastype_of t)
   1.835                val set_compr =
   1.836 -                HOLogic.mk_Collect (uuN, uuT, fold (fn (s, T) => fn t => HOLogic.mk_exists (s, T, t))
   1.837 -                  frees (HOLogic.mk_conj (HOLogic.mk_eq (Free uu, t), @{term "True"})))
   1.838 +                HOLogic.mk_Collect (uuN, uuT,
   1.839 +                  fold (fn (s, T) => fn t => HOLogic.mk_exists (s, T, t))
   1.840 +                    frees (HOLogic.mk_conj (HOLogic.mk_eq (Free uu, t), @{term "True"})))
   1.841              in
   1.842                mk_set_compr [] ts
   1.843 -                (set_compr :: (if null in_insert then xs else (fold mk_insert in_insert empty) :: xs))  
   1.844 +                (set_compr ::
   1.845 +                  (if null in_insert then xs else (fold mk_insert in_insert empty) :: xs))
   1.846              end
   1.847          end
   1.848    in
   1.849 -      foldl1 (HOLogic.mk_binop @{const_name sup}) (mk_set_compr []
   1.850 -        (map (fn ts => HOLogic.mk_tuple 
   1.851 -          (map (restore_nat_numerals o restore_term ctxt' constant_table) (ts ~~ Ts))) tss) [])
   1.852 +    foldl1 (HOLogic.mk_binop @{const_name sup}) (mk_set_compr []
   1.853 +      (map (fn ts => HOLogic.mk_tuple
   1.854 +        (map (restore_nat_numerals o restore_term ctxt' constant_table) (ts ~~ Ts))) tss) [])
   1.855    end
   1.856  
   1.857  fun values_cmd print_modes soln raw_t state =
   1.858 @@ -991,30 +1042,31 @@
   1.859      val ty' = Term.type_of t'
   1.860      val ctxt' = Variable.auto_fixes t' ctxt
   1.861      val _ = tracing "Printing terms..."
   1.862 -    val p = Print_Mode.with_modes print_modes (fn () =>
   1.863 +  in
   1.864 +    Print_Mode.with_modes print_modes (fn () =>
   1.865        Pretty.block [Pretty.quote (Syntax.pretty_term ctxt' t'), Pretty.fbrk,
   1.866 -        Pretty.str "::", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt' ty')]) ();
   1.867 -  in Pretty.writeln p end;
   1.868 +        Pretty.str "::", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt' ty')]) ()
   1.869 +  end |> Pretty.writeln p
   1.870  
   1.871  
   1.872  (* renewing the values command for Prolog queries *)
   1.873  
   1.874  val opt_print_modes =
   1.875 -  Scan.optional (@{keyword "("} |-- Parse.!!! (Scan.repeat1 Parse.xname --| @{keyword ")"})) [];
   1.876 +  Scan.optional (@{keyword "("} |-- Parse.!!! (Scan.repeat1 Parse.xname --| @{keyword ")"})) []
   1.877  
   1.878  val _ =
   1.879    Outer_Syntax.improper_command @{command_spec "values"}
   1.880      "enumerate and print comprehensions"
   1.881      (opt_print_modes -- Scan.optional (Parse.nat >> SOME) NONE -- Parse.term
   1.882       >> (fn ((print_modes, soln), t) => Toplevel.keep
   1.883 -          (values_cmd print_modes soln t))); (*FIXME does not preserve the previous functionality*)
   1.884 +          (values_cmd print_modes soln t))) (*FIXME does not preserve the previous functionality*)
   1.885  
   1.886  
   1.887  (* quickcheck generator *)
   1.888  
   1.889  (* FIXME: a small clone of Predicate_Compile_Quickcheck - maybe refactor out commons *)
   1.890  
   1.891 -val active = Attrib.setup_config_bool @{binding quickcheck_prolog_active} (K true);
   1.892 +val active = Attrib.setup_config_bool @{binding quickcheck_prolog_active} (K true)
   1.893  
   1.894  fun test_term ctxt (t, eval_terms) =
   1.895    let
   1.896 @@ -1035,14 +1087,17 @@
   1.897        p (translate_const constant_table full_constname, map (Var o fst) vs') (map fst vs') (SOME 1)
   1.898      val _ = tracing "Restoring terms..."
   1.899      val counterexample =
   1.900 -      case tss of
   1.901 +      (case tss of
   1.902          [ts] => SOME (map (restore_term ctxt' constant_table) (ts ~~ map snd vs'))
   1.903 -      | _ => NONE
   1.904 +      | _ => NONE)
   1.905    in
   1.906      Quickcheck.Result
   1.907 -      {counterexample = Option.map (pair true o curry (op ~~) (Term.add_free_names t [])) counterexample,
   1.908 -       evaluation_terms = Option.map (K []) counterexample, timings = [], reports = []}
   1.909 -  end;
   1.910 +      {counterexample =
   1.911 +        Option.map (pair true o curry (op ~~) (Term.add_free_names t [])) counterexample,
   1.912 +       evaluation_terms = Option.map (K []) counterexample,
   1.913 +       timings = [],
   1.914 +       reports = []}
   1.915 +  end
   1.916  
   1.917  fun test_goals ctxt _ insts goals =
   1.918    let
   1.919 @@ -1050,6 +1105,5 @@
   1.920    in
   1.921      Quickcheck_Common.collect_results (test_term ctxt) (maps (map snd) correct_inst_goals) []
   1.922    end
   1.923 -  
   1.924 -  
   1.925 -end;
   1.926 +
   1.927 +end
     2.1 --- a/src/HOL/Tools/Predicate_Compile/core_data.ML	Wed Feb 12 13:31:18 2014 +0100
     2.2 +++ b/src/HOL/Tools/Predicate_Compile/core_data.ML	Wed Feb 12 13:33:05 2014 +0100
     2.3 @@ -133,14 +133,16 @@
     2.4    val merge = Graph.merge eq_pred_data;
     2.5  );
     2.6  
     2.7 +
     2.8  (* queries *)
     2.9  
    2.10  fun lookup_pred_data ctxt name =
    2.11    Option.map rep_pred_data (try (Graph.get_node (PredData.get (Proof_Context.theory_of ctxt))) name)
    2.12  
    2.13 -fun the_pred_data ctxt name = case lookup_pred_data ctxt name
    2.14 - of NONE => error ("No such predicate " ^ quote name)  
    2.15 -  | SOME data => data;
    2.16 +fun the_pred_data ctxt name =
    2.17 +  (case lookup_pred_data ctxt name of
    2.18 +    NONE => error ("No such predicate " ^ quote name)  
    2.19 +  | SOME data => data)
    2.20  
    2.21  val is_registered = is_some oo lookup_pred_data
    2.22  
    2.23 @@ -150,24 +152,26 @@
    2.24  
    2.25  val names_of = map fst o #intros oo the_pred_data
    2.26  
    2.27 -fun the_elim_of ctxt name = case #elim (the_pred_data ctxt name)
    2.28 - of NONE => error ("No elimination rule for predicate " ^ quote name)
    2.29 -  | SOME thm => thm
    2.30 +fun the_elim_of ctxt name =
    2.31 +  (case #elim (the_pred_data ctxt name) of
    2.32 +    NONE => error ("No elimination rule for predicate " ^ quote name)
    2.33 +  | SOME thm => thm)
    2.34    
    2.35  val has_elim = is_some o #elim oo the_pred_data
    2.36  
    2.37  fun function_names_of compilation ctxt name =
    2.38 -  case AList.lookup (op =) (#function_names (the_pred_data ctxt name)) compilation of
    2.39 -    NONE => error ("No " ^ string_of_compilation compilation
    2.40 -      ^ " functions defined for predicate " ^ quote name)
    2.41 -  | SOME fun_names => fun_names
    2.42 +  (case AList.lookup (op =) (#function_names (the_pred_data ctxt name)) compilation of
    2.43 +    NONE =>
    2.44 +      error ("No " ^ string_of_compilation compilation ^
    2.45 +        " functions defined for predicate " ^ quote name)
    2.46 +  | SOME fun_names => fun_names)
    2.47  
    2.48  fun function_name_of compilation ctxt name mode =
    2.49 -  case AList.lookup eq_mode
    2.50 -    (function_names_of compilation ctxt name) mode of
    2.51 -    NONE => error ("No " ^ string_of_compilation compilation
    2.52 -      ^ " function defined for mode " ^ string_of_mode mode ^ " of predicate " ^ quote name)
    2.53 -  | SOME function_name => function_name
    2.54 +  (case AList.lookup eq_mode (function_names_of compilation ctxt name) mode of
    2.55 +    NONE =>
    2.56 +      error ("No " ^ string_of_compilation compilation ^
    2.57 +        " function defined for mode " ^ string_of_mode mode ^ " of predicate " ^ quote name)
    2.58 +  | SOME function_name => function_name)
    2.59  
    2.60  fun modes_of compilation ctxt name = map fst (function_names_of compilation ctxt name)
    2.61  
    2.62 @@ -177,9 +181,10 @@
    2.63  
    2.64  val all_random_modes_of = all_modes_of Random
    2.65  
    2.66 -fun defined_functions compilation ctxt name = case lookup_pred_data ctxt name of
    2.67 +fun defined_functions compilation ctxt name =
    2.68 +  (case lookup_pred_data ctxt name of
    2.69      NONE => false
    2.70 -  | SOME data => AList.defined (op =) (#function_names data) compilation
    2.71 +  | SOME data => AList.defined (op =) (#function_names data) compilation)
    2.72  
    2.73  fun needs_random ctxt s m =
    2.74    member (op =) (#needs_random (the_pred_data ctxt s)) m
    2.75 @@ -189,10 +194,11 @@
    2.76      (AList.lookup eq_mode (#predfun_data (the_pred_data ctxt name)) mode)
    2.77  
    2.78  fun the_predfun_data ctxt name mode =
    2.79 -  case lookup_predfun_data ctxt name mode of
    2.80 -    NONE => error ("No function defined for mode " ^ string_of_mode mode ^
    2.81 -      " of predicate " ^ name)
    2.82 -  | SOME data => data;
    2.83 +  (case lookup_predfun_data ctxt name mode of
    2.84 +    NONE =>
    2.85 +      error ("No function defined for mode " ^ string_of_mode mode ^
    2.86 +        " of predicate " ^ name)
    2.87 +  | SOME data => data)
    2.88  
    2.89  val predfun_definition_of = #definition ooo the_predfun_data
    2.90  
    2.91 @@ -221,7 +227,8 @@
    2.92          val case_th =
    2.93            rewrite_rule ctxt (@{thm Predicate.eq_is_eq} :: map meta_eq_of eqs) (nth cases (i - 1))
    2.94          val prems' = maps (dest_conjunct_prem o rewrite_rule ctxt tuple_rew_rules) prems
    2.95 -        val pats = map (swap o HOLogic.dest_eq o HOLogic.dest_Trueprop) (take nargs (prems_of case_th))
    2.96 +        val pats =
    2.97 +          map (swap o HOLogic.dest_eq o HOLogic.dest_Trueprop) (take nargs (prems_of case_th))
    2.98          val case_th' = Thm.instantiate ([], inst_of_matches pats) case_th
    2.99            OF (replicate nargs @{thm refl})
   2.100          val thesis =
   2.101 @@ -242,6 +249,7 @@
   2.102      Goal.prove ctxt (Term.add_free_names cases_rule []) [] cases_rule (fn _ => tac)
   2.103    end
   2.104  
   2.105 +
   2.106  (* updaters *)
   2.107  
   2.108  (* fetching introduction rules or registering introduction rules *)
   2.109 @@ -249,7 +257,7 @@
   2.110  val no_compilation = ([], ([], []))
   2.111  
   2.112  fun fetch_pred_data ctxt name =
   2.113 -  case try (Inductive.the_inductive ctxt) name of
   2.114 +  (case try (Inductive.the_inductive ctxt) name of
   2.115      SOME (info as (_, result)) => 
   2.116        let
   2.117          fun is_intro_of intro =
   2.118 @@ -267,7 +275,7 @@
   2.119        in
   2.120          mk_pred_data (((map (pair NONE) intros, SOME elim), true), no_compilation)
   2.121        end
   2.122 -  | NONE => error ("No such predicate: " ^ quote name)
   2.123 +  | NONE => error ("No such predicate: " ^ quote name))
   2.124  
   2.125  fun add_predfun_data name mode data =
   2.126    let
   2.127 @@ -294,16 +302,19 @@
   2.128    let
   2.129      val (name, _) = dest_Const (fst (strip_intro_concl thm))
   2.130      fun cons_intro gr =
   2.131 -     case try (Graph.get_node gr) name of
   2.132 -       SOME _ => Graph.map_node name (map_pred_data
   2.133 -         (apfst (apfst (apfst (fn intros => intros @ [(opt_case_name, thm)]))))) gr
   2.134 -     | NONE => Graph.new_node (name, mk_pred_data ((([(opt_case_name, thm)], NONE), false), no_compilation)) gr
   2.135 +      (case try (Graph.get_node gr) name of
   2.136 +        SOME _ =>
   2.137 +          Graph.map_node name (map_pred_data
   2.138 +            (apfst (apfst (apfst (fn intros => intros @ [(opt_case_name, thm)]))))) gr
   2.139 +      | NONE =>
   2.140 +          Graph.new_node
   2.141 +            (name, mk_pred_data ((([(opt_case_name, thm)], NONE), false), no_compilation)) gr)
   2.142    in PredData.map cons_intro thy end
   2.143  
   2.144  fun set_elim thm =
   2.145    let
   2.146 -    val (name, _) = dest_Const (fst 
   2.147 -      (strip_comb (HOLogic.dest_Trueprop (hd (prems_of thm)))))
   2.148 +    val (name, _) =
   2.149 +      dest_Const (fst (strip_comb (HOLogic.dest_Trueprop (hd (prems_of thm)))))
   2.150    in PredData.map (Graph.map_node name (map_pred_data (apfst (apfst (apsnd (K (SOME thm))))))) end
   2.151  
   2.152  fun register_predicate (constname, intros, elim) thy =
   2.153 @@ -356,12 +367,14 @@
   2.154  
   2.155  fun extend' value_of edges_of key (G, visited) =
   2.156    let
   2.157 -    val (G', v) = case try (Graph.get_node G) key of
   2.158 +    val (G', v) =
   2.159 +      (case try (Graph.get_node G) key of
   2.160          SOME v => (G, v)
   2.161 -      | NONE => (Graph.new_node (key, value_of key) G, value_of key)
   2.162 -    val (G'', visited') = fold (extend' value_of edges_of)
   2.163 -      (subtract (op =) visited (edges_of (key, v)))
   2.164 -      (G', key :: visited)
   2.165 +      | NONE => (Graph.new_node (key, value_of key) G, value_of key))
   2.166 +    val (G'', visited') =
   2.167 +      fold (extend' value_of edges_of)
   2.168 +        (subtract (op =) visited (edges_of (key, v)))
   2.169 +        (G', key :: visited)
   2.170    in
   2.171      (fold (Graph.add_edge o (pair key)) (edges_of (key, v)) G'', visited')
   2.172    end;
   2.173 @@ -391,14 +404,15 @@
   2.174        end))))
   2.175      thy  
   2.176  
   2.177 +
   2.178  (* registration of alternative function names *)
   2.179  
   2.180  structure Alt_Compilations_Data = Theory_Data
   2.181  (
   2.182 -  type T = (mode * (compilation_funs -> typ -> term)) list Symtab.table;
   2.183 -  val empty = Symtab.empty;
   2.184 -  val extend = I;
   2.185 -  fun merge data : T = Symtab.merge (K true) data;
   2.186 +  type T = (mode * (compilation_funs -> typ -> term)) list Symtab.table
   2.187 +  val empty = Symtab.empty
   2.188 +  val extend = I
   2.189 +  fun merge data : T = Symtab.merge (K true) data
   2.190  );
   2.191  
   2.192  fun alternative_compilation_of_global thy pred_name mode =
   2.193 @@ -416,19 +430,21 @@
   2.194        (List.partition (fn (_, (_, random)) => random) compilations)
   2.195      val non_random_dummys = map (rpair "dummy") non_random_modes
   2.196      val all_dummys = map (rpair "dummy") modes
   2.197 -    val dummy_function_names = map (rpair all_dummys) Predicate_Compile_Aux.random_compilations
   2.198 -      @ map (rpair non_random_dummys) Predicate_Compile_Aux.non_random_compilations
   2.199 +    val dummy_function_names =
   2.200 +      map (rpair all_dummys) Predicate_Compile_Aux.random_compilations @
   2.201 +      map (rpair non_random_dummys) Predicate_Compile_Aux.non_random_compilations
   2.202      val alt_compilations = map (apsnd fst) compilations
   2.203    in
   2.204 -    PredData.map (Graph.new_node
   2.205 -      (pred_name, mk_pred_data ((([], SOME @{thm refl}), true), (dummy_function_names, ([], needs_random)))))
   2.206 +    PredData.map
   2.207 +      (Graph.new_node
   2.208 +        (pred_name,
   2.209 +          mk_pred_data ((([], SOME @{thm refl}), true), (dummy_function_names, ([], needs_random)))))
   2.210      #> Alt_Compilations_Data.map (Symtab.insert (K false) (pred_name, alt_compilations))
   2.211    end
   2.212  
   2.213  fun functional_compilation fun_name mode compfuns T =
   2.214    let
   2.215 -    val (inpTs, outpTs) = split_map_modeT (fn _ => fn T => (SOME T, NONE))
   2.216 -      mode (binder_types T)
   2.217 +    val (inpTs, outpTs) = split_map_modeT (fn _ => fn T => (SOME T, NONE)) mode (binder_types T)
   2.218      val bs = map (pair "x") inpTs
   2.219      val bounds = map Bound (rev (0 upto (length bs) - 1))
   2.220      val f = Const (fun_name, inpTs ---> HOLogic.mk_tupleT outpTs)
   2.221 @@ -443,4 +459,4 @@
   2.222      (map (fn (mode, (fun_name, random)) => (mode, (functional_compilation fun_name mode, random)))
   2.223      fun_names)
   2.224  
   2.225 -end;
   2.226 \ No newline at end of file
   2.227 +end
   2.228 \ No newline at end of file
     3.1 --- a/src/HOL/Tools/Predicate_Compile/mode_inference.ML	Wed Feb 12 13:31:18 2014 +0100
     3.2 +++ b/src/HOL/Tools/Predicate_Compile/mode_inference.ML	Wed Feb 12 13:33:05 2014 +0100
     3.3 @@ -71,8 +71,10 @@
     3.4  fun mode_of (Context m) = m
     3.5    | mode_of (Term m) = m
     3.6    | mode_of (Mode_App (d1, d2)) =
     3.7 -    (case mode_of d1 of Fun (m, m') =>
     3.8 -        (if eq_mode (m, mode_of d2) then m' else raise Fail "mode_of: derivation has mismatching modes")
     3.9 +      (case mode_of d1 of
    3.10 +        Fun (m, m') =>
    3.11 +          (if eq_mode (m, mode_of d2) then m'
    3.12 +           else raise Fail "mode_of: derivation has mismatching modes")
    3.13        | _ => raise Fail "mode_of: derivation has a non-functional mode")
    3.14    | mode_of (Mode_Pair (d1, d2)) =
    3.15      Pair (mode_of d1, mode_of d2)
    3.16 @@ -109,12 +111,12 @@
    3.17      (Syntax.string_of_term ctxt (HOLogic.mk_not t)) ^ "(negative premise)"
    3.18    | string_of_prem ctxt (Sidecond t) =
    3.19      (Syntax.string_of_term ctxt t) ^ "(sidecondition)"
    3.20 -  | string_of_prem ctxt _ = raise Fail "string_of_prem: unexpected input"
    3.21 +  | string_of_prem _ _ = raise Fail "string_of_prem: unexpected input"
    3.22  
    3.23  type mode_analysis_options =
    3.24    {use_generators : bool,
    3.25 -  reorder_premises : bool,
    3.26 -  infer_pos_and_neg_modes : bool}
    3.27 +   reorder_premises : bool,
    3.28 +   infer_pos_and_neg_modes : bool}
    3.29  
    3.30  (*** check if a type is an equality type (i.e. doesn't contain fun)
    3.31    FIXME this is only an approximation ***)
    3.32 @@ -134,7 +136,7 @@
    3.33  
    3.34  fun error_of p (_, m) is =
    3.35    "  Clauses " ^ commas (map (fn i => string_of_int (i + 1)) is) ^ " of " ^
    3.36 -        p ^ " violates mode " ^ string_of_mode m
    3.37 +  p ^ " violates mode " ^ string_of_mode m
    3.38  
    3.39  fun is_all_input mode =
    3.40    let
     4.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile.ML	Wed Feb 12 13:31:18 2014 +0100
     4.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile.ML	Wed Feb 12 13:33:05 2014 +0100
     4.3 @@ -24,18 +24,20 @@
     4.4  
     4.5  fun print_intross options thy msg intross =
     4.6    if show_intermediate_results options then
     4.7 -    tracing (msg ^ 
     4.8 -      (space_implode "\n" (map 
     4.9 +    tracing (msg ^
    4.10 +      (space_implode "\n" (map
    4.11          (fn (c, intros) => "Introduction rule(s) of " ^ c ^ ":\n" ^
    4.12             commas (map (Display.string_of_thm_global thy) intros)) intross)))
    4.13    else ()
    4.14 -      
    4.15 +
    4.16  fun print_specs options thy specs =
    4.17    if show_intermediate_results options then
    4.18 -    map (fn (c, thms) => "Constant " ^ c ^ " has specification:\n"
    4.19 -      ^ (space_implode "\n" (map (Display.string_of_thm_global thy) thms)) ^ "\n") specs
    4.20 +    map (fn (c, thms) =>
    4.21 +      "Constant " ^ c ^ " has specification:\n" ^
    4.22 +        (space_implode "\n" (map (Display.string_of_thm_global thy) thms)) ^ "\n") specs
    4.23      |> space_implode "\n" |> tracing
    4.24    else ()
    4.25 +
    4.26  fun overload_const thy s = the_default s (Option.map fst (Axclass.inst_of_param thy s))
    4.27  
    4.28  fun map_specs f specs =
    4.29 @@ -44,8 +46,12 @@
    4.30  fun process_specification options specs thy' =
    4.31    let
    4.32      val _ = print_step options "Compiling predicates to flat introrules..."
    4.33 -    val specs = map (apsnd (map
    4.34 -      (fn th => if is_equationlike th then Predicate_Compile_Data.normalize_equation thy' th else th))) specs
    4.35 +    val specs =
    4.36 +      map
    4.37 +        (apsnd (map
    4.38 +          (fn th =>
    4.39 +            if is_equationlike th then Predicate_Compile_Data.normalize_equation thy' th else th)))
    4.40 +        specs
    4.41      val (intross1, thy'') =
    4.42        apfst flat (fold_map (Predicate_Compile_Pred.preprocess options) specs thy')
    4.43      val _ = print_intross options thy'' "Flattened introduction rules: " intross1
    4.44 @@ -53,21 +59,24 @@
    4.45      val intross2 =
    4.46        if function_flattening options then
    4.47          if fail_safe_function_flattening options then
    4.48 -          case try (map_specs (maps (Predicate_Compile_Fun.rewrite_intro thy''))) intross1 of
    4.49 +          (case try (map_specs (maps (Predicate_Compile_Fun.rewrite_intro thy''))) intross1 of
    4.50              SOME intross => intross
    4.51            | NONE =>
    4.52              (if show_caught_failures options then tracing "Function replacement failed!" else ();
    4.53 -            intross1)
    4.54 +             intross1))
    4.55          else map_specs (maps (Predicate_Compile_Fun.rewrite_intro thy'')) intross1
    4.56        else
    4.57          intross1
    4.58      val _ = print_intross options thy'' "Introduction rules with replaced functions: " intross2
    4.59 -    val _ = print_step options "Introducing new constants for abstractions at higher-order argument positions..."
    4.60 -    val (intross3, (new_defs, thy''')) = Predicate_Compile_Pred.flat_higher_order_arguments (intross2, thy'')
    4.61 -    val (new_intross, thy'''')  =
    4.62 +    val _ = print_step options
    4.63 +      "Introducing new constants for abstractions at higher-order argument positions..."
    4.64 +    val (intross3, (new_defs, thy''')) =
    4.65 +      Predicate_Compile_Pred.flat_higher_order_arguments (intross2, thy'')
    4.66 +    val (new_intross, thy'''') =
    4.67        if not (null new_defs) then
    4.68          let
    4.69 -          val _ = print_step options "Recursively obtaining introduction rules for new definitions..."
    4.70 +          val _ =
    4.71 +            print_step options "Recursively obtaining introduction rules for new definitions..."
    4.72          in process_specification options new_defs thy''' end
    4.73        else ([], thy''')
    4.74    in
    4.75 @@ -75,9 +84,8 @@
    4.76    end
    4.77  
    4.78  fun preprocess_strong_conn_constnames options gr ts thy =
    4.79 -  if forall (fn (Const (c, _)) =>
    4.80 -      Core_Data.is_registered (Proof_Context.init_global thy) c) ts then
    4.81 -    thy
    4.82 +  if forall (fn (Const (c, _)) => Core_Data.is_registered (Proof_Context.init_global thy) c) ts
    4.83 +  then thy
    4.84    else
    4.85      let
    4.86        fun get_specs ts = map_filter (fn t =>
    4.87 @@ -94,9 +102,9 @@
    4.88        val (fun_pred_specs, thy1) =
    4.89          (if function_flattening options andalso (not (null funnames)) then
    4.90            if fail_safe_function_flattening options then
    4.91 -            case try (Predicate_Compile_Fun.define_predicates (get_specs funnames)) thy of
    4.92 +            (case try (Predicate_Compile_Fun.define_predicates (get_specs funnames)) thy of
    4.93                SOME (intross, thy) => (intross, thy)
    4.94 -            | NONE => ([], thy)
    4.95 +            | NONE => ([], thy))
    4.96            else Predicate_Compile_Fun.define_predicates (get_specs funnames) thy
    4.97          else ([], thy))
    4.98        val _ = print_specs options thy1 fun_pred_specs
    4.99 @@ -111,8 +119,9 @@
   4.100          map (fn (s, ths) => (overload_const thy2 s, map (Axclass.overload thy2) ths)) intross5
   4.101        val intross7 = map_specs (map (expand_tuples thy2)) intross6
   4.102        val intross8 = map_specs (map (eta_contract_ho_arguments thy2)) intross7
   4.103 -      val _ = case !intro_hook of NONE => () | SOME f => (map_specs (map (f thy2)) intross8; ())
   4.104 -      val _ = print_step options ("Looking for specialisations in " ^ commas (map fst intross8) ^ "...")
   4.105 +      val _ = (case !intro_hook of NONE => () | SOME f => (map_specs (map (f thy2)) intross8; ()))
   4.106 +      val _ =
   4.107 +        print_step options ("Looking for specialisations in " ^ commas (map fst intross8) ^ "...")
   4.108        val (intross9, thy3) =
   4.109          if specialise options then
   4.110            Predicate_Compile_Specialisation.find_specialisations [] intross8 thy2
   4.111 @@ -129,14 +138,17 @@
   4.112  fun preprocess options t thy =
   4.113    let
   4.114      val _ = print_step options "Fetching definitions from theory..."
   4.115 -    val gr = cond_timeit (Config.get_global thy Quickcheck.timing) "preprocess-obtain graph"
   4.116 -          (fn () => Predicate_Compile_Data.obtain_specification_graph options thy t
   4.117 +    val gr =
   4.118 +      cond_timeit (Config.get_global thy Quickcheck.timing) "preprocess-obtain graph"
   4.119 +        (fn () =>
   4.120 +          Predicate_Compile_Data.obtain_specification_graph options thy t
   4.121            |> (fn gr => Term_Graph.restrict (member (op =) (Term_Graph.all_succs gr [t])) gr))
   4.122      val _ = if !present_graph then Predicate_Compile_Data.present_graph gr else ()
   4.123    in
   4.124      cond_timeit (Config.get_global thy Quickcheck.timing) "preprocess-process"
   4.125 -      (fn () => (fold_rev (preprocess_strong_conn_constnames options gr)
   4.126 -        (Term_Graph.strong_conn gr) thy))
   4.127 +      (fn () =>
   4.128 +        fold_rev (preprocess_strong_conn_constnames options gr)
   4.129 +          (Term_Graph.strong_conn gr) thy)
   4.130    end
   4.131  
   4.132  datatype proposed_modes = Multiple_Preds of (string * (mode * string option) list) list
   4.133 @@ -145,14 +157,15 @@
   4.134  fun extract_options lthy (((expected_modes, proposed_modes), (compilation, raw_options)), const) =
   4.135    let
   4.136      fun chk s = member (op =) raw_options s
   4.137 -    val proposed_modes = case proposed_modes of
   4.138 -          Single_Pred proposed_modes => [(const, proposed_modes)]
   4.139 -        | Multiple_Preds proposed_modes => map
   4.140 -          (apfst (Code.read_const (Proof_Context.theory_of lthy))) proposed_modes
   4.141 +    val proposed_modes =
   4.142 +      (case proposed_modes of
   4.143 +        Single_Pred proposed_modes => [(const, proposed_modes)]
   4.144 +      | Multiple_Preds proposed_modes =>
   4.145 +          map (apfst (Code.read_const (Proof_Context.theory_of lthy))) proposed_modes)
   4.146    in
   4.147      Options {
   4.148        expected_modes = Option.map (pair const) expected_modes,
   4.149 -      proposed_modes = 
   4.150 +      proposed_modes =
   4.151          map (apsnd (map fst)) proposed_modes,
   4.152        proposed_names =
   4.153          maps (fn (predname, ms) => (map_filter
   4.154 @@ -190,15 +203,14 @@
   4.155        let
   4.156          val lthy' = Local_Theory.background_theory (preprocess options t) lthy
   4.157          val const =
   4.158 -          case Predicate_Compile_Fun.pred_of_function (Proof_Context.theory_of lthy') const of
   4.159 +          (case Predicate_Compile_Fun.pred_of_function (Proof_Context.theory_of lthy') const of
   4.160              SOME c => c
   4.161 -          | NONE => const
   4.162 +          | NONE => const)
   4.163          val _ = print_step options "Starting Predicate Compile Core..."
   4.164        in
   4.165          Predicate_Compile_Core.code_pred options const lthy'
   4.166        end
   4.167 -    else
   4.168 -      Predicate_Compile_Core.code_pred_cmd options raw_const lthy
   4.169 +    else Predicate_Compile_Core.code_pred_cmd options raw_const lthy
   4.170    end
   4.171  
   4.172  val setup = Predicate_Compile_Core.setup
   4.173 @@ -210,10 +222,11 @@
   4.174    (Args.$$$ "i" >> K Input || Args.$$$ "o" >> K Output ||
   4.175      Args.$$$ "bool" >> K Bool || Args.$$$ "(" |-- parse_mode_expr --| Args.$$$ ")") xs
   4.176  and parse_mode_tuple_expr xs =
   4.177 -  (parse_mode_basic_expr --| (Args.$$$ "*" || Args.$$$ "\<times>") -- parse_mode_tuple_expr >> Pair || parse_mode_basic_expr)
   4.178 -    xs
   4.179 +  (parse_mode_basic_expr --| (Args.$$$ "*" || Args.$$$ "\<times>") -- parse_mode_tuple_expr >> Pair ||
   4.180 +    parse_mode_basic_expr) xs
   4.181  and parse_mode_expr xs =
   4.182 -  (parse_mode_tuple_expr --| (Args.$$$ "=>" || Args.$$$ "\<Rightarrow>") -- parse_mode_expr >> Fun || parse_mode_tuple_expr) xs
   4.183 +  (parse_mode_tuple_expr --| (Args.$$$ "=>" || Args.$$$ "\<Rightarrow>") -- parse_mode_expr >> Fun ||
   4.184 +    parse_mode_tuple_expr) xs
   4.185  
   4.186  val mode_and_opt_proposal = parse_mode_expr --
   4.187    Scan.optional (Args.$$$ "as" |-- Parse.xname >> SOME) NONE
   4.188 @@ -230,6 +243,7 @@
   4.189    Scan.optional (@{keyword "("} |-- Args.$$$ "expected_modes" |-- @{keyword ":"} |--
   4.190      Parse.enum "," parse_mode_expr --| @{keyword ")"} >> SOME) NONE
   4.191  
   4.192 +
   4.193  (* Parser for options *)
   4.194  
   4.195  val scan_options =
   4.196 @@ -243,7 +257,7 @@
   4.197    end
   4.198  
   4.199  val opt_print_modes =
   4.200 -  Scan.optional (@{keyword "("} |-- Parse.!!! (Scan.repeat1 Parse.xname --| @{keyword ")"})) [];
   4.201 +  Scan.optional (@{keyword "("} |-- Parse.!!! (Scan.repeat1 Parse.xname --| @{keyword ")"})) []
   4.202  
   4.203  val opt_mode = (Args.$$$ "_" >> K NONE) || (parse_mode_expr >> SOME)
   4.204  
   4.205 @@ -267,6 +281,7 @@
   4.206        ((NONE, false), (Pred, []))
   4.207    end
   4.208  
   4.209 +
   4.210  (* code_pred command and values command *)
   4.211  
   4.212  val _ =
     5.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_aux.ML	Wed Feb 12 13:31:18 2014 +0100
     5.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_aux.ML	Wed Feb 12 13:33:05 2014 +0100
     5.3 @@ -89,17 +89,17 @@
     5.4    val funT_of : compilation_funs -> mode -> typ -> typ
     5.5    (* Different compilations *)
     5.6    datatype compilation = Pred | Depth_Limited | Random | Depth_Limited_Random | DSeq | Annotated
     5.7 -    | Pos_Random_DSeq | Neg_Random_DSeq | New_Pos_Random_DSeq | New_Neg_Random_DSeq 
     5.8 +    | Pos_Random_DSeq | Neg_Random_DSeq | New_Pos_Random_DSeq | New_Neg_Random_DSeq
     5.9      | Pos_Generator_DSeq | Neg_Generator_DSeq | Pos_Generator_CPS | Neg_Generator_CPS
    5.10    val negative_compilation_of : compilation -> compilation
    5.11    val compilation_for_polarity : bool -> compilation -> compilation
    5.12 -  val is_depth_limited_compilation : compilation -> bool 
    5.13 +  val is_depth_limited_compilation : compilation -> bool
    5.14    val string_of_compilation : compilation -> string
    5.15    val compilation_names : (string * compilation) list
    5.16    val non_random_compilations : compilation list
    5.17    val random_compilations : compilation list
    5.18    (* Different options for compiler *)
    5.19 -  datatype options = Options of {  
    5.20 +  datatype options = Options of {
    5.21      expected_modes : (string * mode list) option,
    5.22      proposed_modes : (string * mode list) list,
    5.23      proposed_names : ((string * mode) * string) list,
    5.24 @@ -161,7 +161,7 @@
    5.25    val unify_consts : theory -> term list -> term list -> (term list * term list)
    5.26    val mk_casesrule : Proof.context -> term -> thm list -> term
    5.27    val preprocess_intro : theory -> thm -> thm
    5.28 -  
    5.29 +
    5.30    val define_quickcheck_predicate :
    5.31      term -> theory -> (((string * typ) * (string * typ) list) * thm) * theory
    5.32  end;
    5.33 @@ -211,7 +211,7 @@
    5.34    | mode_ord (Bool, Bool) = EQUAL
    5.35    | mode_ord (Pair (m1, m2), Pair (m3, m4)) = prod_ord mode_ord mode_ord ((m1, m2), (m3, m4))
    5.36    | mode_ord (Fun (m1, m2), Fun (m3, m4)) = prod_ord mode_ord mode_ord ((m1, m2), (m3, m4))
    5.37 - 
    5.38 +
    5.39  fun list_fun_mode [] = Bool
    5.40    | list_fun_mode (m :: ms) = Fun (m, list_fun_mode ms)
    5.41  
    5.42 @@ -227,7 +227,7 @@
    5.43  fun dest_tuple_mode (Pair (mode, mode')) = mode :: dest_tuple_mode mode'
    5.44    | dest_tuple_mode _ = []
    5.45  
    5.46 -fun all_modes_of_typ' (T as Type ("fun", _)) = 
    5.47 +fun all_modes_of_typ' (T as Type ("fun", _)) =
    5.48    let
    5.49      val (S, U) = strip_type T
    5.50    in
    5.51 @@ -237,7 +237,7 @@
    5.52      else
    5.53        [Input, Output]
    5.54    end
    5.55 -  | all_modes_of_typ' (Type (@{type_name Product_Type.prod}, [T1, T2])) = 
    5.56 +  | all_modes_of_typ' (Type (@{type_name Product_Type.prod}, [T1, T2])) =
    5.57      map_product (curry Pair) (all_modes_of_typ' T1) (all_modes_of_typ' T2)
    5.58    | all_modes_of_typ' _ = [Input, Output]
    5.59  
    5.60 @@ -258,7 +258,7 @@
    5.61  fun all_smodes_of_typ (T as Type ("fun", _)) =
    5.62    let
    5.63      val (S, U) = strip_type T
    5.64 -    fun all_smodes (Type (@{type_name Product_Type.prod}, [T1, T2])) = 
    5.65 +    fun all_smodes (Type (@{type_name Product_Type.prod}, [T1, T2])) =
    5.66        map_product (curry Pair) (all_smodes T1) (all_smodes T2)
    5.67        | all_smodes _ = [Input, Output]
    5.68    in
    5.69 @@ -291,8 +291,9 @@
    5.70  
    5.71  fun ho_args_of_typ T ts =
    5.72    let
    5.73 -    fun ho_arg (T as Type("fun", [_,_])) (SOME t) = if body_type T = @{typ bool} then [t] else []
    5.74 -      | ho_arg (Type("fun", [_,_])) NONE = raise Fail "mode and term do not match"
    5.75 +    fun ho_arg (T as Type ("fun", [_, _])) (SOME t) =
    5.76 +          if body_type T = @{typ bool} then [t] else []
    5.77 +      | ho_arg (Type ("fun", [_, _])) NONE = raise Fail "mode and term do not match"
    5.78        | ho_arg (Type(@{type_name "Product_Type.prod"}, [T1, T2]))
    5.79           (SOME (Const (@{const_name Pair}, _) $ t1 $ t2)) =
    5.80            ho_arg T1 (SOME t1) @ ho_arg T2 (SOME t2)
    5.81 @@ -306,25 +307,25 @@
    5.82  fun ho_argsT_of_typ Ts =
    5.83    let
    5.84      fun ho_arg (T as Type("fun", [_,_])) = if body_type T = @{typ bool} then [T] else []
    5.85 -      | ho_arg (Type(@{type_name "Product_Type.prod"}, [T1, T2])) =
    5.86 +      | ho_arg (Type (@{type_name "Product_Type.prod"}, [T1, T2])) =
    5.87            ho_arg T1 @ ho_arg T2
    5.88        | ho_arg _ = []
    5.89    in
    5.90      maps ho_arg Ts
    5.91    end
    5.92 -  
    5.93 +
    5.94  
    5.95  (* temporary function should be replaced by unsplit_input or so? *)
    5.96  fun replace_ho_args mode hoargs ts =
    5.97    let
    5.98      fun replace (Fun _, _) (arg' :: hoargs') = (arg', hoargs')
    5.99        | replace (Pair (m1, m2), Const (@{const_name Pair}, T) $ t1 $ t2) hoargs =
   5.100 -        let
   5.101 -          val (t1', hoargs') = replace (m1, t1) hoargs
   5.102 -          val (t2', hoargs'') = replace (m2, t2) hoargs'
   5.103 -        in
   5.104 -          (Const (@{const_name Pair}, T) $ t1' $ t2', hoargs'')
   5.105 -        end
   5.106 +          let
   5.107 +            val (t1', hoargs') = replace (m1, t1) hoargs
   5.108 +            val (t2', hoargs'') = replace (m2, t2) hoargs'
   5.109 +          in
   5.110 +            (Const (@{const_name Pair}, T) $ t1' $ t2', hoargs'')
   5.111 +          end
   5.112        | replace (_, t) hoargs = (t, hoargs)
   5.113    in
   5.114      fst (fold_map replace (strip_fun_mode mode ~~ ts) hoargs)
   5.115 @@ -333,7 +334,8 @@
   5.116  fun ho_argsT_of mode Ts =
   5.117    let
   5.118      fun ho_arg (Fun _) T = [T]
   5.119 -      | ho_arg (Pair (m1, m2)) (Type (@{type_name Product_Type.prod}, [T1, T2])) = ho_arg m1 T1 @ ho_arg m2 T2
   5.120 +      | ho_arg (Pair (m1, m2)) (Type (@{type_name Product_Type.prod}, [T1, T2])) =
   5.121 +          ho_arg m1 T1 @ ho_arg m2 T2
   5.122        | ho_arg _ _ = []
   5.123    in
   5.124      flat (map2 ho_arg (strip_fun_mode mode) Ts)
   5.125 @@ -379,28 +381,28 @@
   5.126  fun split_mode mode ts = split_map_mode (fn _ => fn _ => (NONE, NONE)) mode ts
   5.127  
   5.128  fun fold_map_aterms_prodT comb f (Type (@{type_name Product_Type.prod}, [T1, T2])) s =
   5.129 -  let
   5.130 -    val (x1, s') = fold_map_aterms_prodT comb f T1 s
   5.131 -    val (x2, s'') = fold_map_aterms_prodT comb f T2 s'
   5.132 -  in
   5.133 -    (comb x1 x2, s'')
   5.134 -  end
   5.135 -  | fold_map_aterms_prodT comb f T s = f T s
   5.136 +      let
   5.137 +        val (x1, s') = fold_map_aterms_prodT comb f T1 s
   5.138 +        val (x2, s'') = fold_map_aterms_prodT comb f T2 s'
   5.139 +      in
   5.140 +        (comb x1 x2, s'')
   5.141 +      end
   5.142 +  | fold_map_aterms_prodT _ f T s = f T s
   5.143  
   5.144  fun map_filter_prod f (Const (@{const_name Pair}, _) $ t1 $ t2) =
   5.145 -  comb_option HOLogic.mk_prod (map_filter_prod f t1, map_filter_prod f t2)
   5.146 +      comb_option HOLogic.mk_prod (map_filter_prod f t1, map_filter_prod f t2)
   5.147    | map_filter_prod f t = f t
   5.148 -  
   5.149 +
   5.150  fun split_modeT mode Ts =
   5.151    let
   5.152      fun split_arg_mode (Fun _) _ = ([], [])
   5.153        | split_arg_mode (Pair (m1, m2)) (Type (@{type_name Product_Type.prod}, [T1, T2])) =
   5.154 -        let
   5.155 -          val (i1, o1) = split_arg_mode m1 T1
   5.156 -          val (i2, o2) = split_arg_mode m2 T2
   5.157 -        in
   5.158 -          (i1 @ i2, o1 @ o2)
   5.159 -        end
   5.160 +          let
   5.161 +            val (i1, o1) = split_arg_mode m1 T1
   5.162 +            val (i2, o2) = split_arg_mode m2 T2
   5.163 +          in
   5.164 +            (i1 @ i2, o1 @ o2)
   5.165 +          end
   5.166        | split_arg_mode Input T = ([T], [])
   5.167        | split_arg_mode Output T = ([], [T])
   5.168        | split_arg_mode _ _ = raise Fail "split_modeT: mode and type do not match"
   5.169 @@ -427,7 +429,7 @@
   5.170        | ascii_string_of_mode' Bool = "b"
   5.171        | ascii_string_of_mode' (Pair (m1, m2)) =
   5.172            "P" ^ ascii_string_of_mode' m1 ^ ascii_string_of_mode'_Pair m2
   5.173 -      | ascii_string_of_mode' (Fun (m1, m2)) = 
   5.174 +      | ascii_string_of_mode' (Fun (m1, m2)) =
   5.175            "F" ^ ascii_string_of_mode' m1 ^ ascii_string_of_mode'_Fun m2 ^ "B"
   5.176      and ascii_string_of_mode'_Fun (Fun (m1, m2)) =
   5.177            ascii_string_of_mode' m1 ^ (if m2 = Bool then "" else "_" ^ ascii_string_of_mode'_Fun m2)
   5.178 @@ -438,10 +440,11 @@
   5.179        | ascii_string_of_mode'_Pair m = ascii_string_of_mode' m
   5.180    in ascii_string_of_mode'_Fun mode' end
   5.181  
   5.182 +
   5.183  (* premises *)
   5.184  
   5.185 -datatype indprem = Prem of term | Negprem of term | Sidecond of term
   5.186 -  | Generator of (string * typ);
   5.187 +datatype indprem =
   5.188 +  Prem of term | Negprem of term | Sidecond of term | Generator of (string * typ)
   5.189  
   5.190  fun dest_indprem (Prem t) = t
   5.191    | dest_indprem (Negprem t) = t
   5.192 @@ -453,25 +456,28 @@
   5.193    | map_indprem f (Sidecond t) = Sidecond (f t)
   5.194    | map_indprem f (Generator (v, T)) = Generator (dest_Free (f (Free (v, T))))
   5.195  
   5.196 +
   5.197  (* general syntactic functions *)
   5.198  
   5.199  fun is_equationlike_term (Const ("==", _) $ _ $ _) = true
   5.200 -  | is_equationlike_term (Const (@{const_name Trueprop}, _) $ (Const (@{const_name HOL.eq}, _) $ _ $ _)) = true
   5.201 +  | is_equationlike_term
   5.202 +      (Const (@{const_name Trueprop}, _) $ (Const (@{const_name HOL.eq}, _) $ _ $ _)) = true
   5.203    | is_equationlike_term _ = false
   5.204 -  
   5.205 -val is_equationlike = is_equationlike_term o prop_of 
   5.206 +
   5.207 +val is_equationlike = is_equationlike_term o prop_of
   5.208  
   5.209  fun is_pred_equation_term (Const ("==", _) $ u $ v) =
   5.210 -  (fastype_of u = @{typ bool}) andalso (fastype_of v = @{typ bool})
   5.211 +      (fastype_of u = @{typ bool}) andalso (fastype_of v = @{typ bool})
   5.212    | is_pred_equation_term _ = false
   5.213 -  
   5.214 -val is_pred_equation = is_pred_equation_term o prop_of 
   5.215 +
   5.216 +val is_pred_equation = is_pred_equation_term o prop_of
   5.217  
   5.218  fun is_intro_term constname t =
   5.219 -  the_default false (try (fn t => case fst (strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl t))) of
   5.220 -    Const (c, _) => c = constname
   5.221 -  | _ => false) t)
   5.222 -  
   5.223 +  the_default false (try (fn t =>
   5.224 +    case fst (strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl t))) of
   5.225 +      Const (c, _) => c = constname
   5.226 +    | _ => false) t)
   5.227 +
   5.228  fun is_intro constname t = is_intro_term constname (prop_of t)
   5.229  
   5.230  fun is_predT (T as Type("fun", [_, _])) = (body_type T = @{typ bool})
   5.231 @@ -486,14 +492,17 @@
   5.232      val cnstrs = flat (maps
   5.233        (map (fn (_, (Tname, _, cs)) => map (apsnd (rpair Tname o length)) cs) o #descr o snd)
   5.234        (Symtab.dest (Datatype.get_all thy)));
   5.235 -    fun check t = (case strip_comb t of
   5.236 +    fun check t =
   5.237 +      (case strip_comb t of
   5.238          (Var _, []) => true
   5.239        | (Free _, []) => true
   5.240 -      | (Const (s, T), ts) => (case (AList.lookup (op =) cnstrs s, body_type T) of
   5.241 -            (SOME (i, Tname), Type (Tname', _)) => length ts = i andalso Tname = Tname' andalso forall check ts
   5.242 +      | (Const (s, T), ts) =>
   5.243 +          (case (AList.lookup (op =) cnstrs s, body_type T) of
   5.244 +            (SOME (i, Tname), Type (Tname', _)) =>
   5.245 +              length ts = i andalso Tname = Tname' andalso forall check ts
   5.246            | _ => false)
   5.247        | _ => false)
   5.248 -  in check end;
   5.249 +  in check end
   5.250  
   5.251  (* returns true if t is an application of an datatype constructor *)
   5.252  (* which then consequently would be splitted *)
   5.253 @@ -512,35 +521,37 @@
   5.254    else false
   5.255  *)
   5.256  
   5.257 -val is_constr = Code.is_constr o Proof_Context.theory_of;
   5.258 +val is_constr = Code.is_constr o Proof_Context.theory_of
   5.259  
   5.260  fun strip_all t = (Term.strip_all_vars t, Term.strip_all_body t)
   5.261  
   5.262  fun strip_ex (Const (@{const_name Ex}, _) $ Abs (x, T, t)) =
   5.263 -  let
   5.264 -    val (xTs, t') = strip_ex t
   5.265 -  in
   5.266 -    ((x, T) :: xTs, t')
   5.267 -  end
   5.268 +      let
   5.269 +        val (xTs, t') = strip_ex t
   5.270 +      in
   5.271 +        ((x, T) :: xTs, t')
   5.272 +      end
   5.273    | strip_ex t = ([], t)
   5.274  
   5.275  fun focus_ex t nctxt =
   5.276    let
   5.277 -    val ((xs, Ts), t') = apfst split_list (strip_ex t) 
   5.278 +    val ((xs, Ts), t') = apfst split_list (strip_ex t)
   5.279      val (xs', nctxt') = fold_map Name.variant xs nctxt;
   5.280      val ps' = xs' ~~ Ts;
   5.281      val vs = map Free ps';
   5.282      val t'' = Term.subst_bounds (rev vs, t');
   5.283 -  in ((ps', t''), nctxt') end;
   5.284 +  in ((ps', t''), nctxt') end
   5.285  
   5.286 -val strip_intro_concl = (strip_comb o HOLogic.dest_Trueprop o Logic.strip_imp_concl o prop_of)
   5.287 -  
   5.288 +val strip_intro_concl = strip_comb o HOLogic.dest_Trueprop o Logic.strip_imp_concl o prop_of
   5.289 +
   5.290 +
   5.291  (* introduction rule combinators *)
   5.292  
   5.293 -fun map_atoms f intro = 
   5.294 +fun map_atoms f intro =
   5.295    let
   5.296      val (literals, head) = Logic.strip_horn intro
   5.297 -    fun appl t = (case t of
   5.298 +    fun appl t =
   5.299 +      (case t of
   5.300          (@{term Not} $ t') => HOLogic.mk_not (f t')
   5.301        | _ => f t)
   5.302    in
   5.303 @@ -551,16 +562,18 @@
   5.304  fun fold_atoms f intro s =
   5.305    let
   5.306      val (literals, _) = Logic.strip_horn intro
   5.307 -    fun appl t s = (case t of
   5.308 -      (@{term Not} $ t') => f t' s
   5.309 +    fun appl t s =
   5.310 +      (case t of
   5.311 +        (@{term Not} $ t') => f t' s
   5.312        | _ => f t s)
   5.313    in fold appl (map HOLogic.dest_Trueprop literals) s end
   5.314  
   5.315  fun fold_map_atoms f intro s =
   5.316    let
   5.317      val (literals, head) = Logic.strip_horn intro
   5.318 -    fun appl t s = (case t of
   5.319 -      (@{term Not} $ t') => apfst HOLogic.mk_not (f t' s)
   5.320 +    fun appl t s =
   5.321 +      (case t of
   5.322 +        (@{term Not} $ t') => apfst HOLogic.mk_not (f t' s)
   5.323        | _ => f t s)
   5.324      val (literals', s') = fold_map appl (map HOLogic.dest_Trueprop literals) s
   5.325    in
   5.326 @@ -588,12 +601,14 @@
   5.327      Logic.list_implies (premises, f head)
   5.328    end
   5.329  
   5.330 +
   5.331  (* combinators to apply a function to all basic parts of nested products *)
   5.332  
   5.333  fun map_products f (Const (@{const_name Pair}, T) $ t1 $ t2) =
   5.334    Const (@{const_name Pair}, T) $ map_products f t1 $ map_products f t2
   5.335    | map_products f t = f t
   5.336  
   5.337 +
   5.338  (* split theorems of case expressions *)
   5.339  
   5.340  fun prepare_split_thm ctxt split_thm =
   5.341 @@ -602,7 +617,8 @@
   5.342        @{thm atomize_all[symmetric]}, @{thm atomize_imp[symmetric]}]
   5.343  
   5.344  fun find_split_thm thy (Const (name, _)) = Option.map #split (Datatype.info_of_case thy name)
   5.345 -  | find_split_thm thy _ = NONE
   5.346 +  | find_split_thm _ _ = NONE
   5.347 +
   5.348  
   5.349  (* lifting term operations to theorems *)
   5.350  
   5.351 @@ -612,10 +628,11 @@
   5.352  (*
   5.353  fun equals_conv lhs_cv rhs_cv ct =
   5.354    case Thm.term_of ct of
   5.355 -    Const ("==", _) $ _ $ _ => Conv.arg_conv cv ct  
   5.356 -  | _ => error "equals_conv"  
   5.357 +    Const ("==", _) $ _ $ _ => Conv.arg_conv cv ct
   5.358 +  | _ => error "equals_conv"
   5.359  *)
   5.360  
   5.361 +
   5.362  (* Different compilations *)
   5.363  
   5.364  datatype compilation = Pred | Depth_Limited | Random | Depth_Limited_Random | DSeq | Annotated
   5.365 @@ -629,9 +646,9 @@
   5.366    | negative_compilation_of Pos_Generator_DSeq = Neg_Generator_DSeq
   5.367    | negative_compilation_of Neg_Generator_DSeq = Pos_Generator_DSeq
   5.368    | negative_compilation_of Pos_Generator_CPS = Neg_Generator_CPS
   5.369 -  | negative_compilation_of Neg_Generator_CPS = Pos_Generator_CPS  
   5.370 +  | negative_compilation_of Neg_Generator_CPS = Pos_Generator_CPS
   5.371    | negative_compilation_of c = c
   5.372 -  
   5.373 +
   5.374  fun compilation_for_polarity false Pos_Random_DSeq = Neg_Random_DSeq
   5.375    | compilation_for_polarity false New_Pos_Random_DSeq = New_Neg_Random_DSeq
   5.376    | compilation_for_polarity _ c = c
   5.377 @@ -641,7 +658,7 @@
   5.378    (c = Pos_Generator_DSeq) orelse (c = Pos_Generator_DSeq)
   5.379  
   5.380  fun string_of_compilation c =
   5.381 -  case c of
   5.382 +  (case c of
   5.383      Pred => ""
   5.384    | Random => "random"
   5.385    | Depth_Limited => "depth limited"
   5.386 @@ -655,9 +672,10 @@
   5.387    | Pos_Generator_DSeq => "pos_generator_dseq"
   5.388    | Neg_Generator_DSeq => "neg_generator_dseq"
   5.389    | Pos_Generator_CPS => "pos_generator_cps"
   5.390 -  | Neg_Generator_CPS => "neg_generator_cps"
   5.391 -  
   5.392 -val compilation_names = [("pred", Pred),
   5.393 +  | Neg_Generator_CPS => "neg_generator_cps")
   5.394 +
   5.395 +val compilation_names =
   5.396 + [("pred", Pred),
   5.397    ("random", Random),
   5.398    ("depth_limited", Depth_Limited),
   5.399    ("depth_limited_random", Depth_Limited_Random),
   5.400 @@ -675,6 +693,7 @@
   5.401    Pos_Random_DSeq, Neg_Random_DSeq, New_Pos_Random_DSeq, New_Neg_Random_DSeq,
   5.402    Pos_Generator_CPS, Neg_Generator_CPS]
   5.403  
   5.404 +
   5.405  (* datastructures and setup for generic compilation *)
   5.406  
   5.407  datatype compilation_funs = CompilationFuns of {
   5.408 @@ -688,7 +707,7 @@
   5.409    mk_iterate_upto : typ -> term * term * term -> term,
   5.410    mk_not : term -> term,
   5.411    mk_map : typ -> typ -> term -> term -> term
   5.412 -};
   5.413 +}
   5.414  
   5.415  fun mk_monadT (CompilationFuns funs) = #mk_monadT funs
   5.416  fun dest_monadT (CompilationFuns funs) = #dest_monadT funs
   5.417 @@ -701,19 +720,22 @@
   5.418  fun mk_not (CompilationFuns funs) = #mk_not funs
   5.419  fun mk_map (CompilationFuns funs) = #mk_map funs
   5.420  
   5.421 +
   5.422  (** function types and names of different compilations **)
   5.423  
   5.424  fun funT_of compfuns mode T =
   5.425    let
   5.426      val Ts = binder_types T
   5.427 -    val (inTs, outTs) = split_map_modeT (fn m => fn T => (SOME (funT_of compfuns m T), NONE)) mode Ts
   5.428 +    val (inTs, outTs) =
   5.429 +      split_map_modeT (fn m => fn T => (SOME (funT_of compfuns m T), NONE)) mode Ts
   5.430    in
   5.431      inTs ---> (mk_monadT compfuns (HOLogic.mk_tupleT outTs))
   5.432 -  end;
   5.433 +  end
   5.434 +
   5.435  
   5.436  (* Different options for compiler *)
   5.437  
   5.438 -datatype options = Options of {  
   5.439 +datatype options = Options of {
   5.440    expected_modes : (string * mode list) option,
   5.441    proposed_modes : (string * mode list) list,
   5.442    proposed_names : ((string * mode) * string) list,
   5.443 @@ -735,7 +757,7 @@
   5.444    detect_switches : bool,
   5.445    smart_depth_limiting : bool,
   5.446    compilation : compilation
   5.447 -};
   5.448 +}
   5.449  
   5.450  fun expected_modes (Options opt) = #expected_modes opt
   5.451  fun proposed_modes (Options opt) = AList.lookup (op =) (#proposed_modes opt)
   5.452 @@ -798,33 +820,37 @@
   5.453  fun print_step options s =
   5.454    if show_steps options then tracing s else ()
   5.455  
   5.456 +
   5.457  (* simple transformations *)
   5.458  
   5.459  (** tuple processing **)
   5.460  
   5.461  fun rewrite_args [] (pats, intro_t, ctxt) = (pats, intro_t, ctxt)
   5.462 -  | rewrite_args (arg::args) (pats, intro_t, ctxt) = 
   5.463 -    (case HOLogic.strip_tupleT (fastype_of arg) of
   5.464 -      (_ :: _ :: _) =>
   5.465 -      let
   5.466 -        fun rewrite_arg' (Const (@{const_name Pair}, _) $ _ $ t2, Type (@{type_name Product_Type.prod}, [_, T2]))
   5.467 -          (args, (pats, intro_t, ctxt)) = rewrite_arg' (t2, T2) (args, (pats, intro_t, ctxt))
   5.468 -          | rewrite_arg' (t, Type (@{type_name Product_Type.prod}, [T1, T2])) (args, (pats, intro_t, ctxt)) =
   5.469 -            let
   5.470 -              val thy = Proof_Context.theory_of ctxt
   5.471 -              val ([x, y], ctxt') = Variable.variant_fixes ["x", "y"] ctxt
   5.472 -              val pat = (t, HOLogic.mk_prod (Free (x, T1), Free (y, T2)))
   5.473 -              val intro_t' = Pattern.rewrite_term thy [pat] [] intro_t
   5.474 -              val args' = map (Pattern.rewrite_term thy [pat] []) args
   5.475 -            in
   5.476 -              rewrite_arg' (Free (y, T2), T2) (args', (pat::pats, intro_t', ctxt'))
   5.477 -            end
   5.478 -          | rewrite_arg' _ (args, (pats, intro_t, ctxt)) = (args, (pats, intro_t, ctxt))
   5.479 -        val (args', (pats, intro_t', ctxt')) = rewrite_arg' (arg, fastype_of arg)
   5.480 -          (args, (pats, intro_t, ctxt))
   5.481 -      in
   5.482 -        rewrite_args args' (pats, intro_t', ctxt')
   5.483 -      end
   5.484 +  | rewrite_args (arg::args) (pats, intro_t, ctxt) =
   5.485 +      (case HOLogic.strip_tupleT (fastype_of arg) of
   5.486 +        (_ :: _ :: _) =>
   5.487 +        let
   5.488 +          fun rewrite_arg'
   5.489 +                (Const (@{const_name Pair}, _) $ _ $ t2, Type (@{type_name Product_Type.prod}, [_, T2]))
   5.490 +                (args, (pats, intro_t, ctxt)) =
   5.491 +                rewrite_arg' (t2, T2) (args, (pats, intro_t, ctxt))
   5.492 +            | rewrite_arg'
   5.493 +                (t, Type (@{type_name Product_Type.prod}, [T1, T2])) (args, (pats, intro_t, ctxt)) =
   5.494 +                let
   5.495 +                  val thy = Proof_Context.theory_of ctxt
   5.496 +                  val ([x, y], ctxt') = Variable.variant_fixes ["x", "y"] ctxt
   5.497 +                  val pat = (t, HOLogic.mk_prod (Free (x, T1), Free (y, T2)))
   5.498 +                  val intro_t' = Pattern.rewrite_term thy [pat] [] intro_t
   5.499 +                  val args' = map (Pattern.rewrite_term thy [pat] []) args
   5.500 +                in
   5.501 +                  rewrite_arg' (Free (y, T2), T2) (args', (pat::pats, intro_t', ctxt'))
   5.502 +                end
   5.503 +            | rewrite_arg' _ (args, (pats, intro_t, ctxt)) = (args, (pats, intro_t, ctxt))
   5.504 +          val (args', (pats, intro_t', ctxt')) =
   5.505 +            rewrite_arg' (arg, fastype_of arg) (args, (pats, intro_t, ctxt))
   5.506 +        in
   5.507 +          rewrite_args args' (pats, intro_t', ctxt')
   5.508 +        end
   5.509    | _ => rewrite_args args (pats, intro_t, ctxt))
   5.510  
   5.511  fun rewrite_prem atom =
   5.512 @@ -834,23 +860,24 @@
   5.513  
   5.514  fun split_conjuncts_in_assms ctxt th =
   5.515    let
   5.516 -    val ((_, [fixed_th]), ctxt') = Variable.import false [th] ctxt 
   5.517 +    val ((_, [fixed_th]), ctxt') = Variable.import false [th] ctxt
   5.518      fun split_conjs i nprems th =
   5.519        if i > nprems then th
   5.520        else
   5.521 -        case try Drule.RSN (@{thm conjI}, (i, th)) of
   5.522 -          SOME th' => split_conjs i (nprems+1) th'
   5.523 -        | NONE => split_conjs (i+1) nprems th
   5.524 +        (case try Drule.RSN (@{thm conjI}, (i, th)) of
   5.525 +          SOME th' => split_conjs i (nprems + 1) th'
   5.526 +        | NONE => split_conjs (i + 1) nprems th)
   5.527    in
   5.528 -    singleton (Variable.export ctxt' ctxt) (split_conjs 1 (Thm.nprems_of fixed_th) fixed_th)
   5.529 +    singleton (Variable.export ctxt' ctxt)
   5.530 +      (split_conjs 1 (Thm.nprems_of fixed_th) fixed_th)
   5.531    end
   5.532  
   5.533  fun dest_conjunct_prem th =
   5.534 -  case HOLogic.dest_Trueprop (prop_of th) of
   5.535 +  (case HOLogic.dest_Trueprop (prop_of th) of
   5.536      (Const (@{const_name HOL.conj}, _) $ _ $ _) =>
   5.537        dest_conjunct_prem (th RS @{thm conjunct1})
   5.538          @ dest_conjunct_prem (th RS @{thm conjunct2})
   5.539 -    | _ => [th]
   5.540 +   | _ => [th])
   5.541  
   5.542  fun expand_tuples thy intro =
   5.543    let
   5.544 @@ -877,6 +904,7 @@
   5.545      intro'''''
   5.546    end
   5.547  
   5.548 +
   5.549  (** making case distributivity rules **)
   5.550  (*** this should be part of the datatype package ***)
   5.551  
   5.552 @@ -888,7 +916,7 @@
   5.553      val case_combs = Datatype_Prop.make_case_combs case_names descr thy "f";
   5.554      fun make comb =
   5.555        let
   5.556 -        val Type ("fun", [T, T']) = fastype_of comb;
   5.557 +        val Type ("fun", [T, T']) = fastype_of comb
   5.558          val (Const (case_name, _), fs) = strip_comb comb
   5.559          val used = Term.add_tfree_names comb []
   5.560          val U = TFree (singleton (Name.variant_list used) "'t", HOLogic.typeS)
   5.561 @@ -952,12 +980,14 @@
   5.562        (map (fn th => th RS @{thm eq_reflection}) ths) [] t
   5.563    end
   5.564  
   5.565 +
   5.566  (*** conversions ***)
   5.567  
   5.568  fun imp_prems_conv cv ct =
   5.569 -  case Thm.term_of ct of
   5.570 +  (case Thm.term_of ct of
   5.571      Const ("==>", _) $ _ $ _ => Conv.combination_conv (Conv.arg_conv cv) (imp_prems_conv cv) ct
   5.572 -  | _ => Conv.all_conv ct
   5.573 +  | _ => Conv.all_conv ct)
   5.574 +
   5.575  
   5.576  (** eta contract higher-order arguments **)
   5.577  
   5.578 @@ -968,6 +998,7 @@
   5.579      map_term thy (map_concl f o map_atoms f) intro
   5.580    end
   5.581  
   5.582 +
   5.583  (** remove equalities **)
   5.584  
   5.585  fun remove_equalities thy intro =
   5.586 @@ -978,26 +1009,27 @@
   5.587          fun remove_eq (prems, concl) =
   5.588            let
   5.589              fun removable_eq prem =
   5.590 -              case try (HOLogic.dest_eq o HOLogic.dest_Trueprop) prem of
   5.591 -                SOME (lhs, rhs) => (case lhs of
   5.592 -                  Var _ => true
   5.593 +              (case try (HOLogic.dest_eq o HOLogic.dest_Trueprop) prem of
   5.594 +                SOME (lhs, rhs) =>
   5.595 +                  (case lhs of
   5.596 +                    Var _ => true
   5.597                    | _ => (case rhs of Var _ => true | _ => false))
   5.598 -              | NONE => false
   5.599 +              | NONE => false)
   5.600            in
   5.601 -            case find_first removable_eq prems of
   5.602 +            (case find_first removable_eq prems of
   5.603                NONE => (prems, concl)
   5.604              | SOME eq =>
   5.605 -              let
   5.606 -                val (lhs, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop eq)
   5.607 -                val prems' = remove (op =) eq prems
   5.608 -                val subst = (case lhs of
   5.609 -                  (v as Var _) =>
   5.610 -                    (fn t => if t = v then rhs else t)
   5.611 -                | _ => (case rhs of
   5.612 -                   (v as Var _) => (fn t => if t = v then lhs else t)))
   5.613 -              in
   5.614 -                remove_eq (map (map_aterms subst) prems', map_aterms subst concl)
   5.615 -              end
   5.616 +                let
   5.617 +                  val (lhs, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop eq)
   5.618 +                  val prems' = remove (op =) eq prems
   5.619 +                  val subst =
   5.620 +                    (case lhs of
   5.621 +                      (v as Var _) =>
   5.622 +                        (fn t => if t = v then rhs else t)
   5.623 +                    | _ => (case rhs of (v as Var _) => (fn t => if t = v then lhs else t)))
   5.624 +                in
   5.625 +                  remove_eq (map (map_aterms subst) prems', map_aterms subst concl)
   5.626 +                end)
   5.627            end
   5.628        in
   5.629          Logic.list_implies (remove_eq (prems, concl))
   5.630 @@ -1006,6 +1038,7 @@
   5.631      map_term thy remove_eqs intro
   5.632    end
   5.633  
   5.634 +
   5.635  (* Some last processing *)
   5.636  
   5.637  fun remove_pointless_clauses intro =
   5.638 @@ -1013,6 +1046,7 @@
   5.639      []
   5.640    else [intro]
   5.641  
   5.642 +
   5.643  (* some peephole optimisations *)
   5.644  
   5.645  fun peephole_optimisation thy intro =
   5.646 @@ -1021,7 +1055,8 @@
   5.647      val process =
   5.648        rewrite_rule ctxt (Predicate_Compile_Simps.get ctxt)
   5.649      fun process_False intro_t =
   5.650 -      if member (op =) (Logic.strip_imp_prems intro_t) @{prop "False"} then NONE else SOME intro_t
   5.651 +      if member (op =) (Logic.strip_imp_prems intro_t) @{prop "False"}
   5.652 +      then NONE else SOME intro_t
   5.653      fun process_True intro_t =
   5.654        map_filter_premises (fn p => if p = @{prop True} then NONE else SOME p) intro_t
   5.655    in
   5.656 @@ -1033,60 +1068,65 @@
   5.657  (* importing introduction rules *)
   5.658  
   5.659  fun import_intros inp_pred [] ctxt =
   5.660 -  let
   5.661 -    val ([outp_pred], ctxt') = Variable.import_terms true [inp_pred] ctxt
   5.662 -    val T = fastype_of outp_pred
   5.663 -    val paramTs = ho_argsT_of_typ (binder_types T)
   5.664 -    val (param_names, _) = Variable.variant_fixes
   5.665 -      (map (fn i => "p" ^ (string_of_int i)) (1 upto (length paramTs))) ctxt'
   5.666 -    val params = map2 (curry Free) param_names paramTs
   5.667 -  in
   5.668 -    (((outp_pred, params), []), ctxt')
   5.669 -  end
   5.670 +      let
   5.671 +        val ([outp_pred], ctxt') = Variable.import_terms true [inp_pred] ctxt
   5.672 +        val T = fastype_of outp_pred
   5.673 +        val paramTs = ho_argsT_of_typ (binder_types T)
   5.674 +        val (param_names, _) = Variable.variant_fixes
   5.675 +          (map (fn i => "p" ^ (string_of_int i)) (1 upto (length paramTs))) ctxt'
   5.676 +        val params = map2 (curry Free) param_names paramTs
   5.677 +      in
   5.678 +        (((outp_pred, params), []), ctxt')
   5.679 +      end
   5.680    | import_intros inp_pred (th :: ths) ctxt =
   5.681 -    let
   5.682 -      val ((_, [th']), ctxt') = Variable.import true [th] ctxt
   5.683 -      val thy = Proof_Context.theory_of ctxt'
   5.684 -      val (pred, args) = strip_intro_concl th'
   5.685 -      val T = fastype_of pred
   5.686 -      val ho_args = ho_args_of_typ T args
   5.687 -      fun subst_of (pred', pred) =
   5.688 -        let
   5.689 -          val subst = Sign.typ_match thy (fastype_of pred', fastype_of pred) Vartab.empty
   5.690 -            handle Type.TYPE_MATCH => error ("Type mismatch of predicate " ^ fst (dest_Const pred)
   5.691 -            ^ " (trying to match " ^ Syntax.string_of_typ ctxt (fastype_of pred')
   5.692 -            ^ " and " ^ Syntax.string_of_typ ctxt (fastype_of pred) ^ ")"
   5.693 -            ^ " in " ^ Display.string_of_thm ctxt th)
   5.694 -        in map (fn (indexname, (s, T)) => ((indexname, s), T)) (Vartab.dest subst) end
   5.695 -      fun instantiate_typ th =
   5.696 -        let
   5.697 -          val (pred', _) = strip_intro_concl th
   5.698 -          val _ = if not (fst (dest_Const pred) = fst (dest_Const pred')) then
   5.699 -            raise Fail "Trying to instantiate another predicate" else ()
   5.700 -        in Thm.certify_instantiate (subst_of (pred', pred), []) th end;
   5.701 -      fun instantiate_ho_args th =
   5.702 -        let
   5.703 -          val (_, args') = (strip_comb o HOLogic.dest_Trueprop o Logic.strip_imp_concl o prop_of) th
   5.704 -          val ho_args' = map dest_Var (ho_args_of_typ T args')
   5.705 -        in Thm.certify_instantiate ([], ho_args' ~~ ho_args) th end
   5.706 -      val outp_pred =
   5.707 -        Term_Subst.instantiate (subst_of (inp_pred, pred), []) inp_pred
   5.708 -      val ((_, ths'), ctxt1) =
   5.709 -        Variable.import false (map (instantiate_typ #> instantiate_ho_args) ths) ctxt'
   5.710 -    in
   5.711 -      (((outp_pred, ho_args), th' :: ths'), ctxt1)
   5.712 -    end
   5.713 -  
   5.714 +      let
   5.715 +        val ((_, [th']), ctxt') = Variable.import true [th] ctxt
   5.716 +        val thy = Proof_Context.theory_of ctxt'
   5.717 +        val (pred, args) = strip_intro_concl th'
   5.718 +        val T = fastype_of pred
   5.719 +        val ho_args = ho_args_of_typ T args
   5.720 +        fun subst_of (pred', pred) =
   5.721 +          let
   5.722 +            val subst = Sign.typ_match thy (fastype_of pred', fastype_of pred) Vartab.empty
   5.723 +              handle Type.TYPE_MATCH =>
   5.724 +                error ("Type mismatch of predicate " ^ fst (dest_Const pred) ^
   5.725 +                  " (trying to match " ^ Syntax.string_of_typ ctxt (fastype_of pred') ^
   5.726 +                  " and " ^ Syntax.string_of_typ ctxt (fastype_of pred) ^ ")" ^
   5.727 +                  " in " ^ Display.string_of_thm ctxt th)
   5.728 +          in map (fn (indexname, (s, T)) => ((indexname, s), T)) (Vartab.dest subst) end
   5.729 +        fun instantiate_typ th =
   5.730 +          let
   5.731 +            val (pred', _) = strip_intro_concl th
   5.732 +            val _ =
   5.733 +              if not (fst (dest_Const pred) = fst (dest_Const pred')) then
   5.734 +                raise Fail "Trying to instantiate another predicate"
   5.735 +              else ()
   5.736 +          in Thm.certify_instantiate (subst_of (pred', pred), []) th end
   5.737 +        fun instantiate_ho_args th =
   5.738 +          let
   5.739 +            val (_, args') =
   5.740 +              (strip_comb o HOLogic.dest_Trueprop o Logic.strip_imp_concl o prop_of) th
   5.741 +            val ho_args' = map dest_Var (ho_args_of_typ T args')
   5.742 +          in Thm.certify_instantiate ([], ho_args' ~~ ho_args) th end
   5.743 +        val outp_pred =
   5.744 +          Term_Subst.instantiate (subst_of (inp_pred, pred), []) inp_pred
   5.745 +        val ((_, ths'), ctxt1) =
   5.746 +          Variable.import false (map (instantiate_typ #> instantiate_ho_args) ths) ctxt'
   5.747 +      in
   5.748 +        (((outp_pred, ho_args), th' :: ths'), ctxt1)
   5.749 +      end
   5.750 +
   5.751 +
   5.752  (* generation of case rules from user-given introduction rules *)
   5.753  
   5.754  fun mk_args2 (Type (@{type_name Product_Type.prod}, [T1, T2])) st =
   5.755 -    let
   5.756 -      val (t1, st') = mk_args2 T1 st
   5.757 -      val (t2, st'') = mk_args2 T2 st'
   5.758 -    in
   5.759 -      (HOLogic.mk_prod (t1, t2), st'')
   5.760 -    end
   5.761 -  (*| mk_args2 (T as Type ("fun", _)) (params, ctxt) = 
   5.762 +      let
   5.763 +        val (t1, st') = mk_args2 T1 st
   5.764 +        val (t2, st'') = mk_args2 T2 st'
   5.765 +      in
   5.766 +        (HOLogic.mk_prod (t1, t2), st'')
   5.767 +      end
   5.768 +  (*| mk_args2 (T as Type ("fun", _)) (params, ctxt) =
   5.769      let
   5.770        val (S, U) = strip_type T
   5.771      in
   5.772 @@ -1100,11 +1140,11 @@
   5.773          end
   5.774      end*)
   5.775    | mk_args2 T (params, ctxt) =
   5.776 -    let
   5.777 -      val ([x], ctxt') = Variable.variant_fixes ["x"] ctxt
   5.778 -    in
   5.779 -      (Free (x, T), (params, ctxt'))
   5.780 -    end
   5.781 +      let
   5.782 +        val ([x], ctxt') = Variable.variant_fixes ["x"] ctxt
   5.783 +      in
   5.784 +        (Free (x, T), (params, ctxt'))
   5.785 +      end
   5.786  
   5.787  fun mk_casesrule ctxt pred introrules =
   5.788    let
   5.789 @@ -1129,28 +1169,29 @@
   5.790      val assm = HOLogic.mk_Trueprop (list_comb (pred, argvs))
   5.791      val cases = map mk_case intros
   5.792    in Logic.list_implies (assm :: cases, prop) end;
   5.793 -  
   5.794 +
   5.795  
   5.796  (* unifying constants to have the same type variables *)
   5.797  
   5.798  fun unify_consts thy cs intr_ts =
   5.799 -  (let
   5.800 +  let
   5.801       val add_term_consts_2 = fold_aterms (fn Const c => insert (op =) c | _ => I);
   5.802       fun varify (t, (i, ts)) =
   5.803         let val t' = map_types (Logic.incr_tvar (i + 1)) (#2 (Type.varify_global [] t))
   5.804 -       in (maxidx_of_term t', t'::ts) end;
   5.805 -     val (i, cs') = List.foldr varify (~1, []) cs;
   5.806 -     val (i', intr_ts') = List.foldr varify (i, []) intr_ts;
   5.807 -     val rec_consts = fold add_term_consts_2 cs' [];
   5.808 -     val intr_consts = fold add_term_consts_2 intr_ts' [];
   5.809 +       in (maxidx_of_term t', t' :: ts) end
   5.810 +     val (i, cs') = List.foldr varify (~1, []) cs
   5.811 +     val (i', intr_ts') = List.foldr varify (i, []) intr_ts
   5.812 +     val rec_consts = fold add_term_consts_2 cs' []
   5.813 +     val intr_consts = fold add_term_consts_2 intr_ts' []
   5.814       fun unify (cname, cT) =
   5.815         let val consts = map snd (filter (fn c => fst c = cname) intr_consts)
   5.816 -       in fold (Sign.typ_unify thy) ((replicate (length consts) cT) ~~ consts) end;
   5.817 -     val (env, _) = fold unify rec_consts (Vartab.empty, i');
   5.818 +       in fold (Sign.typ_unify thy) ((replicate (length consts) cT) ~~ consts) end
   5.819 +     val (env, _) = fold unify rec_consts (Vartab.empty, i')
   5.820       val subst = map_types (Envir.norm_type env)
   5.821     in (map subst cs', map subst intr_ts')
   5.822 -   end) handle Type.TUNIFY =>
   5.823 -     (warning "Occurrences of recursive constant have non-unifiable types"; (cs, intr_ts));
   5.824 +   end handle Type.TUNIFY =>
   5.825 +     (warning "Occurrences of recursive constant have non-unifiable types"; (cs, intr_ts))
   5.826 +
   5.827  
   5.828  (* preprocessing rules *)
   5.829  
   5.830 @@ -1163,6 +1204,7 @@
   5.831  
   5.832  fun preprocess_intro thy = expand_tuples thy #> preprocess_equality thy
   5.833  
   5.834 +
   5.835  (* defining a quickcheck predicate *)
   5.836  
   5.837  fun strip_imp_prems (Const(@{const_name HOL.implies}, _) $ A $ B) = A :: strip_imp_prems B
   5.838 @@ -1171,7 +1213,7 @@
   5.839  fun strip_imp_concl (Const(@{const_name HOL.implies}, _) $ _ $ B) = strip_imp_concl B
   5.840    | strip_imp_concl A = A;
   5.841  
   5.842 -fun strip_horn A = (strip_imp_prems A, strip_imp_concl A);
   5.843 +fun strip_horn A = (strip_imp_prems A, strip_imp_concl A)
   5.844  
   5.845  fun define_quickcheck_predicate t thy =
   5.846    let
   5.847 @@ -1184,9 +1226,10 @@
   5.848      val constT = map snd vs' ---> @{typ bool}
   5.849      val thy1 = Sign.add_consts_i [(Binding.name constname, constT, NoSyn)] thy
   5.850      val const = Const (full_constname, constT)
   5.851 -    val t = Logic.list_implies
   5.852 -      (map HOLogic.mk_Trueprop (prems @ [HOLogic.mk_not concl]),
   5.853 -       HOLogic.mk_Trueprop (list_comb (const, map Free vs')))
   5.854 +    val t =
   5.855 +      Logic.list_implies
   5.856 +        (map HOLogic.mk_Trueprop (prems @ [HOLogic.mk_not concl]),
   5.857 +          HOLogic.mk_Trueprop (list_comb (const, map Free vs')))
   5.858      val intro =
   5.859        Goal.prove (Proof_Context.init_global thy1) (map fst vs') [] t
   5.860          (fn _ => ALLGOALS Skip_Proof.cheat_tac)
   5.861 @@ -1194,4 +1237,4 @@
   5.862      ((((full_constname, constT), vs'), intro), thy1)
   5.863    end
   5.864  
   5.865 -end;
   5.866 +end
     6.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_compilations.ML	Wed Feb 12 13:31:18 2014 +0100
     6.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_compilations.ML	Wed Feb 12 13:33:05 2014 +0100
     6.3 @@ -4,30 +4,30 @@
     6.4  Structures for different compilations of the predicate compiler.
     6.5  *)
     6.6  
     6.7 -structure Predicate_Comp_Funs =
     6.8 +structure Predicate_Comp_Funs =  (* FIXME proper signature *)
     6.9  struct
    6.10  
    6.11  fun mk_monadT T = Type (@{type_name Predicate.pred}, [T])
    6.12  
    6.13  fun dest_monadT (Type (@{type_name Predicate.pred}, [T])) = T
    6.14 -  | dest_monadT T = raise TYPE ("dest_monadT", [T], []);
    6.15 +  | dest_monadT T = raise TYPE ("dest_monadT", [T], [])
    6.16  
    6.17 -fun mk_empty T = Const (@{const_name Orderings.bot}, mk_monadT T);
    6.18 +fun mk_empty T = Const (@{const_name Orderings.bot}, mk_monadT T)
    6.19  
    6.20  fun mk_single t =
    6.21    let val T = fastype_of t
    6.22 -  in Const(@{const_name Predicate.single}, T --> mk_monadT T) $ t end;
    6.23 +  in Const(@{const_name Predicate.single}, T --> mk_monadT T) $ t end
    6.24  
    6.25  fun mk_bind (x, f) =
    6.26    let val T as Type ("fun", [_, U]) = fastype_of f
    6.27    in
    6.28      Const (@{const_name Predicate.bind}, fastype_of x --> T --> U) $ x $ f
    6.29 -  end;
    6.30 +  end
    6.31  
    6.32 -val mk_plus = HOLogic.mk_binop @{const_name sup};
    6.33 +val mk_plus = HOLogic.mk_binop @{const_name sup}
    6.34  
    6.35  fun mk_if cond = Const (@{const_name Predicate.if_pred},
    6.36 -  HOLogic.boolT --> mk_monadT HOLogic.unitT) $ cond;
    6.37 +  HOLogic.boolT --> mk_monadT HOLogic.unitT) $ cond
    6.38  
    6.39  fun mk_iterate_upto T (f, from, to) =
    6.40    list_comb (Const (@{const_name Predicate.iterate_upto},
    6.41 @@ -50,44 +50,48 @@
    6.42      val T = dest_monadT (fastype_of f)
    6.43    in
    6.44      Const (@{const_name Predicate.eval}, mk_monadT T --> T --> HOLogic.boolT) $ f $ x
    6.45 -  end;
    6.46 +  end
    6.47  
    6.48  fun dest_Eval (Const (@{const_name Predicate.eval}, _) $ f $ x) = (f, x)
    6.49  
    6.50  fun mk_map T1 T2 tf tp = Const (@{const_name Predicate.map},
    6.51 -  (T1 --> T2) --> mk_monadT T1 --> mk_monadT T2) $ tf $ tp;
    6.52 +  (T1 --> T2) --> mk_monadT T1 --> mk_monadT T2) $ tf $ tp
    6.53  
    6.54 -val compfuns = Predicate_Compile_Aux.CompilationFuns
    6.55 +val compfuns =
    6.56 +  Predicate_Compile_Aux.CompilationFuns
    6.57      {mk_monadT = mk_monadT, dest_monadT = dest_monadT, mk_empty = mk_empty,
    6.58      mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
    6.59 -    mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map};
    6.60 +    mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
    6.61  
    6.62 -end;
    6.63 +end
    6.64  
    6.65 -structure CPS_Comp_Funs =
    6.66 +
    6.67 +structure CPS_Comp_Funs =  (* FIXME proper signature *)
    6.68  struct
    6.69  
    6.70 -fun mk_monadT T = (T --> @{typ "Code_Evaluation.term list option"}) --> @{typ "Code_Evaluation.term list option"}
    6.71 +fun mk_monadT T =
    6.72 +  (T --> @{typ "Code_Evaluation.term list option"}) --> @{typ "Code_Evaluation.term list option"}
    6.73  
    6.74 -fun dest_monadT (Type ("fun", [Type ("fun", [T, @{typ "term list option"}]), @{typ "term list option"}])) = T
    6.75 +fun dest_monadT
    6.76 +      (Type ("fun", [Type ("fun", [T, @{typ "term list option"}]), @{typ "term list option"}])) = T
    6.77    | dest_monadT T = raise TYPE ("dest_monadT", [T], []);
    6.78  
    6.79 -fun mk_empty T = Const (@{const_name Quickcheck_Exhaustive.cps_empty}, mk_monadT T);
    6.80 +fun mk_empty T = Const (@{const_name Quickcheck_Exhaustive.cps_empty}, mk_monadT T)
    6.81  
    6.82  fun mk_single t =
    6.83    let val T = fastype_of t
    6.84 -  in Const(@{const_name Quickcheck_Exhaustive.cps_single}, T --> mk_monadT T) $ t end;
    6.85 +  in Const(@{const_name Quickcheck_Exhaustive.cps_single}, T --> mk_monadT T) $ t end
    6.86  
    6.87  fun mk_bind (x, f) =
    6.88    let val T as Type ("fun", [_, U]) = fastype_of f
    6.89    in
    6.90      Const (@{const_name Quickcheck_Exhaustive.cps_bind}, fastype_of x --> T --> U) $ x $ f
    6.91 -  end;
    6.92 +  end
    6.93  
    6.94 -val mk_plus = HOLogic.mk_binop @{const_name Quickcheck_Exhaustive.cps_plus};
    6.95 +val mk_plus = HOLogic.mk_binop @{const_name Quickcheck_Exhaustive.cps_plus}
    6.96  
    6.97  fun mk_if cond = Const (@{const_name Quickcheck_Exhaustive.cps_if},
    6.98 -  HOLogic.boolT --> mk_monadT HOLogic.unitT) $ cond;
    6.99 +  HOLogic.boolT --> mk_monadT HOLogic.unitT) $ cond
   6.100  
   6.101  fun mk_iterate_upto _ _ = error "not implemented yet"
   6.102  
   6.103 @@ -104,14 +108,16 @@
   6.104  
   6.105  fun mk_map _ _ _ _ = error "not implemented"
   6.106  
   6.107 -val compfuns = Predicate_Compile_Aux.CompilationFuns
   6.108 +val compfuns =
   6.109 +  Predicate_Compile_Aux.CompilationFuns
   6.110      {mk_monadT = mk_monadT, dest_monadT = dest_monadT, mk_empty = mk_empty,
   6.111      mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   6.112      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map};
   6.113  
   6.114 -end;
   6.115 +end
   6.116  
   6.117 -structure Pos_Bounded_CPS_Comp_Funs =
   6.118 +
   6.119 +structure Pos_Bounded_CPS_Comp_Funs =  (* FIXME proper signature *)
   6.120  struct
   6.121  
   6.122  val resultT = @{typ "(bool * Code_Evaluation.term list) option"}
   6.123 @@ -119,13 +125,13 @@
   6.124  
   6.125  fun dest_monadT (Type ("fun", [Type ("fun", [T, @{typ "(bool * term list) option"}]),
   6.126    @{typ "natural => (bool * term list) option"}])) = T
   6.127 -  | dest_monadT T = raise TYPE ("dest_monadT", [T], []);
   6.128 +  | dest_monadT T = raise TYPE ("dest_monadT", [T], [])
   6.129  
   6.130 -fun mk_empty T = Const (@{const_name Quickcheck_Exhaustive.pos_bound_cps_empty}, mk_monadT T);
   6.131 +fun mk_empty T = Const (@{const_name Quickcheck_Exhaustive.pos_bound_cps_empty}, mk_monadT T)
   6.132  
   6.133  fun mk_single t =
   6.134    let val T = fastype_of t
   6.135 -  in Const(@{const_name Quickcheck_Exhaustive.pos_bound_cps_single}, T --> mk_monadT T) $ t end;
   6.136 +  in Const(@{const_name Quickcheck_Exhaustive.pos_bound_cps_single}, T --> mk_monadT T) $ t end
   6.137  
   6.138  fun mk_bind (x, f) =
   6.139    let val T as Type ("fun", [_, U]) = fastype_of f
   6.140 @@ -133,10 +139,11 @@
   6.141      Const (@{const_name Quickcheck_Exhaustive.pos_bound_cps_bind}, fastype_of x --> T --> U) $ x $ f
   6.142    end;
   6.143  
   6.144 -val mk_plus = HOLogic.mk_binop @{const_name Quickcheck_Exhaustive.pos_bound_cps_plus};
   6.145 +val mk_plus = HOLogic.mk_binop @{const_name Quickcheck_Exhaustive.pos_bound_cps_plus}
   6.146  
   6.147 -fun mk_if cond = Const (@{const_name Quickcheck_Exhaustive.pos_bound_cps_if},
   6.148 -  HOLogic.boolT --> mk_monadT HOLogic.unitT) $ cond;
   6.149 +fun mk_if cond =
   6.150 +  Const (@{const_name Quickcheck_Exhaustive.pos_bound_cps_if},
   6.151 +    HOLogic.boolT --> mk_monadT HOLogic.unitT) $ cond
   6.152  
   6.153  fun mk_iterate_upto _ _ = error "not implemented yet"
   6.154  
   6.155 @@ -156,14 +163,16 @@
   6.156  
   6.157  fun mk_map _ _ _ _ = error "not implemented"
   6.158  
   6.159 -val compfuns = Predicate_Compile_Aux.CompilationFuns
   6.160 +val compfuns =
   6.161 +  Predicate_Compile_Aux.CompilationFuns
   6.162      {mk_monadT = mk_monadT, dest_monadT = dest_monadT, mk_empty = mk_empty,
   6.163      mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   6.164      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map};
   6.165  
   6.166 -end;
   6.167 +end
   6.168  
   6.169 -structure Neg_Bounded_CPS_Comp_Funs =
   6.170 +
   6.171 +structure Neg_Bounded_CPS_Comp_Funs =  (* FIXME proper signature *)
   6.172  struct
   6.173  
   6.174  fun mk_monadT T =
   6.175 @@ -171,16 +180,17 @@
   6.176      --> @{typ "Code_Evaluation.term list Quickcheck_Exhaustive.three_valued"})
   6.177      --> @{typ "natural => Code_Evaluation.term list Quickcheck_Exhaustive.three_valued"}
   6.178  
   6.179 -fun dest_monadT (Type ("fun", [Type ("fun", [Type (@{type_name "Quickcheck_Exhaustive.unknown"}, [T]),
   6.180 -    @{typ "term list Quickcheck_Exhaustive.three_valued"}]),
   6.181 -    @{typ "natural => term list Quickcheck_Exhaustive.three_valued"}])) = T
   6.182 +fun dest_monadT
   6.183 +    (Type ("fun", [Type ("fun", [Type (@{type_name "Quickcheck_Exhaustive.unknown"}, [T]),
   6.184 +      @{typ "term list Quickcheck_Exhaustive.three_valued"}]),
   6.185 +      @{typ "natural => term list Quickcheck_Exhaustive.three_valued"}])) = T
   6.186    | dest_monadT T = raise TYPE ("dest_monadT", [T], []);
   6.187  
   6.188 -fun mk_empty T = Const (@{const_name Quickcheck_Exhaustive.neg_bound_cps_empty}, mk_monadT T);
   6.189 +fun mk_empty T = Const (@{const_name Quickcheck_Exhaustive.neg_bound_cps_empty}, mk_monadT T)
   6.190  
   6.191  fun mk_single t =
   6.192    let val T = fastype_of t
   6.193 -  in Const(@{const_name Quickcheck_Exhaustive.neg_bound_cps_single}, T --> mk_monadT T) $ t end;
   6.194 +  in Const(@{const_name Quickcheck_Exhaustive.neg_bound_cps_single}, T --> mk_monadT T) $ t end
   6.195  
   6.196  fun mk_bind (x, f) =
   6.197    let val T as Type ("fun", [_, U]) = fastype_of f
   6.198 @@ -188,10 +198,10 @@
   6.199      Const (@{const_name Quickcheck_Exhaustive.neg_bound_cps_bind}, fastype_of x --> T --> U) $ x $ f
   6.200    end;
   6.201  
   6.202 -val mk_plus = HOLogic.mk_binop @{const_name Quickcheck_Exhaustive.neg_bound_cps_plus};
   6.203 +val mk_plus = HOLogic.mk_binop @{const_name Quickcheck_Exhaustive.neg_bound_cps_plus}
   6.204  
   6.205  fun mk_if cond = Const (@{const_name Quickcheck_Exhaustive.neg_bound_cps_if},
   6.206 -  HOLogic.boolT --> mk_monadT HOLogic.unitT) $ cond;
   6.207 +  HOLogic.boolT --> mk_monadT HOLogic.unitT) $ cond
   6.208  
   6.209  fun mk_iterate_upto _ _ = error "not implemented"
   6.210  
   6.211 @@ -210,7 +220,8 @@
   6.212  
   6.213  fun mk_map _ _ _ _  = error "not implemented"
   6.214  
   6.215 -val compfuns = Predicate_Compile_Aux.CompilationFuns
   6.216 +val compfuns =
   6.217 +  Predicate_Compile_Aux.CompilationFuns
   6.218      {mk_monadT = mk_monadT, dest_monadT = dest_monadT, mk_empty = mk_empty,
   6.219      mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   6.220      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map};
   6.221 @@ -218,7 +229,7 @@
   6.222  end;
   6.223  
   6.224  
   6.225 -structure RandomPredCompFuns =
   6.226 +structure RandomPredCompFuns =  (* FIXME proper signature *)
   6.227  struct
   6.228  
   6.229  fun mk_randompredT T =
   6.230 @@ -226,7 +237,7 @@
   6.231  
   6.232  fun dest_randompredT (Type ("fun", [@{typ Random.seed}, Type (@{type_name Product_Type.prod},
   6.233    [Type (@{type_name Predicate.pred}, [T]), @{typ Random.seed}])])) = T
   6.234 -  | dest_randompredT T = raise TYPE ("dest_randompredT", [T], []);
   6.235 +  | dest_randompredT T = raise TYPE ("dest_randompredT", [T], [])
   6.236  
   6.237  fun mk_empty T = Const(@{const_name Random_Pred.empty}, mk_randompredT T)
   6.238  
   6.239 @@ -235,7 +246,7 @@
   6.240      val T = fastype_of t
   6.241    in
   6.242      Const (@{const_name Random_Pred.single}, T --> mk_randompredT T) $ t
   6.243 -  end;
   6.244 +  end
   6.245  
   6.246  fun mk_bind (x, f) =
   6.247    let
   6.248 @@ -262,14 +273,16 @@
   6.249  fun mk_map T1 T2 tf tp = Const (@{const_name Random_Pred.map},
   6.250    (T1 --> T2) --> mk_randompredT T1 --> mk_randompredT T2) $ tf $ tp
   6.251  
   6.252 -val compfuns = Predicate_Compile_Aux.CompilationFuns
   6.253 +val compfuns =
   6.254 +  Predicate_Compile_Aux.CompilationFuns
   6.255      {mk_monadT = mk_randompredT, dest_monadT = dest_randompredT,
   6.256      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   6.257      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map};
   6.258  
   6.259 -end;
   6.260 +end
   6.261  
   6.262 -structure DSequence_CompFuns =
   6.263 +
   6.264 +structure DSequence_CompFuns =  (* FIXME proper signature *)
   6.265  struct
   6.266  
   6.267  fun mk_dseqT T = Type ("fun", [@{typ natural}, Type ("fun", [@{typ bool},
   6.268 @@ -304,48 +317,51 @@
   6.269  fun mk_map T1 T2 tf tp = Const (@{const_name Limited_Sequence.map},
   6.270    (T1 --> T2) --> mk_dseqT T1 --> mk_dseqT T2) $ tf $ tp
   6.271  
   6.272 -val compfuns = Predicate_Compile_Aux.CompilationFuns
   6.273 +val compfuns =
   6.274 +  Predicate_Compile_Aux.CompilationFuns
   6.275      {mk_monadT = mk_dseqT, dest_monadT = dest_dseqT,
   6.276      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   6.277      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   6.278  
   6.279  end;
   6.280  
   6.281 -structure New_Pos_DSequence_CompFuns =
   6.282 +
   6.283 +structure New_Pos_DSequence_CompFuns =  (* FIXME proper signature *)
   6.284  struct
   6.285  
   6.286  fun mk_pos_dseqT T =
   6.287 -    @{typ natural} --> Type (@{type_name Lazy_Sequence.lazy_sequence}, [T])
   6.288 +  @{typ natural} --> Type (@{type_name Lazy_Sequence.lazy_sequence}, [T])
   6.289  
   6.290 -fun dest_pos_dseqT (Type ("fun", [@{typ natural},
   6.291 -    Type (@{type_name Lazy_Sequence.lazy_sequence}, [T])])) = T
   6.292 -  | dest_pos_dseqT T = raise TYPE ("dest_pos_dseqT", [T], []);
   6.293 +fun dest_pos_dseqT
   6.294 +      (Type ("fun", [@{typ natural}, Type (@{type_name Lazy_Sequence.lazy_sequence}, [T])])) = T
   6.295 +  | dest_pos_dseqT T = raise TYPE ("dest_pos_dseqT", [T], [])
   6.296  
   6.297 -fun mk_empty T = Const (@{const_name Limited_Sequence.pos_empty}, mk_pos_dseqT T);
   6.298 +fun mk_empty T = Const (@{const_name Limited_Sequence.pos_empty}, mk_pos_dseqT T)
   6.299  
   6.300  fun mk_single t =
   6.301    let
   6.302      val T = fastype_of t
   6.303 -  in Const(@{const_name Limited_Sequence.pos_single}, T --> mk_pos_dseqT T) $ t end;
   6.304 +  in Const(@{const_name Limited_Sequence.pos_single}, T --> mk_pos_dseqT T) $ t end
   6.305  
   6.306  fun mk_bind (x, f) =
   6.307    let
   6.308      val T as Type ("fun", [_, U]) = fastype_of f
   6.309    in
   6.310      Const (@{const_name Limited_Sequence.pos_bind}, fastype_of x --> T --> U) $ x $ f
   6.311 -  end;
   6.312 +  end
   6.313    
   6.314  fun mk_decr_bind (x, f) =
   6.315    let
   6.316      val T as Type ("fun", [_, U]) = fastype_of f
   6.317    in
   6.318      Const (@{const_name Limited_Sequence.pos_decr_bind}, fastype_of x --> T --> U) $ x $ f
   6.319 -  end;
   6.320 +  end
   6.321 +
   6.322 +val mk_plus = HOLogic.mk_binop @{const_name Limited_Sequence.pos_union}
   6.323  
   6.324 -val mk_plus = HOLogic.mk_binop @{const_name Limited_Sequence.pos_union};
   6.325 -
   6.326 -fun mk_if cond = Const (@{const_name Limited_Sequence.pos_if_seq},
   6.327 -  HOLogic.boolT --> mk_pos_dseqT HOLogic.unitT) $ cond;
   6.328 +fun mk_if cond =
   6.329 +  Const (@{const_name Limited_Sequence.pos_if_seq},
   6.330 +    HOLogic.boolT --> mk_pos_dseqT HOLogic.unitT) $ cond
   6.331  
   6.332  fun mk_iterate_upto _ _ = raise Fail "No iterate_upto compilation"
   6.333  
   6.334 @@ -357,56 +373,63 @@
   6.335          [Type (@{type_name Option.option}, [@{typ unit}])])
   6.336    in Const (@{const_name Limited_Sequence.pos_not_seq}, nT --> pT) $ t end
   6.337  
   6.338 -fun mk_map T1 T2 tf tp = Const (@{const_name Limited_Sequence.pos_map},
   6.339 -  (T1 --> T2) --> mk_pos_dseqT T1 --> mk_pos_dseqT T2) $ tf $ tp
   6.340 +fun mk_map T1 T2 tf tp =
   6.341 +  Const (@{const_name Limited_Sequence.pos_map},
   6.342 +    (T1 --> T2) --> mk_pos_dseqT T1 --> mk_pos_dseqT T2) $ tf $ tp
   6.343  
   6.344 -val depth_limited_compfuns = Predicate_Compile_Aux.CompilationFuns
   6.345 +val depth_limited_compfuns =
   6.346 +  Predicate_Compile_Aux.CompilationFuns
   6.347      {mk_monadT = mk_pos_dseqT, dest_monadT = dest_pos_dseqT,
   6.348      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_decr_bind, mk_plus = mk_plus, mk_if = mk_if,
   6.349      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   6.350  
   6.351 -val depth_unlimited_compfuns = Predicate_Compile_Aux.CompilationFuns
   6.352 +val depth_unlimited_compfuns =
   6.353 +  Predicate_Compile_Aux.CompilationFuns
   6.354      {mk_monadT = mk_pos_dseqT, dest_monadT = dest_pos_dseqT,
   6.355      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   6.356      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   6.357  
   6.358 -end;
   6.359 +end
   6.360  
   6.361 -structure New_Neg_DSequence_CompFuns =
   6.362 +
   6.363 +structure New_Neg_DSequence_CompFuns =  (* FIXME proper signature *)
   6.364  struct
   6.365  
   6.366  fun mk_neg_dseqT T = @{typ natural} -->
   6.367    Type (@{type_name Lazy_Sequence.lazy_sequence}, [Type (@{type_name Option.option}, [T])])
   6.368  
   6.369 -fun dest_neg_dseqT (Type ("fun", [@{typ natural},
   6.370 -    Type (@{type_name Lazy_Sequence.lazy_sequence}, [Type (@{type_name Option.option}, [T])])])) = T
   6.371 -  | dest_neg_dseqT T = raise TYPE ("dest_neg_dseqT", [T], []);
   6.372 +fun dest_neg_dseqT
   6.373 +    (Type ("fun", [@{typ natural},
   6.374 +      Type (@{type_name Lazy_Sequence.lazy_sequence}, [Type (@{type_name Option.option}, [T])])])) =
   6.375 +      T
   6.376 +  | dest_neg_dseqT T = raise TYPE ("dest_neg_dseqT", [T], [])
   6.377  
   6.378 -fun mk_empty T = Const (@{const_name Limited_Sequence.neg_empty}, mk_neg_dseqT T);
   6.379 +fun mk_empty T = Const (@{const_name Limited_Sequence.neg_empty}, mk_neg_dseqT T)
   6.380  
   6.381  fun mk_single t =
   6.382    let
   6.383      val T = fastype_of t
   6.384 -  in Const(@{const_name Limited_Sequence.neg_single}, T --> mk_neg_dseqT T) $ t end;
   6.385 +  in Const(@{const_name Limited_Sequence.neg_single}, T --> mk_neg_dseqT T) $ t end
   6.386  
   6.387  fun mk_bind (x, f) =
   6.388    let
   6.389      val T as Type ("fun", [_, U]) = fastype_of f
   6.390    in
   6.391      Const (@{const_name Limited_Sequence.neg_bind}, fastype_of x --> T --> U) $ x $ f
   6.392 -  end;
   6.393 +  end
   6.394    
   6.395  fun mk_decr_bind (x, f) =
   6.396    let
   6.397      val T as Type ("fun", [_, U]) = fastype_of f
   6.398    in
   6.399      Const (@{const_name Limited_Sequence.neg_decr_bind}, fastype_of x --> T --> U) $ x $ f
   6.400 -  end;
   6.401 +  end
   6.402 +
   6.403 +val mk_plus = HOLogic.mk_binop @{const_name Limited_Sequence.neg_union}
   6.404  
   6.405 -val mk_plus = HOLogic.mk_binop @{const_name Limited_Sequence.neg_union};
   6.406 -
   6.407 -fun mk_if cond = Const (@{const_name Limited_Sequence.neg_if_seq},
   6.408 -  HOLogic.boolT --> mk_neg_dseqT HOLogic.unitT) $ cond;
   6.409 +fun mk_if cond =
   6.410 +  Const (@{const_name Limited_Sequence.neg_if_seq},
   6.411 +    HOLogic.boolT --> mk_neg_dseqT HOLogic.unitT) $ cond
   6.412  
   6.413  fun mk_iterate_upto _ _ = raise Fail "No iterate_upto compilation"
   6.414  
   6.415 @@ -418,53 +441,58 @@
   6.416          [@{typ unit}])
   6.417    in Const (@{const_name Limited_Sequence.neg_not_seq}, pT --> nT) $ t end
   6.418  
   6.419 -fun mk_map T1 T2 tf tp = Const (@{const_name Limited_Sequence.neg_map},
   6.420 -  (T1 --> T2) --> mk_neg_dseqT T1 --> mk_neg_dseqT T2) $ tf $ tp
   6.421 +fun mk_map T1 T2 tf tp =
   6.422 +  Const (@{const_name Limited_Sequence.neg_map},
   6.423 +    (T1 --> T2) --> mk_neg_dseqT T1 --> mk_neg_dseqT T2) $ tf $ tp
   6.424  
   6.425 -val depth_limited_compfuns = Predicate_Compile_Aux.CompilationFuns
   6.426 +val depth_limited_compfuns =
   6.427 +  Predicate_Compile_Aux.CompilationFuns
   6.428      {mk_monadT = mk_neg_dseqT, dest_monadT = dest_neg_dseqT,
   6.429      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_decr_bind, mk_plus = mk_plus, mk_if = mk_if,
   6.430      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   6.431  
   6.432 -val depth_unlimited_compfuns = Predicate_Compile_Aux.CompilationFuns
   6.433 +val depth_unlimited_compfuns =
   6.434 +  Predicate_Compile_Aux.CompilationFuns
   6.435      {mk_monadT = mk_neg_dseqT, dest_monadT = dest_neg_dseqT,
   6.436      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   6.437      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   6.438  
   6.439 -end;
   6.440 +end
   6.441  
   6.442 -structure New_Pos_Random_Sequence_CompFuns =
   6.443 +
   6.444 +structure New_Pos_Random_Sequence_CompFuns =  (* FIXME proper signature *)
   6.445  struct
   6.446  
   6.447  fun mk_pos_random_dseqT T =
   6.448    @{typ natural} --> @{typ natural} --> @{typ Random.seed} -->
   6.449      @{typ natural} --> Type (@{type_name Lazy_Sequence.lazy_sequence}, [T])
   6.450  
   6.451 -fun dest_pos_random_dseqT (Type ("fun", [@{typ natural}, Type ("fun", [@{typ natural},
   6.452 -    Type ("fun", [@{typ Random.seed}, Type ("fun", [@{typ natural},
   6.453 -    Type (@{type_name Lazy_Sequence.lazy_sequence}, [T])])])])])) = T
   6.454 -  | dest_pos_random_dseqT T = raise TYPE ("dest_random_dseqT", [T], []);
   6.455 +fun dest_pos_random_dseqT
   6.456 +    (Type ("fun", [@{typ natural}, Type ("fun", [@{typ natural},
   6.457 +      Type ("fun", [@{typ Random.seed}, Type ("fun", [@{typ natural},
   6.458 +      Type (@{type_name Lazy_Sequence.lazy_sequence}, [T])])])])])) = T
   6.459 +  | dest_pos_random_dseqT T = raise TYPE ("dest_random_dseqT", [T], [])
   6.460  
   6.461 -fun mk_empty T = Const (@{const_name Random_Sequence.pos_empty}, mk_pos_random_dseqT T);
   6.462 +fun mk_empty T = Const (@{const_name Random_Sequence.pos_empty}, mk_pos_random_dseqT T)
   6.463  
   6.464  fun mk_single t =
   6.465    let
   6.466      val T = fastype_of t
   6.467 -  in Const(@{const_name Random_Sequence.pos_single}, T --> mk_pos_random_dseqT T) $ t end;
   6.468 +  in Const(@{const_name Random_Sequence.pos_single}, T --> mk_pos_random_dseqT T) $ t end
   6.469  
   6.470  fun mk_bind (x, f) =
   6.471    let
   6.472      val T as Type ("fun", [_, U]) = fastype_of f
   6.473    in
   6.474      Const (@{const_name Random_Sequence.pos_bind}, fastype_of x --> T --> U) $ x $ f
   6.475 -  end;
   6.476 +  end
   6.477  
   6.478  fun mk_decr_bind (x, f) =
   6.479    let
   6.480      val T as Type ("fun", [_, U]) = fastype_of f
   6.481    in
   6.482      Const (@{const_name Random_Sequence.pos_decr_bind}, fastype_of x --> T --> U) $ x $ f
   6.483 -  end;
   6.484 +  end
   6.485  
   6.486  val mk_plus = HOLogic.mk_binop @{const_name Random_Sequence.pos_union};
   6.487  
   6.488 @@ -486,59 +514,66 @@
   6.489  
   6.490    in Const (@{const_name Random_Sequence.pos_not_random_dseq}, nT --> pT) $ t end
   6.491  
   6.492 -fun mk_map T1 T2 tf tp = Const (@{const_name Random_Sequence.pos_map},
   6.493 -  (T1 --> T2) --> mk_pos_random_dseqT T1 --> mk_pos_random_dseqT T2) $ tf $ tp
   6.494 +fun mk_map T1 T2 tf tp =
   6.495 +  Const (@{const_name Random_Sequence.pos_map},
   6.496 +    (T1 --> T2) --> mk_pos_random_dseqT T1 --> mk_pos_random_dseqT T2) $ tf $ tp
   6.497  
   6.498 -val depth_limited_compfuns = Predicate_Compile_Aux.CompilationFuns
   6.499 +val depth_limited_compfuns =
   6.500 +  Predicate_Compile_Aux.CompilationFuns
   6.501      {mk_monadT = mk_pos_random_dseqT, dest_monadT = dest_pos_random_dseqT,
   6.502      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_decr_bind, mk_plus = mk_plus, mk_if = mk_if,
   6.503      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   6.504  
   6.505 -val depth_unlimited_compfuns = Predicate_Compile_Aux.CompilationFuns
   6.506 +val depth_unlimited_compfuns =
   6.507 +  Predicate_Compile_Aux.CompilationFuns
   6.508      {mk_monadT = mk_pos_random_dseqT, dest_monadT = dest_pos_random_dseqT,
   6.509      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   6.510      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   6.511 +
   6.512  end;
   6.513  
   6.514 -structure New_Neg_Random_Sequence_CompFuns =
   6.515 +
   6.516 +structure New_Neg_Random_Sequence_CompFuns =  (* FIXME proper signature *)
   6.517  struct
   6.518  
   6.519  fun mk_neg_random_dseqT T =
   6.520 -   @{typ natural} --> @{typ natural} --> @{typ Random.seed} -->
   6.521 +  @{typ natural} --> @{typ natural} --> @{typ Random.seed} -->
   6.522      @{typ natural} --> 
   6.523      Type (@{type_name Lazy_Sequence.lazy_sequence}, [Type (@{type_name Option.option}, [T])])
   6.524  
   6.525 -fun dest_neg_random_dseqT (Type ("fun", [@{typ natural}, Type ("fun", [@{typ natural},
   6.526 -    Type ("fun", [@{typ Random.seed}, Type ("fun", [@{typ natural},
   6.527 -      Type (@{type_name Lazy_Sequence.lazy_sequence},
   6.528 -        [Type (@{type_name Option.option}, [T])])])])])])) = T
   6.529 -  | dest_neg_random_dseqT T = raise TYPE ("dest_random_dseqT", [T], []);
   6.530 +fun dest_neg_random_dseqT
   6.531 +    (Type ("fun", [@{typ natural}, Type ("fun", [@{typ natural},
   6.532 +      Type ("fun", [@{typ Random.seed}, Type ("fun", [@{typ natural},
   6.533 +        Type (@{type_name Lazy_Sequence.lazy_sequence},
   6.534 +          [Type (@{type_name Option.option}, [T])])])])])])) = T
   6.535 +  | dest_neg_random_dseqT T = raise TYPE ("dest_random_dseqT", [T], [])
   6.536  
   6.537 -fun mk_empty T = Const (@{const_name Random_Sequence.neg_empty}, mk_neg_random_dseqT T);
   6.538 +fun mk_empty T = Const (@{const_name Random_Sequence.neg_empty}, mk_neg_random_dseqT T)
   6.539  
   6.540  fun mk_single t =
   6.541    let
   6.542      val T = fastype_of t
   6.543 -  in Const(@{const_name Random_Sequence.neg_single}, T --> mk_neg_random_dseqT T) $ t end;
   6.544 +  in Const(@{const_name Random_Sequence.neg_single}, T --> mk_neg_random_dseqT T) $ t end
   6.545  
   6.546  fun mk_bind (x, f) =
   6.547    let
   6.548      val T as Type ("fun", [_, U]) = fastype_of f
   6.549    in
   6.550      Const (@{const_name Random_Sequence.neg_bind}, fastype_of x --> T --> U) $ x $ f
   6.551 -  end;
   6.552 +  end
   6.553  
   6.554  fun mk_decr_bind (x, f) =
   6.555    let
   6.556      val T as Type ("fun", [_, U]) = fastype_of f
   6.557    in
   6.558      Const (@{const_name Random_Sequence.neg_decr_bind}, fastype_of x --> T --> U) $ x $ f
   6.559 -  end;
   6.560 +  end
   6.561 +
   6.562 +val mk_plus = HOLogic.mk_binop @{const_name Random_Sequence.neg_union}
   6.563  
   6.564 -val mk_plus = HOLogic.mk_binop @{const_name Random_Sequence.neg_union};
   6.565 -
   6.566 -fun mk_if cond = Const (@{const_name Random_Sequence.neg_if_random_dseq},
   6.567 -  HOLogic.boolT --> mk_neg_random_dseqT HOLogic.unitT) $ cond;
   6.568 +fun mk_if cond =
   6.569 +  Const (@{const_name Random_Sequence.neg_if_random_dseq},
   6.570 +    HOLogic.boolT --> mk_neg_random_dseqT HOLogic.unitT) $ cond
   6.571  
   6.572  fun mk_iterate_upto T (f, from, to) =
   6.573    list_comb (Const (@{const_name Random_Sequence.neg_iterate_upto},
   6.574 @@ -553,51 +588,58 @@
   6.575      @{typ natural} --> Type (@{type_name Lazy_Sequence.lazy_sequence}, [@{typ unit}])
   6.576    in Const (@{const_name Random_Sequence.neg_not_random_dseq}, pT --> nT) $ t end
   6.577  
   6.578 -fun mk_map T1 T2 tf tp = Const (@{const_name Random_Sequence.neg_map},
   6.579 -  (T1 --> T2) --> mk_neg_random_dseqT T1 --> mk_neg_random_dseqT T2) $ tf $ tp
   6.580 +fun mk_map T1 T2 tf tp =
   6.581 +  Const (@{const_name Random_Sequence.neg_map},
   6.582 +    (T1 --> T2) --> mk_neg_random_dseqT T1 --> mk_neg_random_dseqT T2) $ tf $ tp
   6.583  
   6.584 -val depth_limited_compfuns = Predicate_Compile_Aux.CompilationFuns
   6.585 +val depth_limited_compfuns =
   6.586 +  Predicate_Compile_Aux.CompilationFuns
   6.587      {mk_monadT = mk_neg_random_dseqT, dest_monadT = dest_neg_random_dseqT,
   6.588      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_decr_bind, mk_plus = mk_plus, mk_if = mk_if,
   6.589      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   6.590  
   6.591 -val depth_unlimited_compfuns = Predicate_Compile_Aux.CompilationFuns
   6.592 +val depth_unlimited_compfuns =
   6.593 +  Predicate_Compile_Aux.CompilationFuns
   6.594      {mk_monadT = mk_neg_random_dseqT, dest_monadT = dest_neg_random_dseqT,
   6.595      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   6.596      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   6.597  
   6.598 -end;
   6.599 +end
   6.600  
   6.601 -structure Random_Sequence_CompFuns =
   6.602 +
   6.603 +structure Random_Sequence_CompFuns =  (* FIXME proper signature *)
   6.604  struct
   6.605  
   6.606  fun mk_random_dseqT T =
   6.607    @{typ natural} --> @{typ natural} --> @{typ Random.seed} -->
   6.608      HOLogic.mk_prodT (DSequence_CompFuns.mk_dseqT T, @{typ Random.seed})
   6.609  
   6.610 -fun dest_random_dseqT (Type ("fun", [@{typ natural}, Type ("fun", [@{typ natural},
   6.611 -  Type ("fun", [@{typ Random.seed},
   6.612 -  Type (@{type_name Product_Type.prod}, [T, @{typ Random.seed}])])])])) = DSequence_CompFuns.dest_dseqT T
   6.613 -  | dest_random_dseqT T = raise TYPE ("dest_random_dseqT", [T], []);
   6.614 +fun dest_random_dseqT
   6.615 +    (Type ("fun", [@{typ natural}, Type ("fun", [@{typ natural},
   6.616 +      Type ("fun", [@{typ Random.seed},
   6.617 +      Type (@{type_name Product_Type.prod}, [T, @{typ Random.seed}])])])])) =
   6.618 +      DSequence_CompFuns.dest_dseqT T
   6.619 +  | dest_random_dseqT T = raise TYPE ("dest_random_dseqT", [T], [])
   6.620  
   6.621 -fun mk_empty T = Const (@{const_name Random_Sequence.empty}, mk_random_dseqT T);
   6.622 +fun mk_empty T = Const (@{const_name Random_Sequence.empty}, mk_random_dseqT T)
   6.623  
   6.624  fun mk_single t =
   6.625    let
   6.626      val T = fastype_of t
   6.627 -  in Const(@{const_name Random_Sequence.single}, T --> mk_random_dseqT T) $ t end;
   6.628 +  in Const(@{const_name Random_Sequence.single}, T --> mk_random_dseqT T) $ t end
   6.629  
   6.630  fun mk_bind (x, f) =
   6.631    let
   6.632      val T as Type ("fun", [_, U]) = fastype_of f
   6.633    in
   6.634      Const (@{const_name Random_Sequence.bind}, fastype_of x --> T --> U) $ x $ f
   6.635 -  end;
   6.636 +  end
   6.637 +
   6.638 +val mk_plus = HOLogic.mk_binop @{const_name Random_Sequence.union}
   6.639  
   6.640 -val mk_plus = HOLogic.mk_binop @{const_name Random_Sequence.union};
   6.641 -
   6.642 -fun mk_if cond = Const (@{const_name Random_Sequence.if_random_dseq},
   6.643 -  HOLogic.boolT --> mk_random_dseqT HOLogic.unitT) $ cond;
   6.644 +fun mk_if cond =
   6.645 +  Const (@{const_name Random_Sequence.if_random_dseq},
   6.646 +    HOLogic.boolT --> mk_random_dseqT HOLogic.unitT) $ cond
   6.647  
   6.648  fun mk_iterate_upto _ _ = raise Fail "No iterate_upto compilation"
   6.649  
   6.650 @@ -609,10 +651,11 @@
   6.651  fun mk_map T1 T2 tf tp = Const (@{const_name Random_Sequence.map},
   6.652    (T1 --> T2) --> mk_random_dseqT T1 --> mk_random_dseqT T2) $ tf $ tp
   6.653  
   6.654 -val compfuns = Predicate_Compile_Aux.CompilationFuns
   6.655 +val compfuns =
   6.656 +  Predicate_Compile_Aux.CompilationFuns
   6.657      {mk_monadT = mk_random_dseqT, dest_monadT = dest_random_dseqT,
   6.658      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   6.659      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   6.660  
   6.661 -end;
   6.662 +end
   6.663  
     7.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML	Wed Feb 12 13:31:18 2014 +0100
     7.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML	Wed Feb 12 13:33:05 2014 +0100
     7.3 @@ -11,15 +11,15 @@
     7.4    type options = Predicate_Compile_Aux.options
     7.5    type compilation = Predicate_Compile_Aux.compilation
     7.6    type compilation_funs = Predicate_Compile_Aux.compilation_funs
     7.7 -  
     7.8 +
     7.9    val setup : theory -> theory
    7.10    val code_pred : options -> string -> Proof.context -> Proof.state
    7.11    val code_pred_cmd : options -> string -> Proof.context -> Proof.state
    7.12 -  val values_cmd : string list -> mode option list option
    7.13 -    -> ((string option * bool) * (compilation * int list)) -> int -> string -> Toplevel.state -> unit
    7.14 +  val values_cmd : string list -> mode option list option ->
    7.15 +    ((string option * bool) * (compilation * int list)) -> int -> string -> Toplevel.state -> unit
    7.16  
    7.17    val values_timeout : real Config.T
    7.18 -  
    7.19 +
    7.20    val print_stored_rules : Proof.context -> unit
    7.21    val print_all_modes : compilation -> Proof.context -> unit
    7.22  
    7.23 @@ -27,19 +27,23 @@
    7.24    val put_pred_random_result : (unit -> seed -> term Predicate.pred * seed) ->
    7.25      Proof.context -> Proof.context
    7.26    val put_dseq_result : (unit -> term Limited_Sequence.dseq) -> Proof.context -> Proof.context
    7.27 -  val put_dseq_random_result : (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> term Limited_Sequence.dseq * seed) ->
    7.28 +  val put_dseq_random_result :
    7.29 +    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed ->
    7.30 +      term Limited_Sequence.dseq * seed) ->
    7.31      Proof.context -> Proof.context
    7.32    val put_new_dseq_result : (unit -> Code_Numeral.natural -> term Lazy_Sequence.lazy_sequence) ->
    7.33      Proof.context -> Proof.context
    7.34    val put_lseq_random_result :
    7.35 -    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural -> term Lazy_Sequence.lazy_sequence) ->
    7.36 +    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural ->
    7.37 +      term Lazy_Sequence.lazy_sequence) ->
    7.38      Proof.context -> Proof.context
    7.39    val put_lseq_random_stats_result :
    7.40 -    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural -> (term * Code_Numeral.natural) Lazy_Sequence.lazy_sequence) ->
    7.41 +    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural ->
    7.42 +      (term * Code_Numeral.natural) Lazy_Sequence.lazy_sequence) ->
    7.43      Proof.context -> Proof.context
    7.44  
    7.45    val code_pred_intro_attrib : attribute
    7.46 -  (* used by Quickcheck_Generator *) 
    7.47 +  (* used by Quickcheck_Generator *)
    7.48    (* temporary for testing of the compilation *)
    7.49    val add_equations : options -> string list -> theory -> theory
    7.50    val add_depth_limited_random_equations : options -> string list -> theory -> theory
    7.51 @@ -54,7 +58,7 @@
    7.52    type mode_analysis_options =
    7.53     {use_generators : bool,
    7.54      reorder_premises : bool,
    7.55 -    infer_pos_and_neg_modes : bool}  
    7.56 +    infer_pos_and_neg_modes : bool}
    7.57    datatype mode_derivation = Mode_App of mode_derivation * mode_derivation | Context of mode
    7.58      | Mode_Pair of mode_derivation * mode_derivation | Term of mode
    7.59    val head_mode_of : mode_derivation -> mode
    7.60 @@ -90,12 +94,14 @@
    7.61    Const(@{const_name Code_Evaluation.tracing},
    7.62      @{typ String.literal} --> (fastype_of t) --> (fastype_of t)) $ (HOLogic.mk_literal s) $ t
    7.63  
    7.64 +
    7.65  (* representation of inferred clauses with modes *)
    7.66  
    7.67  type moded_clause = term list * (indprem * mode_derivation) list
    7.68  
    7.69  type 'a pred_mode_table = (string * ((bool * mode) * 'a) list) list
    7.70  
    7.71 +
    7.72  (* diagnostic display functions *)
    7.73  
    7.74  fun print_modes options modes =
    7.75 @@ -152,50 +158,53 @@
    7.76  (* validity checks *)
    7.77  
    7.78  fun check_expected_modes options _ modes =
    7.79 -  case expected_modes options of
    7.80 -    SOME (s, ms) => (case AList.lookup (op =) modes s of
    7.81 -      SOME modes =>
    7.82 -        let
    7.83 -          val modes' = map snd modes
    7.84 -        in
    7.85 -          if not (eq_set eq_mode (ms, modes')) then
    7.86 -            error ("expected modes were not inferred:\n"
    7.87 -            ^ "  inferred modes for " ^ s ^ ": " ^ commas (map string_of_mode modes')  ^ "\n"
    7.88 -            ^ "  expected modes for " ^ s ^ ": " ^ commas (map string_of_mode ms))
    7.89 -          else ()
    7.90 -        end
    7.91 -      | NONE => ())
    7.92 -  | NONE => ()
    7.93 +  (case expected_modes options of
    7.94 +    SOME (s, ms) =>
    7.95 +      (case AList.lookup (op =) modes s of
    7.96 +        SOME modes =>
    7.97 +          let
    7.98 +            val modes' = map snd modes
    7.99 +          in
   7.100 +            if not (eq_set eq_mode (ms, modes')) then
   7.101 +              error ("expected modes were not inferred:\n"
   7.102 +              ^ "  inferred modes for " ^ s ^ ": " ^ commas (map string_of_mode modes')  ^ "\n"
   7.103 +              ^ "  expected modes for " ^ s ^ ": " ^ commas (map string_of_mode ms))
   7.104 +            else ()
   7.105 +          end
   7.106 +        | NONE => ())
   7.107 +  | NONE => ())
   7.108  
   7.109  fun check_proposed_modes options preds modes errors =
   7.110 -  map (fn (s, _) => case proposed_modes options s of
   7.111 -    SOME ms => (case AList.lookup (op =) modes s of
   7.112 -      SOME inferred_ms =>
   7.113 -        let
   7.114 -          val preds_without_modes = map fst (filter (null o snd) modes)
   7.115 -          val modes' = map snd inferred_ms
   7.116 -        in
   7.117 -          if not (eq_set eq_mode (ms, modes')) then
   7.118 -            error ("expected modes were not inferred:\n"
   7.119 -            ^ "  inferred modes for " ^ s ^ ": " ^ commas (map string_of_mode modes')  ^ "\n"
   7.120 -            ^ "  expected modes for " ^ s ^ ": " ^ commas (map string_of_mode ms) ^ "\n"
   7.121 -            ^ (if show_invalid_clauses options then
   7.122 -            ("For the following clauses, the following modes could not be inferred: " ^ "\n"
   7.123 -            ^ cat_lines errors) else "") ^
   7.124 -            (if not (null preds_without_modes) then
   7.125 -              "\n" ^ "No mode inferred for the predicates " ^ commas preds_without_modes
   7.126 -            else ""))
   7.127 -          else ()
   7.128 -        end
   7.129 -      | NONE => ())
   7.130 -  | NONE => ()) preds
   7.131 +  map (fn (s, _) =>
   7.132 +    case proposed_modes options s of
   7.133 +      SOME ms =>
   7.134 +        (case AList.lookup (op =) modes s of
   7.135 +          SOME inferred_ms =>
   7.136 +            let
   7.137 +              val preds_without_modes = map fst (filter (null o snd) modes)
   7.138 +              val modes' = map snd inferred_ms
   7.139 +            in
   7.140 +              if not (eq_set eq_mode (ms, modes')) then
   7.141 +                error ("expected modes were not inferred:\n"
   7.142 +                ^ "  inferred modes for " ^ s ^ ": " ^ commas (map string_of_mode modes')  ^ "\n"
   7.143 +                ^ "  expected modes for " ^ s ^ ": " ^ commas (map string_of_mode ms) ^ "\n"
   7.144 +                ^ (if show_invalid_clauses options then
   7.145 +                ("For the following clauses, the following modes could not be inferred: " ^ "\n"
   7.146 +                ^ cat_lines errors) else "") ^
   7.147 +                (if not (null preds_without_modes) then
   7.148 +                  "\n" ^ "No mode inferred for the predicates " ^ commas preds_without_modes
   7.149 +                else ""))
   7.150 +              else ()
   7.151 +            end
   7.152 +        | NONE => ())
   7.153 +    | NONE => ()) preds
   7.154  
   7.155  fun check_matches_type ctxt predname T ms =
   7.156    let
   7.157      fun check (Fun (m1, m2)) (Type("fun", [T1,T2])) = check m1 T1 andalso check m2 T2
   7.158        | check m (Type("fun", _)) = (m = Input orelse m = Output)
   7.159        | check (Pair (m1, m2)) (Type (@{type_name Product_Type.prod}, [T1, T2])) =
   7.160 -          check m1 T1 andalso check m2 T2 
   7.161 +          check m1 T1 andalso check m2 T2
   7.162        | check Input _ = true
   7.163        | check Output _ = true
   7.164        | check Bool @{typ bool} = true
   7.165 @@ -203,30 +212,32 @@
   7.166      fun check_consistent_modes ms =
   7.167        if forall (fn Fun _ => true | _ => false) ms then
   7.168          pairself check_consistent_modes (split_list (map (fn Fun (m1, m2) => (m1, m2)) ms))
   7.169 -        |> (fn (res1, res2) => res1 andalso res2) 
   7.170 +        |> (fn (res1, res2) => res1 andalso res2)
   7.171        else if forall (fn Input => true | Output => true | Pair _ => true | _ => false) ms then
   7.172          true
   7.173        else if forall (fn Bool => true | _ => false) ms then
   7.174          true
   7.175        else
   7.176          false
   7.177 -    val _ = map
   7.178 -      (fn mode =>
   7.179 +    val _ =
   7.180 +      map (fn mode =>
   7.181          if length (strip_fun_mode mode) = length (binder_types T)
   7.182            andalso (forall (uncurry check) (strip_fun_mode mode ~~ binder_types T)) then ()
   7.183 -        else error (string_of_mode mode ^ " is not a valid mode for " ^ Syntax.string_of_typ ctxt T
   7.184 -        ^ " at predicate " ^ predname)) ms
   7.185 +        else
   7.186 +          error (string_of_mode mode ^ " is not a valid mode for " ^
   7.187 +            Syntax.string_of_typ ctxt T ^ " at predicate " ^ predname)) ms
   7.188      val _ =
   7.189 -     if check_consistent_modes ms then ()
   7.190 -     else error (commas (map string_of_mode ms) ^
   7.191 -       " are inconsistent modes for predicate " ^ predname)
   7.192 +      if check_consistent_modes ms then ()
   7.193 +      else
   7.194 +        error (commas (map string_of_mode ms) ^ " are inconsistent modes for predicate " ^ predname)
   7.195    in
   7.196      ms
   7.197    end
   7.198  
   7.199 +
   7.200  (* compilation modifiers *)
   7.201  
   7.202 -structure Comp_Mod =
   7.203 +structure Comp_Mod =  (* FIXME proper signature *)
   7.204  struct
   7.205  
   7.206  datatype comp_modifiers = Comp_Modifiers of
   7.207 @@ -263,29 +274,29 @@
   7.208      additional_arguments = additional_arguments, wrap_compilation = wrap_compilation,
   7.209      transform_additional_arguments = transform_additional_arguments})
   7.210  
   7.211 -end;
   7.212 +end
   7.213  
   7.214  fun unlimited_compfuns_of true New_Pos_Random_DSeq =
   7.215 -    New_Pos_Random_Sequence_CompFuns.depth_unlimited_compfuns
   7.216 +      New_Pos_Random_Sequence_CompFuns.depth_unlimited_compfuns
   7.217    | unlimited_compfuns_of false New_Pos_Random_DSeq =
   7.218 -    New_Neg_Random_Sequence_CompFuns.depth_unlimited_compfuns
   7.219 +      New_Neg_Random_Sequence_CompFuns.depth_unlimited_compfuns
   7.220    | unlimited_compfuns_of true Pos_Generator_DSeq =
   7.221 -    New_Pos_DSequence_CompFuns.depth_unlimited_compfuns
   7.222 +      New_Pos_DSequence_CompFuns.depth_unlimited_compfuns
   7.223    | unlimited_compfuns_of false Pos_Generator_DSeq =
   7.224 -    New_Neg_DSequence_CompFuns.depth_unlimited_compfuns
   7.225 +      New_Neg_DSequence_CompFuns.depth_unlimited_compfuns
   7.226    | unlimited_compfuns_of _ c =
   7.227 -    raise Fail ("No unlimited compfuns for compilation " ^ string_of_compilation c)
   7.228 +      raise Fail ("No unlimited compfuns for compilation " ^ string_of_compilation c)
   7.229  
   7.230  fun limited_compfuns_of true Predicate_Compile_Aux.New_Pos_Random_DSeq =
   7.231 -    New_Pos_Random_Sequence_CompFuns.depth_limited_compfuns
   7.232 +      New_Pos_Random_Sequence_CompFuns.depth_limited_compfuns
   7.233    | limited_compfuns_of false Predicate_Compile_Aux.New_Pos_Random_DSeq =
   7.234 -    New_Neg_Random_Sequence_CompFuns.depth_limited_compfuns
   7.235 +      New_Neg_Random_Sequence_CompFuns.depth_limited_compfuns
   7.236    | limited_compfuns_of true Pos_Generator_DSeq =
   7.237 -    New_Pos_DSequence_CompFuns.depth_limited_compfuns
   7.238 +      New_Pos_DSequence_CompFuns.depth_limited_compfuns
   7.239    | limited_compfuns_of false Pos_Generator_DSeq =
   7.240 -    New_Neg_DSequence_CompFuns.depth_limited_compfuns
   7.241 +      New_Neg_DSequence_CompFuns.depth_limited_compfuns
   7.242    | limited_compfuns_of _ c =
   7.243 -    raise Fail ("No limited compfuns for compilation " ^ string_of_compilation c)
   7.244 +      raise Fail ("No limited compfuns for compilation " ^ string_of_compilation c)
   7.245  
   7.246  val depth_limited_comp_modifiers = Comp_Mod.Comp_Modifiers
   7.247    {
   7.248 @@ -328,7 +339,7 @@
   7.249    compfuns = Predicate_Comp_Funs.compfuns,
   7.250    mk_random = (fn T => fn additional_arguments =>
   7.251    list_comb (Const(@{const_name Random_Pred.iter},
   7.252 -  [@{typ natural}, @{typ natural}, @{typ Random.seed}] ---> 
   7.253 +  [@{typ natural}, @{typ natural}, @{typ Random.seed}] --->
   7.254      Predicate_Comp_Funs.mk_monadT T), additional_arguments)),
   7.255    modify_funT = (fn T =>
   7.256      let
   7.257 @@ -354,7 +365,7 @@
   7.258    compfuns = Predicate_Comp_Funs.compfuns,
   7.259    mk_random = (fn T => fn additional_arguments =>
   7.260    list_comb (Const(@{const_name Random_Pred.iter},
   7.261 -  [@{typ natural}, @{typ natural}, @{typ Random.seed}] ---> 
   7.262 +  [@{typ natural}, @{typ natural}, @{typ Random.seed}] --->
   7.263      Predicate_Comp_Funs.mk_monadT T), tl additional_arguments)),
   7.264    modify_funT = (fn T =>
   7.265      let
   7.266 @@ -505,7 +516,7 @@
   7.267     : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
   7.268    transform_additional_arguments = K I : (indprem -> term list -> term list)
   7.269    }
   7.270 -  
   7.271 +
   7.272  val neg_generator_dseq_comp_modifiers = Comp_Mod.Comp_Modifiers
   7.273    {
   7.274    compilation = Neg_Generator_DSeq,
   7.275 @@ -534,7 +545,7 @@
   7.276    wrap_compilation = K (K (K (K (K I))))
   7.277     : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
   7.278    transform_additional_arguments = K I : (indprem -> term list -> term list)
   7.279 -  }  
   7.280 +  }
   7.281  
   7.282  val neg_generator_cps_comp_modifiers = Comp_Mod.Comp_Modifiers
   7.283    {
   7.284 @@ -548,30 +559,32 @@
   7.285     : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
   7.286    transform_additional_arguments = K I : (indprem -> term list -> term list)
   7.287    }
   7.288 -  
   7.289 +
   7.290  fun negative_comp_modifiers_of comp_modifiers =
   7.291 -    (case Comp_Mod.compilation comp_modifiers of
   7.292 -      Pos_Random_DSeq => neg_random_dseq_comp_modifiers
   7.293 -    | Neg_Random_DSeq => pos_random_dseq_comp_modifiers
   7.294 -    | New_Pos_Random_DSeq => new_neg_random_dseq_comp_modifiers
   7.295 -    | New_Neg_Random_DSeq => new_pos_random_dseq_comp_modifiers 
   7.296 -    | Pos_Generator_DSeq => neg_generator_dseq_comp_modifiers
   7.297 -    | Neg_Generator_DSeq => pos_generator_dseq_comp_modifiers
   7.298 -    | Pos_Generator_CPS => neg_generator_cps_comp_modifiers
   7.299 -    | Neg_Generator_CPS => pos_generator_cps_comp_modifiers
   7.300 -    | _ => comp_modifiers)
   7.301 +  (case Comp_Mod.compilation comp_modifiers of
   7.302 +    Pos_Random_DSeq => neg_random_dseq_comp_modifiers
   7.303 +  | Neg_Random_DSeq => pos_random_dseq_comp_modifiers
   7.304 +  | New_Pos_Random_DSeq => new_neg_random_dseq_comp_modifiers
   7.305 +  | New_Neg_Random_DSeq => new_pos_random_dseq_comp_modifiers
   7.306 +  | Pos_Generator_DSeq => neg_generator_dseq_comp_modifiers
   7.307 +  | Neg_Generator_DSeq => pos_generator_dseq_comp_modifiers
   7.308 +  | Pos_Generator_CPS => neg_generator_cps_comp_modifiers
   7.309 +  | Neg_Generator_CPS => pos_generator_cps_comp_modifiers
   7.310 +  | _ => comp_modifiers)
   7.311 +
   7.312  
   7.313  (* term construction *)
   7.314  
   7.315 -fun mk_v (names, vs) s T = (case AList.lookup (op =) vs s of
   7.316 -      NONE => (Free (s, T), (names, (s, [])::vs))
   7.317 -    | SOME xs =>
   7.318 -        let
   7.319 -          val s' = singleton (Name.variant_list names) s;
   7.320 -          val v = Free (s', T)
   7.321 -        in
   7.322 -          (v, (s'::names, AList.update (op =) (s, v::xs) vs))
   7.323 -        end);
   7.324 +fun mk_v (names, vs) s T =
   7.325 +  (case AList.lookup (op =) vs s of
   7.326 +    NONE => (Free (s, T), (names, (s, [])::vs))
   7.327 +  | SOME xs =>
   7.328 +      let
   7.329 +        val s' = singleton (Name.variant_list names) s;
   7.330 +        val v = Free (s', T)
   7.331 +      in
   7.332 +        (v, (s'::names, AList.update (op =) (s, v::xs) vs))
   7.333 +      end);
   7.334  
   7.335  fun distinct_v (Free (s, T)) nvs = mk_v nvs s T
   7.336    | distinct_v (t $ u) nvs =
   7.337 @@ -587,7 +600,7 @@
   7.338    let
   7.339      fun mk_bounds (Type (@{type_name Product_Type.prod}, [T1, T2])) i =
   7.340            let
   7.341 -            val (bs2, i') = mk_bounds T2 i 
   7.342 +            val (bs2, i') = mk_bounds T2 i
   7.343              val (bs1, i'') = mk_bounds T1 i'
   7.344            in
   7.345              (HOLogic.pair_const T1 T2 $ bs1 $ bs2, i'' + 1)
   7.346 @@ -608,17 +621,17 @@
   7.347      fold_rev mk_split_abs (binder_types T) inner_term
   7.348    end
   7.349  
   7.350 -fun compile_arg compilation_modifiers _ _ param_modes arg = 
   7.351 +fun compile_arg compilation_modifiers _ _ param_modes arg =
   7.352    let
   7.353      fun map_params (t as Free (f, T)) =
   7.354 -      (case (AList.lookup (op =) param_modes f) of
   7.355 -          SOME mode =>
   7.356 -            let
   7.357 -              val T' = Comp_Mod.funT_of compilation_modifiers mode T
   7.358 -            in
   7.359 -              mk_Eval_of (Free (f, T'), T) mode
   7.360 -            end
   7.361 -        | NONE => t)
   7.362 +          (case (AList.lookup (op =) param_modes f) of
   7.363 +              SOME mode =>
   7.364 +                let
   7.365 +                  val T' = Comp_Mod.funT_of compilation_modifiers mode T
   7.366 +                in
   7.367 +                  mk_Eval_of (Free (f, T'), T) mode
   7.368 +                end
   7.369 +          | NONE => t)
   7.370        | map_params t = t
   7.371    in
   7.372      map_aterms map_params arg
   7.373 @@ -654,39 +667,40 @@
   7.374      val compfuns = Comp_Mod.compfuns compilation_modifiers
   7.375      fun expr_of (t, deriv) =
   7.376        (case (t, deriv) of
   7.377 -        (t, Term Input) => SOME (compile_arg compilation_modifiers additional_arguments ctxt param_modes t)
   7.378 +        (t, Term Input) =>
   7.379 +          SOME (compile_arg compilation_modifiers additional_arguments ctxt param_modes t)
   7.380        | (_, Term Output) => NONE
   7.381        | (Const (name, T), Context mode) =>
   7.382 -        (case alternative_compilation_of ctxt name mode of
   7.383 -          SOME alt_comp => SOME (alt_comp compfuns T)
   7.384 -        | NONE =>
   7.385 -          SOME (Const (function_name_of (Comp_Mod.compilation compilation_modifiers)
   7.386 -            ctxt name mode,
   7.387 -            Comp_Mod.funT_of compilation_modifiers mode T)))
   7.388 +          (case alternative_compilation_of ctxt name mode of
   7.389 +            SOME alt_comp => SOME (alt_comp compfuns T)
   7.390 +          | NONE =>
   7.391 +            SOME (Const (function_name_of (Comp_Mod.compilation compilation_modifiers)
   7.392 +              ctxt name mode,
   7.393 +              Comp_Mod.funT_of compilation_modifiers mode T)))
   7.394        | (Free (s, T), Context m) =>
   7.395 -        (case (AList.lookup (op =) param_modes s) of
   7.396 -          SOME _ => SOME (Free (s, Comp_Mod.funT_of compilation_modifiers m T))
   7.397 -        | NONE =>
   7.398 -        let
   7.399 -          val bs = map (pair "x") (binder_types (fastype_of t))
   7.400 -          val bounds = map Bound (rev (0 upto (length bs) - 1))
   7.401 -        in SOME (fold_rev Term.abs bs (mk_if compfuns (list_comb (t, bounds)))) end)
   7.402 +          (case (AList.lookup (op =) param_modes s) of
   7.403 +            SOME _ => SOME (Free (s, Comp_Mod.funT_of compilation_modifiers m T))
   7.404 +          | NONE =>
   7.405 +              let
   7.406 +                val bs = map (pair "x") (binder_types (fastype_of t))
   7.407 +                val bounds = map Bound (rev (0 upto (length bs) - 1))
   7.408 +              in SOME (fold_rev Term.abs bs (mk_if compfuns (list_comb (t, bounds)))) end)
   7.409        | (t, Context _) =>
   7.410 -        let
   7.411 -          val bs = map (pair "x") (binder_types (fastype_of t))
   7.412 -          val bounds = map Bound (rev (0 upto (length bs) - 1))
   7.413 -        in SOME (fold_rev Term.abs bs (mk_if compfuns (list_comb (t, bounds)))) end
   7.414 +          let
   7.415 +            val bs = map (pair "x") (binder_types (fastype_of t))
   7.416 +            val bounds = map Bound (rev (0 upto (length bs) - 1))
   7.417 +          in SOME (fold_rev Term.abs bs (mk_if compfuns (list_comb (t, bounds)))) end
   7.418        | (Const (@{const_name Pair}, _) $ t1 $ t2, Mode_Pair (d1, d2)) =>
   7.419 -        (case (expr_of (t1, d1), expr_of (t2, d2)) of
   7.420 -          (NONE, NONE) => NONE
   7.421 -        | (NONE, SOME t) => SOME t
   7.422 -        | (SOME t, NONE) => SOME t
   7.423 -        | (SOME t1, SOME t2) => SOME (HOLogic.mk_prod (t1, t2)))
   7.424 +          (case (expr_of (t1, d1), expr_of (t2, d2)) of
   7.425 +            (NONE, NONE) => NONE
   7.426 +          | (NONE, SOME t) => SOME t
   7.427 +          | (SOME t, NONE) => SOME t
   7.428 +          | (SOME t1, SOME t2) => SOME (HOLogic.mk_prod (t1, t2)))
   7.429        | (t1 $ t2, Mode_App (deriv1, deriv2)) =>
   7.430 -        (case (expr_of (t1, deriv1), expr_of (t2, deriv2)) of
   7.431 -          (SOME t, NONE) => SOME t
   7.432 -         | (SOME t, SOME u) => SOME (t $ u)
   7.433 -         | _ => error "something went wrong here!"))
   7.434 +          (case (expr_of (t1, deriv1), expr_of (t2, deriv2)) of
   7.435 +            (SOME t, NONE) => SOME t
   7.436 +           | (SOME t, SOME u) => SOME (t $ u)
   7.437 +           | _ => error "something went wrong here!"))
   7.438    in
   7.439      list_comb (the (expr_of (t, deriv)), additional_arguments)
   7.440    end
   7.441 @@ -721,51 +735,56 @@
   7.442              val mode = head_mode_of deriv
   7.443              val additional_arguments' =
   7.444                Comp_Mod.transform_additional_arguments compilation_modifiers p additional_arguments
   7.445 -            val (compiled_clause, rest) = case p of
   7.446 -               Prem t =>
   7.447 -                 let
   7.448 -                   val u =
   7.449 -                     compile_expr compilation_modifiers ctxt (t, deriv) param_modes additional_arguments'
   7.450 -                   val (_, out_ts''') = split_mode mode (snd (strip_comb t))
   7.451 -                   val rest = compile_prems out_ts''' vs' names'' ps
   7.452 -                 in
   7.453 -                   (u, rest)
   7.454 -                 end
   7.455 -             | Negprem t =>
   7.456 -                 let
   7.457 -                   val neg_compilation_modifiers =
   7.458 -                     negative_comp_modifiers_of compilation_modifiers
   7.459 -                   val u = mk_not compfuns
   7.460 -                     (compile_expr neg_compilation_modifiers ctxt (t, deriv) param_modes additional_arguments')
   7.461 -                   val (_, out_ts''') = split_mode mode (snd (strip_comb t))
   7.462 -                   val rest = compile_prems out_ts''' vs' names'' ps
   7.463 -                 in
   7.464 -                   (u, rest)
   7.465 -                 end
   7.466 -             | Sidecond t =>
   7.467 -                 let
   7.468 -                   val t = compile_arg compilation_modifiers additional_arguments
   7.469 -                     ctxt param_modes t
   7.470 -                   val rest = compile_prems [] vs' names'' ps;
   7.471 -                 in
   7.472 -                   (mk_if compfuns t, rest)
   7.473 -                 end
   7.474 -             | Generator (v, T) =>
   7.475 -                 let
   7.476 -                   val u = Comp_Mod.mk_random compilation_modifiers T additional_arguments
   7.477 -                   val rest = compile_prems [Free (v, T)]  vs' names'' ps;
   7.478 -                 in
   7.479 -                   (u, rest)
   7.480 -                 end
   7.481 +            val (compiled_clause, rest) =
   7.482 +              (case p of
   7.483 +                Prem t =>
   7.484 +                  let
   7.485 +                    val u =
   7.486 +                      compile_expr compilation_modifiers ctxt (t, deriv)
   7.487 +                       param_modes additional_arguments'
   7.488 +                    val (_, out_ts''') = split_mode mode (snd (strip_comb t))
   7.489 +                    val rest = compile_prems out_ts''' vs' names'' ps
   7.490 +                  in
   7.491 +                    (u, rest)
   7.492 +                  end
   7.493 +              | Negprem t =>
   7.494 +                  let
   7.495 +                    val neg_compilation_modifiers =
   7.496 +                      negative_comp_modifiers_of compilation_modifiers
   7.497 +                    val u =
   7.498 +                     mk_not compfuns
   7.499 +                       (compile_expr neg_compilation_modifiers ctxt (t, deriv)
   7.500 +                         param_modes additional_arguments')
   7.501 +                    val (_, out_ts''') = split_mode mode (snd (strip_comb t))
   7.502 +                    val rest = compile_prems out_ts''' vs' names'' ps
   7.503 +                  in
   7.504 +                    (u, rest)
   7.505 +                  end
   7.506 +              | Sidecond t =>
   7.507 +                  let
   7.508 +                    val t = compile_arg compilation_modifiers additional_arguments
   7.509 +                      ctxt param_modes t
   7.510 +                    val rest = compile_prems [] vs' names'' ps;
   7.511 +                  in
   7.512 +                    (mk_if compfuns t, rest)
   7.513 +                  end
   7.514 +              | Generator (v, T) =>
   7.515 +                  let
   7.516 +                    val u = Comp_Mod.mk_random compilation_modifiers T additional_arguments
   7.517 +                    val rest = compile_prems [Free (v, T)]  vs' names'' ps;
   7.518 +                  in
   7.519 +                    (u, rest)
   7.520 +                  end)
   7.521            in
   7.522              compile_match constr_vs' eqs out_ts''
   7.523                (mk_bind compfuns (compiled_clause, rest))
   7.524            end
   7.525 -    val prem_t = compile_prems in_ts' (map fst param_modes) all_vs' moded_ps;
   7.526 +    val prem_t = compile_prems in_ts' (map fst param_modes) all_vs' moded_ps
   7.527    in
   7.528      mk_bind compfuns (mk_single compfuns inp, prem_t)
   7.529    end
   7.530  
   7.531 +
   7.532  (* switch detection *)
   7.533  
   7.534  (** argument position of an inductive predicates and the executable functions **)
   7.535 @@ -776,23 +795,25 @@
   7.536    | input_positions_pair Output = []
   7.537    | input_positions_pair (Fun _) = []
   7.538    | input_positions_pair (Pair (m1, m2)) =
   7.539 -    map (cons 1) (input_positions_pair m1) @ map (cons 2) (input_positions_pair m2)
   7.540 +      map (cons 1) (input_positions_pair m1) @ map (cons 2) (input_positions_pair m2)
   7.541  
   7.542 -fun input_positions_of_mode mode = flat (map_index
   7.543 -   (fn (i, Input) => [(i, [])]
   7.544 -   | (_, Output) => []
   7.545 -   | (_, Fun _) => []
   7.546 -   | (i, m as Pair _) => map (pair i) (input_positions_pair m))
   7.547 -     (Predicate_Compile_Aux.strip_fun_mode mode))
   7.548 +fun input_positions_of_mode mode =
   7.549 +  flat
   7.550 +    (map_index
   7.551 +      (fn (i, Input) => [(i, [])]
   7.552 +        | (_, Output) => []
   7.553 +        | (_, Fun _) => []
   7.554 +        | (i, m as Pair _) => map (pair i) (input_positions_pair m))
   7.555 +      (Predicate_Compile_Aux.strip_fun_mode mode))
   7.556  
   7.557  fun argument_position_pair _ [] = []
   7.558    | argument_position_pair (Pair (Fun _, m2)) (2 :: is) = argument_position_pair m2 is
   7.559    | argument_position_pair (Pair (m1, m2)) (i :: is) =
   7.560 -    (if eq_mode (m1, Output) andalso i = 2 then
   7.561 -      argument_position_pair m2 is
   7.562 -    else if eq_mode (m2, Output) andalso i = 1 then
   7.563 -      argument_position_pair m1 is
   7.564 -    else (i :: argument_position_pair (if i = 1 then m1 else m2) is))
   7.565 +      (if eq_mode (m1, Output) andalso i = 2 then
   7.566 +        argument_position_pair m2 is
   7.567 +      else if eq_mode (m2, Output) andalso i = 1 then
   7.568 +        argument_position_pair m1 is
   7.569 +      else (i :: argument_position_pair (if i = 1 then m1 else m2) is))
   7.570  
   7.571  fun argument_position_of mode (i, is) =
   7.572    (i - (length (filter (fn Output => true | Fun _ => true | _ => false)
   7.573 @@ -804,6 +825,7 @@
   7.574    | nth_pair (2 :: is) (Const (@{const_name Pair}, _) $ _ $ t2) = nth_pair is t2
   7.575    | nth_pair _ _ = raise Fail "unexpected input for nth_tuple"
   7.576  
   7.577 +
   7.578  (** switch detection analysis **)
   7.579  
   7.580  fun find_switch_test ctxt (i, is) (ts, _) =
   7.581 @@ -811,25 +833,25 @@
   7.582      val t = nth_pair is (nth ts i)
   7.583      val T = fastype_of t
   7.584    in
   7.585 -    case T of
   7.586 +    (case T of
   7.587        TFree _ => NONE
   7.588      | Type (Tcon, _) =>
   7.589 -      (case Datatype.get_constrs (Proof_Context.theory_of ctxt) Tcon of
   7.590 -        NONE => NONE
   7.591 -      | SOME cs =>
   7.592 -        (case strip_comb t of
   7.593 -          (Var _, []) => NONE
   7.594 -        | (Free _, []) => NONE
   7.595 -        | (Const (c, T), _) => if AList.defined (op =) cs c then SOME (c, T) else NONE))
   7.596 +        (case Datatype.get_constrs (Proof_Context.theory_of ctxt) Tcon of
   7.597 +          NONE => NONE
   7.598 +        | SOME cs =>
   7.599 +            (case strip_comb t of
   7.600 +              (Var _, []) => NONE
   7.601 +            | (Free _, []) => NONE
   7.602 +            | (Const (c, T), _) => if AList.defined (op =) cs c then SOME (c, T) else NONE)))
   7.603    end
   7.604  
   7.605  fun partition_clause ctxt pos moded_clauses =
   7.606    let
   7.607      fun insert_list eq (key, value) = AList.map_default eq (key, []) (cons value)
   7.608      fun find_switch_test' moded_clause (cases, left) =
   7.609 -      case find_switch_test ctxt pos moded_clause of
   7.610 +      (case find_switch_test ctxt pos moded_clause of
   7.611          SOME (c, T) => (insert_list (op =) ((c, T), moded_clause) cases, left)
   7.612 -      | NONE => (cases, moded_clause :: left)
   7.613 +      | NONE => (cases, moded_clause :: left))
   7.614    in
   7.615      fold find_switch_test' moded_clauses ([], [])
   7.616    end
   7.617 @@ -845,34 +867,36 @@
   7.618          val partition = partition_clause ctxt input_position moded_clauses
   7.619          val switch = if (length (fst partition) > 1) then SOME (input_position, partition) else NONE
   7.620        in
   7.621 -        case ord (switch, best_switch) of LESS => best_switch
   7.622 -          | EQUAL => best_switch | GREATER => switch
   7.623 +        (case ord (switch, best_switch) of
   7.624 +          LESS => best_switch
   7.625 +        | EQUAL => best_switch
   7.626 +        | GREATER => switch)
   7.627        end
   7.628      fun detect_switches moded_clauses =
   7.629 -      case fold (select_best_switch moded_clauses) (input_positions_of_mode mode) NONE of
   7.630 +      (case fold (select_best_switch moded_clauses) (input_positions_of_mode mode) NONE of
   7.631          SOME (best_pos, (switched_on, left_clauses)) =>
   7.632            Node ((best_pos, map (apsnd detect_switches) switched_on),
   7.633              detect_switches left_clauses)
   7.634 -      | NONE => Atom moded_clauses
   7.635 +      | NONE => Atom moded_clauses)
   7.636    in
   7.637      detect_switches moded_clauses
   7.638    end
   7.639  
   7.640 +
   7.641  (** compilation of detected switches **)
   7.642  
   7.643  fun destruct_constructor_pattern (pat, obj) =
   7.644    (case strip_comb pat of
   7.645 -    (Free _, []) => cons (pat, obj)
   7.646 +      (Free _, []) => cons (pat, obj)
   7.647    | (Const (c, T), pat_args) =>
   7.648 -    (case strip_comb obj of
   7.649 -      (Const (c', T'), obj_args) =>
   7.650 -        (if c = c' andalso T = T' then
   7.651 -          fold destruct_constructor_pattern (pat_args ~~ obj_args)
   7.652 -        else raise Fail "pattern and object mismatch")
   7.653 -    | _ => raise Fail "unexpected object")
   7.654 +      (case strip_comb obj of
   7.655 +        (Const (c', T'), obj_args) =>
   7.656 +          (if c = c' andalso T = T' then
   7.657 +            fold destruct_constructor_pattern (pat_args ~~ obj_args)
   7.658 +          else raise Fail "pattern and object mismatch")
   7.659 +      | _ => raise Fail "unexpected object")
   7.660    | _ => raise Fail "unexpected pattern")
   7.661  
   7.662 -
   7.663  fun compile_switch compilation_modifiers ctxt all_vs param_modes additional_arguments mode
   7.664    in_ts' outTs switch_tree =
   7.665    let
   7.666 @@ -920,48 +944,55 @@
   7.667            ((map compile_single_case switched_clauses) @
   7.668              [(xt, mk_empty compfuns (HOLogic.mk_tupleT outTs))])
   7.669        in
   7.670 -        case compile_switch_tree all_vs ctxt_eqs left_clauses of
   7.671 +        (case compile_switch_tree all_vs ctxt_eqs left_clauses of
   7.672            NONE => SOME switch
   7.673 -        | SOME left_comp => SOME (mk_plus compfuns (switch, left_comp))
   7.674 +        | SOME left_comp => SOME (mk_plus compfuns (switch, left_comp)))
   7.675        end
   7.676    in
   7.677      compile_switch_tree all_vs [] switch_tree
   7.678    end
   7.679  
   7.680 +
   7.681  (* compilation of predicates *)
   7.682  
   7.683  fun compile_pred options compilation_modifiers ctxt all_vs param_vs s T (pol, mode) moded_cls =
   7.684    let
   7.685 -    val is_terminating = false (* FIXME: requires an termination analysis *)  
   7.686 +    val is_terminating = false (* FIXME: requires an termination analysis *)
   7.687      val compilation_modifiers =
   7.688        (if pol then compilation_modifiers else
   7.689          negative_comp_modifiers_of compilation_modifiers)
   7.690        |> (if is_depth_limited_compilation (Comp_Mod.compilation compilation_modifiers) then
   7.691             (if is_terminating then
   7.692 -             (Comp_Mod.set_compfuns (unlimited_compfuns_of pol (Comp_Mod.compilation compilation_modifiers)))
   7.693 -           else
   7.694 -             (Comp_Mod.set_compfuns (limited_compfuns_of pol (Comp_Mod.compilation compilation_modifiers))))
   7.695 -         else I)
   7.696 -    val additional_arguments = Comp_Mod.additional_arguments compilation_modifiers
   7.697 -      (all_vs @ param_vs)
   7.698 +              (Comp_Mod.set_compfuns
   7.699 +                (unlimited_compfuns_of pol (Comp_Mod.compilation compilation_modifiers)))
   7.700 +            else
   7.701 +              (Comp_Mod.set_compfuns
   7.702 +                (limited_compfuns_of pol (Comp_Mod.compilation compilation_modifiers))))
   7.703 +          else I)
   7.704 +    val additional_arguments =
   7.705 +      Comp_Mod.additional_arguments compilation_modifiers (all_vs @ param_vs)
   7.706      val compfuns = Comp_Mod.compfuns compilation_modifiers
   7.707      fun is_param_type (T as Type ("fun",[_ , T'])) =
   7.708 -      is_some (try (dest_monadT compfuns) T) orelse is_param_type T'
   7.709 +          is_some (try (dest_monadT compfuns) T) orelse is_param_type T'
   7.710        | is_param_type T = is_some (try (dest_monadT compfuns) T)
   7.711 -    val (inpTs, outTs) = split_map_modeT (fn m => fn T => (SOME (funT_of compfuns m T), NONE)) mode
   7.712 -      (binder_types T)
   7.713 +    val (inpTs, outTs) =
   7.714 +      split_map_modeT (fn m => fn T => (SOME (funT_of compfuns m T), NONE)) mode
   7.715 +        (binder_types T)
   7.716      val funT = Comp_Mod.funT_of compilation_modifiers mode T
   7.717 -    val (in_ts, _) = fold_map (fold_map_aterms_prodT (curry HOLogic.mk_prod)
   7.718 -      (fn T => fn (param_vs, names) =>
   7.719 -        if is_param_type T then
   7.720 -          (Free (hd param_vs, T), (tl param_vs, names))
   7.721 -        else
   7.722 -          let
   7.723 -            val new = singleton (Name.variant_list names) "x"
   7.724 -          in (Free (new, T), (param_vs, new :: names)) end)) inpTs
   7.725 +    val (in_ts, _) =
   7.726 +      fold_map (fold_map_aterms_prodT (curry HOLogic.mk_prod)
   7.727 +        (fn T => fn (param_vs, names) =>
   7.728 +          if is_param_type T then
   7.729 +            (Free (hd param_vs, T), (tl param_vs, names))
   7.730 +          else
   7.731 +            let
   7.732 +              val new = singleton (Name.variant_list names) "x"
   7.733 +            in (Free (new, T), (param_vs, new :: names)) end)) inpTs
   7.734          (param_vs, (all_vs @ param_vs))
   7.735 -    val in_ts' = map_filter (map_filter_prod
   7.736 -      (fn t as Free (x, _) => if member (op =) param_vs x then NONE else SOME t | t => SOME t)) in_ts
   7.737 +    val in_ts' =
   7.738 +      map_filter (map_filter_prod
   7.739 +        (fn t as Free (x, _) =>
   7.740 +          if member (op =) param_vs x then NONE else SOME t | t => SOME t)) in_ts
   7.741      val param_modes = param_vs ~~ ho_arg_modes_of mode
   7.742      val compilation =
   7.743        if detect_switches options then
   7.744 @@ -971,9 +1002,9 @@
   7.745        else
   7.746          let
   7.747            val cl_ts =
   7.748 -            map (fn (ts, moded_prems) => 
   7.749 +            map (fn (ts, moded_prems) =>
   7.750                compile_clause compilation_modifiers ctxt all_vs param_modes additional_arguments
   7.751 -                (HOLogic.mk_tuple in_ts') (split_mode mode ts) moded_prems) moded_cls;
   7.752 +                (HOLogic.mk_tuple in_ts') (split_mode mode ts) moded_prems) moded_cls
   7.753          in
   7.754            Comp_Mod.wrap_compilation compilation_modifiers compfuns s T mode additional_arguments
   7.755              (if null cl_ts then
   7.756 @@ -982,12 +1013,12 @@
   7.757                foldr1 (mk_plus compfuns) cl_ts)
   7.758          end
   7.759      val fun_const =
   7.760 -      Const (function_name_of (Comp_Mod.compilation compilation_modifiers)
   7.761 -      ctxt s mode, funT)
   7.762 +      Const (function_name_of (Comp_Mod.compilation compilation_modifiers) ctxt s mode, funT)
   7.763    in
   7.764      HOLogic.mk_Trueprop
   7.765        (HOLogic.mk_eq (list_comb (fun_const, in_ts @ additional_arguments), compilation))
   7.766 -  end;
   7.767 +  end
   7.768 +
   7.769  
   7.770  (* Definition of executable functions and their intro and elim rules *)
   7.771  
   7.772 @@ -996,36 +1027,36 @@
   7.773    | strip_split_abs t = t
   7.774  
   7.775  fun mk_args is_eval (m as Pair (m1, m2), T as Type (@{type_name Product_Type.prod}, [T1, T2])) names =
   7.776 -    if eq_mode (m, Input) orelse eq_mode (m, Output) then
   7.777 +      if eq_mode (m, Input) orelse eq_mode (m, Output) then
   7.778 +        let
   7.779 +          val x = singleton (Name.variant_list names) "x"
   7.780 +        in
   7.781 +          (Free (x, T), x :: names)
   7.782 +        end
   7.783 +      else
   7.784 +        let
   7.785 +          val (t1, names') = mk_args is_eval (m1, T1) names
   7.786 +          val (t2, names'') = mk_args is_eval (m2, T2) names'
   7.787 +        in
   7.788 +          (HOLogic.mk_prod (t1, t2), names'')
   7.789 +        end
   7.790 +  | mk_args is_eval ((m as Fun _), T) names =
   7.791 +      let
   7.792 +        val funT = funT_of Predicate_Comp_Funs.compfuns m T
   7.793 +        val x = singleton (Name.variant_list names) "x"
   7.794 +        val (args, _) = fold_map (mk_args is_eval) (strip_fun_mode m ~~ binder_types T) (x :: names)
   7.795 +        val (inargs, outargs) = split_map_mode (fn _ => fn t => (SOME t, NONE)) m args
   7.796 +        val t = fold_rev HOLogic.tupled_lambda args (Predicate_Comp_Funs.mk_Eval
   7.797 +          (list_comb (Free (x, funT), inargs), HOLogic.mk_tuple outargs))
   7.798 +      in
   7.799 +        (if is_eval then t else Free (x, funT), x :: names)
   7.800 +      end
   7.801 +  | mk_args _ (_, T) names =
   7.802        let
   7.803          val x = singleton (Name.variant_list names) "x"
   7.804        in
   7.805          (Free (x, T), x :: names)
   7.806        end
   7.807 -    else
   7.808 -      let
   7.809 -        val (t1, names') = mk_args is_eval (m1, T1) names
   7.810 -        val (t2, names'') = mk_args is_eval (m2, T2) names'
   7.811 -      in
   7.812 -        (HOLogic.mk_prod (t1, t2), names'')
   7.813 -      end
   7.814 -  | mk_args is_eval ((m as Fun _), T) names =
   7.815 -    let
   7.816 -      val funT = funT_of Predicate_Comp_Funs.compfuns m T
   7.817 -      val x = singleton (Name.variant_list names) "x"
   7.818 -      val (args, _) = fold_map (mk_args is_eval) (strip_fun_mode m ~~ binder_types T) (x :: names)
   7.819 -      val (inargs, outargs) = split_map_mode (fn _ => fn t => (SOME t, NONE)) m args
   7.820 -      val t = fold_rev HOLogic.tupled_lambda args (Predicate_Comp_Funs.mk_Eval
   7.821 -        (list_comb (Free (x, funT), inargs), HOLogic.mk_tuple outargs))
   7.822 -    in
   7.823 -      (if is_eval then t else Free (x, funT), x :: names)
   7.824 -    end
   7.825 -  | mk_args is_eval (_, T) names =
   7.826 -    let
   7.827 -      val x = singleton (Name.variant_list names) "x"
   7.828 -    in
   7.829 -      (Free (x, T), x :: names)
   7.830 -    end
   7.831  
   7.832  fun create_intro_elim_rule ctxt mode defthm mode_id funT pred =
   7.833    let
   7.834 @@ -1052,8 +1083,9 @@
   7.835      val funpropI = HOLogic.mk_Trueprop (Predicate_Comp_Funs.mk_Eval (list_comb (funtrm, inargs),
   7.836                       HOLogic.mk_tuple outargs))
   7.837      val introtrm = Logic.list_implies (predpropI :: param_eqs, funpropI)
   7.838 -    val simprules = [defthm, @{thm eval_pred},
   7.839 -      @{thm "split_beta"}, @{thm "fst_conv"}, @{thm "snd_conv"}, @{thm pair_collapse}]
   7.840 +    val simprules =
   7.841 +      [defthm, @{thm eval_pred},
   7.842 +        @{thm "split_beta"}, @{thm "fst_conv"}, @{thm "snd_conv"}, @{thm pair_collapse}]
   7.843      val unfolddef_tac =
   7.844        Simplifier.asm_full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps simprules) 1
   7.845      val introthm = Goal.prove ctxt
   7.846 @@ -1082,14 +1114,13 @@
   7.847      ((introthm, elimthm), opt_neg_introthm)
   7.848    end
   7.849  
   7.850 -fun create_constname_of_mode options thy prefix name _ mode = 
   7.851 +fun create_constname_of_mode options thy prefix name _ mode =
   7.852    let
   7.853 -    val system_proposal = prefix ^ (Long_Name.base_name name)
   7.854 -      ^ "_" ^ ascii_string_of_mode mode
   7.855 +    val system_proposal = prefix ^ (Long_Name.base_name name) ^ "_" ^ ascii_string_of_mode mode
   7.856      val name = the_default system_proposal (proposed_names options name mode)
   7.857    in
   7.858      Sign.full_bname thy name
   7.859 -  end;
   7.860 +  end
   7.861  
   7.862  fun create_definitions options preds (name, modes) thy =
   7.863    let
   7.864 @@ -1181,13 +1212,14 @@
   7.865  fun dest_prem ctxt params t =
   7.866    (case strip_comb t of
   7.867      (v as Free _, _) => if member (op =) params v then Prem t else Sidecond t
   7.868 -  | (c as Const (@{const_name Not}, _), [t]) => (case dest_prem ctxt params t of
   7.869 -      Prem t => Negprem t
   7.870 -    | Negprem _ => error ("Double negation not allowed in premise: " ^
   7.871 -        Syntax.string_of_term ctxt (c $ t)) 
   7.872 -    | Sidecond t => Sidecond (c $ t))
   7.873 +  | (c as Const (@{const_name Not}, _), [t]) =>
   7.874 +      (case dest_prem ctxt params t of
   7.875 +        Prem t => Negprem t
   7.876 +      | Negprem _ => error ("Double negation not allowed in premise: " ^
   7.877 +          Syntax.string_of_term ctxt (c $ t))
   7.878 +      | Sidecond t => Sidecond (c $ t))
   7.879    | (Const (s, _), _) =>
   7.880 -    if is_registered ctxt s then Prem t else Sidecond t
   7.881 +      if is_registered ctxt s then Prem t else Sidecond t
   7.882    | _ => Sidecond t)
   7.883  
   7.884  fun prepare_intrs options ctxt prednames intros =
   7.885 @@ -1204,13 +1236,14 @@
   7.886          all_smodes_of_typ T
   7.887        else
   7.888          all_modes_of_typ T
   7.889 -    val all_modes = 
   7.890 +    val all_modes =
   7.891        map (fn (s, T) =>
   7.892 -        (s, case proposed_modes options s of
   7.893 +        (s,
   7.894 +          (case proposed_modes options s of
   7.895              SOME ms => check_matches_type ctxt s T ms
   7.896 -          | NONE => generate_modes s T)) preds
   7.897 +          | NONE => generate_modes s T))) preds
   7.898      val params =
   7.899 -      case intrs of
   7.900 +      (case intrs of
   7.901          [] =>
   7.902            let
   7.903              val T = snd (hd preds)
   7.904 @@ -1223,25 +1256,28 @@
   7.905              map2 (curry Free) param_names paramTs
   7.906            end
   7.907        | (intr :: _) =>
   7.908 -        let
   7.909 -          val (p, args) = strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl intr))
   7.910 -          val one_mode = hd (the (AList.lookup (op =) all_modes (fst (dest_Const p))))
   7.911 -        in
   7.912 -          ho_args_of one_mode args
   7.913 -        end
   7.914 +          let
   7.915 +            val (p, args) = strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl intr))
   7.916 +            val one_mode = hd (the (AList.lookup (op =) all_modes (fst (dest_Const p))))
   7.917 +          in
   7.918 +            ho_args_of one_mode args
   7.919 +          end)
   7.920      val param_vs = map (fst o dest_Free) params
   7.921      fun add_clause intr clauses =
   7.922        let
   7.923 -        val (Const (name, _), ts) = strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl intr))
   7.924 -        val prems = map (dest_prem ctxt params o HOLogic.dest_Trueprop) (Logic.strip_imp_prems intr)
   7.925 +        val (Const (name, _), ts) =
   7.926 +          strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl intr))
   7.927 +        val prems =
   7.928 +          map (dest_prem ctxt params o HOLogic.dest_Trueprop) (Logic.strip_imp_prems intr)
   7.929        in
   7.930 -        AList.update op = (name, these (AList.lookup op = clauses name) @
   7.931 -          [(ts, prems)]) clauses
   7.932 +        AList.update op =
   7.933 +          (name, these (AList.lookup op = clauses name) @ [(ts, prems)])
   7.934 +          clauses
   7.935        end;
   7.936      val clauses = fold add_clause intrs []
   7.937    in
   7.938      (preds, all_vs, param_vs, all_modes, clauses)
   7.939 -  end;
   7.940 +  end
   7.941  
   7.942  (* sanity check of introduction rules *)
   7.943  (* TODO: rethink check with new modes *)
   7.944 @@ -1258,7 +1294,7 @@
   7.945          else
   7.946            error ("Format of introduction rule is invalid: tuples must be expanded:"
   7.947            ^ (Syntax.string_of_term_global thy arg) ^ " in " ^
   7.948 -          (Display.string_of_thm_global thy intro)) 
   7.949 +          (Display.string_of_thm_global thy intro))
   7.950        | _ => true
   7.951      val prems = Logic.strip_imp_prems (prop_of intro)
   7.952      fun check_prem (Prem t) = forall check_arg args
   7.953 @@ -1288,6 +1324,7 @@
   7.954    in forall check prednames end
   7.955  *)
   7.956  
   7.957 +
   7.958  (* create code equation *)
   7.959  
   7.960  fun add_code_equations ctxt preds result_thmss =
   7.961 @@ -1321,6 +1358,7 @@
   7.962      map2 add_code_equation preds result_thmss
   7.963    end
   7.964  
   7.965 +
   7.966  (** main function of predicate compiler **)
   7.967  
   7.968  datatype steps = Steps of
   7.969 @@ -1340,11 +1378,12 @@
   7.970      fun dest_steps (Steps s) = s
   7.971      val compilation = Comp_Mod.compilation (#comp_modifiers (dest_steps steps))
   7.972      val ctxt = Proof_Context.init_global thy
   7.973 -    val _ = print_step options
   7.974 -      ("Starting predicate compiler (compilation: " ^ string_of_compilation compilation
   7.975 -        ^ ") for predicates " ^ commas prednames ^ "...")
   7.976 -      (*val _ = check_intros_elim_match thy prednames*)
   7.977 -      (*val _ = map (check_format_of_intro_rule thy) (maps (intros_of thy) prednames)*)
   7.978 +    val _ =
   7.979 +      print_step options
   7.980 +        ("Starting predicate compiler (compilation: " ^ string_of_compilation compilation ^
   7.981 +          ") for predicates " ^ commas prednames ^ "...")
   7.982 +    (*val _ = check_intros_elim_match thy prednames*)
   7.983 +    (*val _ = map (check_format_of_intro_rule thy) (maps (intros_of thy) prednames)*)
   7.984      val _ =
   7.985        if show_intermediate_results options then
   7.986          tracing (commas (map (Display.string_of_thm ctxt) (maps (intros_of ctxt) prednames)))
   7.987 @@ -1391,7 +1430,7 @@
   7.988    in
   7.989      thy'''
   7.990    end
   7.991 -  
   7.992 +
   7.993  fun gen_add_equations steps options names thy =
   7.994    let
   7.995      fun dest_steps (Steps s) = s
   7.996 @@ -1498,14 +1537,17 @@
   7.997    (Steps {
   7.998    define_functions =
   7.999      fn options => fn preds => fn (s, modes) =>
  7.1000 -    let
  7.1001 -      val pos_modes = map_filter (fn (true, m) => SOME m | _ => NONE) modes
  7.1002 -      val neg_modes = map_filter (fn (false, m) => SOME m | _ => NONE) modes
  7.1003 -    in define_functions new_pos_random_dseq_comp_modifiers New_Pos_Random_Sequence_CompFuns.depth_limited_compfuns
  7.1004 -      options preds (s, pos_modes)
  7.1005 -      #> define_functions new_neg_random_dseq_comp_modifiers New_Neg_Random_Sequence_CompFuns.depth_limited_compfuns
  7.1006 -      options preds (s, neg_modes)
  7.1007 -    end,
  7.1008 +      let
  7.1009 +        val pos_modes = map_filter (fn (true, m) => SOME m | _ => NONE) modes
  7.1010 +        val neg_modes = map_filter (fn (false, m) => SOME m | _ => NONE) modes
  7.1011 +      in
  7.1012 +        define_functions new_pos_random_dseq_comp_modifiers
  7.1013 +          New_Pos_Random_Sequence_CompFuns.depth_limited_compfuns
  7.1014 +          options preds (s, pos_modes) #>
  7.1015 +        define_functions new_neg_random_dseq_comp_modifiers
  7.1016 +          New_Neg_Random_Sequence_CompFuns.depth_limited_compfuns
  7.1017 +          options preds (s, neg_modes)
  7.1018 +      end,
  7.1019    prove = prove_by_skip,
  7.1020    add_code_equations = K (K I),
  7.1021    comp_modifiers = new_pos_random_dseq_comp_modifiers,
  7.1022 @@ -1515,16 +1557,16 @@
  7.1023  val add_generator_dseq_equations = gen_add_equations
  7.1024    (Steps {
  7.1025    define_functions =
  7.1026 -  fn options => fn preds => fn (s, modes) =>
  7.1027 -    let
  7.1028 -      val pos_modes = map_filter (fn (true, m) => SOME m | _ => NONE) modes
  7.1029 -      val neg_modes = map_filter (fn (false, m) => SOME m | _ => NONE) modes
  7.1030 -    in 
  7.1031 -      define_functions pos_generator_dseq_comp_modifiers New_Pos_DSequence_CompFuns.depth_limited_compfuns
  7.1032 -        options preds (s, pos_modes)
  7.1033 -      #> define_functions neg_generator_dseq_comp_modifiers New_Neg_DSequence_CompFuns.depth_limited_compfuns
  7.1034 -        options preds (s, neg_modes)
  7.1035 -    end,
  7.1036 +    fn options => fn preds => fn (s, modes) =>
  7.1037 +      let
  7.1038 +        val pos_modes = map_filter (fn (true, m) => SOME m | _ => NONE) modes
  7.1039 +        val neg_modes = map_filter (fn (false, m) => SOME m | _ => NONE) modes
  7.1040 +      in
  7.1041 +        define_functions pos_generator_dseq_comp_modifiers
  7.1042 +          New_Pos_DSequence_CompFuns.depth_limited_compfuns options preds (s, pos_modes) #>
  7.1043 +        define_functions neg_generator_dseq_comp_modifiers
  7.1044 +          New_Neg_DSequence_CompFuns.depth_limited_compfuns options preds (s, neg_modes)
  7.1045 +      end,
  7.1046    prove = prove_by_skip,
  7.1047    add_code_equations = K (K I),
  7.1048    comp_modifiers = pos_generator_dseq_comp_modifiers,
  7.1049 @@ -1534,23 +1576,23 @@
  7.1050  val add_generator_cps_equations = gen_add_equations
  7.1051    (Steps {
  7.1052    define_functions =
  7.1053 -  fn options => fn preds => fn (s, modes) =>
  7.1054 -    let
  7.1055 -      val pos_modes = map_filter (fn (true, m) => SOME m | _ => NONE) modes
  7.1056 -      val neg_modes = map_filter (fn (false, m) => SOME m | _ => NONE) modes
  7.1057 -    in 
  7.1058 -      define_functions pos_generator_cps_comp_modifiers Pos_Bounded_CPS_Comp_Funs.compfuns
  7.1059 -        options preds (s, pos_modes)
  7.1060 -      #> define_functions neg_generator_cps_comp_modifiers Neg_Bounded_CPS_Comp_Funs.compfuns
  7.1061 -        options preds (s, neg_modes)
  7.1062 -    end,
  7.1063 +    fn options => fn preds => fn (s, modes) =>
  7.1064 +      let
  7.1065 +        val pos_modes = map_filter (fn (true, m) => SOME m | _ => NONE) modes
  7.1066 +        val neg_modes = map_filter (fn (false, m) => SOME m | _ => NONE) modes
  7.1067 +      in
  7.1068 +        define_functions pos_generator_cps_comp_modifiers Pos_Bounded_CPS_Comp_Funs.compfuns
  7.1069 +          options preds (s, pos_modes)
  7.1070 +        #> define_functions neg_generator_cps_comp_modifiers Neg_Bounded_CPS_Comp_Funs.compfuns
  7.1071 +          options preds (s, neg_modes)
  7.1072 +      end,
  7.1073    prove = prove_by_skip,
  7.1074    add_code_equations = K (K I),
  7.1075    comp_modifiers = pos_generator_cps_comp_modifiers,
  7.1076    use_generators = true,
  7.1077    qname = "generator_cps_equation"})
  7.1078 -  
  7.1079 -  
  7.1080 +
  7.1081 +
  7.1082  (** user interface **)
  7.1083  
  7.1084  (* code_pred_intro attribute *)
  7.1085 @@ -1568,9 +1610,11 @@
  7.1086  
  7.1087  val default_values_timeout = if ML_System.is_smlnj then 1200.0 else 40.0
  7.1088  
  7.1089 -val values_timeout = Attrib.setup_config_real @{binding values_timeout} (K default_values_timeout)
  7.1090 +val values_timeout =
  7.1091 +  Attrib.setup_config_real @{binding values_timeout} (K default_values_timeout)
  7.1092  
  7.1093 -val setup = PredData.put (Graph.empty) #>
  7.1094 +val setup =
  7.1095 +  PredData.put (Graph.empty) #>
  7.1096    Attrib.setup @{binding code_pred_intro} (Scan.lift (Scan.option Args.name) >> attrib' add_intro)
  7.1097      "adding alternative introduction rules for code generation of inductive predicates"
  7.1098  
  7.1099 @@ -1592,7 +1636,7 @@
  7.1100          val T = Sign.the_const_type thy' const
  7.1101          val pred = Const (const, T)
  7.1102          val intros = intros_of ctxt' const
  7.1103 -      in mk_casesrule lthy' pred intros end  
  7.1104 +      in mk_casesrule lthy' pred intros end
  7.1105      val cases_rules = map mk_cases preds
  7.1106      val cases =
  7.1107        map2 (fn pred_name => fn case_rule => Rule_Cases.Case {fixes = [],
  7.1108 @@ -1633,6 +1677,7 @@
  7.1109  val code_pred = generic_code_pred (K I);
  7.1110  val code_pred_cmd = generic_code_pred Code.read_const
  7.1111  
  7.1112 +
  7.1113  (* transformation for code generation *)
  7.1114  
  7.1115  (* FIXME just one data slot (record) per program unit *)
  7.1116 @@ -1695,13 +1740,16 @@
  7.1117  
  7.1118  fun dest_special_compr t =
  7.1119    let
  7.1120 -    val (inner_t, T_compr) = case t of (Const (@{const_name Collect}, _) $ Abs (_, T, t)) => (t, T)
  7.1121 -      | _ => raise TERM ("dest_special_compr", [t])
  7.1122 +    val (inner_t, T_compr) =
  7.1123 +      (case t of
  7.1124 +        (Const (@{const_name Collect}, _) $ Abs (_, T, t)) => (t, T)
  7.1125 +      | _ => raise TERM ("dest_special_compr", [t]))
  7.1126      val (Ts, conj) = apfst (map snd) (Predicate_Compile_Aux.strip_ex inner_t)
  7.1127      val [eq, body] = HOLogic.dest_conj conj
  7.1128 -    val rhs = case HOLogic.dest_eq eq of
  7.1129 +    val rhs =
  7.1130 +      (case HOLogic.dest_eq eq of
  7.1131          (Bound i, rhs) => if i = length Ts then rhs else raise TERM ("dest_special_compr", [t])
  7.1132 -      | _ => raise TERM ("dest_special_compr", [t])
  7.1133 +      | _ => raise TERM ("dest_special_compr", [t]))
  7.1134      val output_names = Name.variant_list (fold Term.add_free_names [rhs, body] [])
  7.1135        (map (fn i => "x" ^ string_of_int i) (1 upto length Ts))
  7.1136      val output_frees = map2 (curry Free) output_names (rev Ts)
  7.1137 @@ -1712,9 +1760,11 @@
  7.1138    end
  7.1139  
  7.1140  fun dest_general_compr ctxt t_compr =
  7.1141 -  let      
  7.1142 -    val inner_t = case t_compr of (Const (@{const_name Collect}, _) $ t) => t
  7.1143 -      | _ => error ("Not a set comprehension: " ^ Syntax.string_of_term ctxt t_compr);    
  7.1144 +  let
  7.1145 +    val inner_t =
  7.1146 +      (case t_compr of
  7.1147 +        (Const (@{const_name Collect}, _) $ t) => t
  7.1148 +      | _ => error ("Not a set comprehension: " ^ Syntax.string_of_term ctxt t_compr))
  7.1149      val (body, Ts, fp) = HOLogic.strip_psplits inner_t;
  7.1150      val output_names = Name.variant_list (Term.add_free_names body [])
  7.1151        (map (fn i => "x" ^ string_of_int i) (1 upto length Ts))
  7.1152 @@ -1733,24 +1783,28 @@
  7.1153      val compfuns = Comp_Mod.compfuns comp_modifiers
  7.1154      val all_modes_of = all_modes_of compilation
  7.1155      val (((body, output), T_compr), output_names) =
  7.1156 -      case try dest_special_compr t_compr of SOME r => r | NONE => dest_general_compr ctxt t_compr
  7.1157 +      (case try dest_special_compr t_compr of
  7.1158 +        SOME r => r
  7.1159 +      | NONE => dest_general_compr ctxt t_compr)
  7.1160      val (Const (name, _), all_args) =
  7.1161 -      case strip_comb body of
  7.1162 +      (case strip_comb body of
  7.1163          (Const (name, T), all_args) => (Const (name, T), all_args)
  7.1164 -      | (head, _) => error ("Not a constant: " ^ Syntax.string_of_term ctxt head)
  7.1165 +      | (head, _) => error ("Not a constant: " ^ Syntax.string_of_term ctxt head))
  7.1166    in
  7.1167      if defined_functions compilation ctxt name then
  7.1168        let
  7.1169 -        fun extract_mode (Const (@{const_name Pair}, _) $ t1 $ t2) = Pair (extract_mode t1, extract_mode t2)
  7.1170 -          | extract_mode (Free (x, _)) = if member (op =) output_names x then Output else Input
  7.1171 +        fun extract_mode (Const (@{const_name Pair}, _) $ t1 $ t2) =
  7.1172 +              Pair (extract_mode t1, extract_mode t2)
  7.1173 +          | extract_mode (Free (x, _)) =
  7.1174 +              if member (op =) output_names x then Output else Input
  7.1175            | extract_mode _ = Input
  7.1176          val user_mode = fold_rev (curry Fun) (map extract_mode all_args) Bool
  7.1177          fun valid modes1 modes2 =
  7.1178 -          case int_ord (length modes1, length modes2) of
  7.1179 +          (case int_ord (length modes1, length modes2) of
  7.1180              GREATER => error "Not enough mode annotations"
  7.1181            | LESS => error "Too many mode annotations"
  7.1182 -          | EQUAL => forall (fn (_, NONE) => true | (m, SOME m2) => eq_mode (m, m2))
  7.1183 -            (modes1 ~~ modes2)
  7.1184 +          | EQUAL =>
  7.1185 +              forall (fn (_, NONE) => true | (m, SOME m2) => eq_mode (m, m2)) (modes1 ~~ modes2))
  7.1186          fun mode_instance_of (m1, m2) =
  7.1187            let
  7.1188              fun instance_of (Fun _, Input) = true
  7.1189 @@ -1778,12 +1832,14 @@
  7.1190                the_default true (Option.map (valid modes) param_user_modes)
  7.1191              end)
  7.1192            |> map fst
  7.1193 -        val deriv = case derivs of
  7.1194 -            [] => error ("No mode possible for comprehension "
  7.1195 -                    ^ Syntax.string_of_term ctxt t_compr)
  7.1196 +        val deriv =
  7.1197 +          (case derivs of
  7.1198 +            [] =>
  7.1199 +              error ("No mode possible for comprehension " ^ Syntax.string_of_term ctxt t_compr)
  7.1200            | [d] => d
  7.1201 -          | d :: _ :: _ => (warning ("Multiple modes possible for comprehension "
  7.1202 -                    ^ Syntax.string_of_term ctxt t_compr); d);
  7.1203 +          | d :: _ :: _ =>
  7.1204 +              (warning ("Multiple modes possible for comprehension " ^
  7.1205 +                Syntax.string_of_term ctxt t_compr); d))
  7.1206          val (_, outargs) = split_mode (head_mode_of deriv) all_args
  7.1207          val t_pred = compile_expr comp_modifiers ctxt
  7.1208            (body, deriv) [] additional_arguments;
  7.1209 @@ -1805,32 +1861,35 @@
  7.1210        in count' 0 xs end
  7.1211      fun accumulate xs = (map (fn x => (x, count xs x)) o sort int_ord o distinct (op =)) xs;
  7.1212      val comp_modifiers =
  7.1213 -      case compilation of
  7.1214 -          Pred => predicate_comp_modifiers
  7.1215 -        | Random => random_comp_modifiers
  7.1216 -        | Depth_Limited => depth_limited_comp_modifiers
  7.1217 -        | Depth_Limited_Random => depth_limited_random_comp_modifiers
  7.1218 -        (*| Annotated => annotated_comp_modifiers*)
  7.1219 -        | DSeq => dseq_comp_modifiers
  7.1220 -        | Pos_Random_DSeq => pos_random_dseq_comp_modifiers
  7.1221 -        | New_Pos_Random_DSeq => new_pos_random_dseq_comp_modifiers
  7.1222 -        | Pos_Generator_DSeq => pos_generator_dseq_comp_modifiers
  7.1223 +      (case compilation of
  7.1224 +        Pred => predicate_comp_modifiers
  7.1225 +      | Random => random_comp_modifiers
  7.1226 +      | Depth_Limited => depth_limited_comp_modifiers
  7.1227 +      | Depth_Limited_Random => depth_limited_random_comp_modifiers
  7.1228 +      (*| Annotated => annotated_comp_modifiers*)
  7.1229 +      | DSeq => dseq_comp_modifiers
  7.1230 +      | Pos_Random_DSeq => pos_random_dseq_comp_modifiers
  7.1231 +      | New_Pos_Random_DSeq => new_pos_random_dseq_comp_modifiers
  7.1232 +      | Pos_Generator_DSeq => pos_generator_dseq_comp_modifiers)
  7.1233      val compfuns = Comp_Mod.compfuns comp_modifiers
  7.1234      val additional_arguments =
  7.1235 -      case compilation of
  7.1236 +      (case compilation of
  7.1237          Pred => []
  7.1238 -      | Random => map (HOLogic.mk_number @{typ "natural"}) arguments @
  7.1239 -        [@{term "(1, 1) :: natural * natural"}]
  7.1240 +      | Random =>
  7.1241 +          map (HOLogic.mk_number @{typ "natural"}) arguments @
  7.1242 +            [@{term "(1, 1) :: natural * natural"}]
  7.1243        | Annotated => []
  7.1244        | Depth_Limited => [HOLogic.mk_number @{typ "natural"} (hd arguments)]
  7.1245 -      | Depth_Limited_Random => map (HOLogic.mk_number @{typ "natural"}) arguments @
  7.1246 -        [@{term "(1, 1) :: natural * natural"}]
  7.1247 +      | Depth_Limited_Random =>
  7.1248 +          map (HOLogic.mk_number @{typ "natural"}) arguments @
  7.1249 +            [@{term "(1, 1) :: natural * natural"}]
  7.1250        | DSeq => []
  7.1251        | Pos_Random_DSeq => []
  7.1252        | New_Pos_Random_DSeq => []
  7.1253 -      | Pos_Generator_DSeq => []
  7.1254 -    val t = analyze_compr ctxt (comp_modifiers, additional_arguments) param_user_modes options t_compr;
  7.1255 -    val T = dest_monadT compfuns (fastype_of t);
  7.1256 +      | Pos_Generator_DSeq => [])
  7.1257 +    val t =
  7.1258 +      analyze_compr ctxt (comp_modifiers, additional_arguments) param_user_modes options t_compr
  7.1259 +    val T = dest_monadT compfuns (fastype_of t)
  7.1260      val t' =
  7.1261        if stats andalso compilation = New_Pos_Random_DSeq then
  7.1262          mk_map compfuns T (HOLogic.mk_prodT (HOLogic.termT, @{typ natural}))
  7.1263 @@ -1890,7 +1949,7 @@
  7.1264                (TimeLimit.timeLimit time_limit (fn () => fst (Lazy_Sequence.yieldn k
  7.1265                  (Code_Runtime.dynamic_value_strict
  7.1266                    (Lseq_Random_Result.get, put_lseq_random_result, "Predicate_Compile_Core.put_lseq_random_result")
  7.1267 -                  thy NONE 
  7.1268 +                  thy NONE
  7.1269                    (fn proc => fn g => fn nrandom => fn size => fn s => fn depth => g nrandom size s depth
  7.1270                      |> Lazy_Sequence.map proc)
  7.1271                      t' [] nrandom size seed depth))) ())
  7.1272 @@ -1908,20 +1967,21 @@
  7.1273      val setT = HOLogic.mk_setT T
  7.1274      val elems = HOLogic.mk_set T ts
  7.1275      val ([dots], ctxt') =
  7.1276 -      Proof_Context.add_fixes [(@{binding dots}, SOME setT, Mixfix ("...", [], 1000))] ctxt 
  7.1277 +      Proof_Context.add_fixes [(@{binding dots}, SOME setT, Mixfix ("...", [], 1000))] ctxt
  7.1278      (* check expected values *)
  7.1279      val union = Const (@{const_abbrev Set.union}, setT --> setT --> setT)
  7.1280      val () =
  7.1281 -      case raw_expected of
  7.1282 +      (case raw_expected of
  7.1283          NONE => ()
  7.1284        | SOME s =>
  7.1285          if eq_set (op =) (HOLogic.dest_set (Syntax.read_term ctxt s), ts) then ()
  7.1286          else
  7.1287            error ("expected and computed values do not match:\n" ^
  7.1288              "expected values: " ^ Syntax.string_of_term ctxt (Syntax.read_term ctxt s) ^ "\n" ^
  7.1289 -            "computed values: " ^ Syntax.string_of_term ctxt elems ^ "\n")
  7.1290 +            "computed values: " ^ Syntax.string_of_term ctxt elems ^ "\n"))
  7.1291    in
  7.1292 -    ((if k = ~1 orelse length ts < k then elems else union $ elems $ Free (dots, setT), statistics), ctxt')
  7.1293 +    ((if k = ~1 orelse length ts < k then elems else union $ elems $ Free (dots, setT), statistics),
  7.1294 +      ctxt')
  7.1295    end;
  7.1296  
  7.1297  fun values_cmd print_modes param_user_modes options k raw_t state =
  7.1298 @@ -1932,9 +1992,9 @@
  7.1299      val ty' = Term.type_of t'
  7.1300      val ctxt'' = Variable.auto_fixes t' ctxt'
  7.1301      val pretty_stat =
  7.1302 -      case stats of
  7.1303 -          NONE => []
  7.1304 -        | SOME xs =>
  7.1305 +      (case stats of
  7.1306 +        NONE => []
  7.1307 +      | SOME xs =>
  7.1308            let
  7.1309              val total = fold (curry (op +)) (map snd xs) 0
  7.1310              fun pretty_entry (s, n) =
  7.1311 @@ -1943,13 +2003,14 @@
  7.1312                 Pretty.str (string_of_int n), Pretty.fbrk]
  7.1313            in
  7.1314              [Pretty.fbrk, Pretty.str "Statistics:", Pretty.fbrk,
  7.1315 -             Pretty.str "total:", Pretty.brk 1, Pretty.str (string_of_int total), Pretty.fbrk]
  7.1316 -             @ maps pretty_entry xs
  7.1317 -          end
  7.1318 -    val p = Print_Mode.with_modes print_modes (fn () =>
  7.1319 +             Pretty.str "total:", Pretty.brk 1, Pretty.str (string_of_int total), Pretty.fbrk] @
  7.1320 +              maps pretty_entry xs
  7.1321 +          end)
  7.1322 +  in
  7.1323 +    Print_Mode.with_modes print_modes (fn () =>
  7.1324        Pretty.block ([Pretty.quote (Syntax.pretty_term ctxt'' t'), Pretty.fbrk,
  7.1325          Pretty.str "::", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt'' ty')]
  7.1326 -        @ pretty_stat)) ();
  7.1327 -  in Pretty.writeln p end;
  7.1328 +        @ pretty_stat)) ()
  7.1329 +  end |> Pretty.writeln
  7.1330  
  7.1331 -end;
  7.1332 +end
     8.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML	Wed Feb 12 13:31:18 2014 +0100
     8.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML	Wed Feb 12 13:33:05 2014 +0100
     8.3 @@ -11,11 +11,11 @@
     8.4    val keep_function : theory -> string -> bool
     8.5    val processed_specs : theory -> string -> (string * thm list) list option
     8.6    val store_processed_specs : (string * (string * thm list) list) -> theory -> theory
     8.7 -  
     8.8 +
     8.9    val get_specification : Predicate_Compile_Aux.options -> theory -> term -> thm list
    8.10    val obtain_specification_graph :
    8.11      Predicate_Compile_Aux.options -> theory -> term -> thm list Term_Graph.T
    8.12 -    
    8.13 +
    8.14    val present_graph : thm list Term_Graph.T -> unit
    8.15    val normalize_equation : theory -> thm -> thm
    8.16  end;
    8.17 @@ -66,7 +66,7 @@
    8.18    let
    8.19      val _ $ u = Logic.strip_imp_concl t
    8.20    in fst (strip_comb u) end
    8.21 -(*  
    8.22 +(*
    8.23    in case pred of
    8.24      Const (c, T) => c
    8.25      | _ => raise TERM ("defining_const_of_introrule_term failed: Not a constant", [t])
    8.26 @@ -75,9 +75,9 @@
    8.27  val defining_term_of_introrule = defining_term_of_introrule_term o prop_of
    8.28  
    8.29  fun defining_const_of_introrule th =
    8.30 -  case defining_term_of_introrule th
    8.31 -   of Const (c, _) => c
    8.32 -    | _ => raise TERM ("defining_const_of_introrule failed: Not a constant", [prop_of th])
    8.33 +  (case defining_term_of_introrule th of
    8.34 +    Const (c, _) => c
    8.35 +  | _ => raise TERM ("defining_const_of_introrule failed: Not a constant", [prop_of th]))
    8.36  
    8.37  (*TODO*)
    8.38  fun is_introlike_term _ = true
    8.39 @@ -85,29 +85,29 @@
    8.40  val is_introlike = is_introlike_term o prop_of
    8.41  
    8.42  fun check_equation_format_term (t as (Const ("==", _) $ u $ _)) =
    8.43 -  (case strip_comb u of
    8.44 -    (Const (_, T), args) =>
    8.45 -      if (length (binder_types T) = length args) then
    8.46 -        true
    8.47 -      else
    8.48 -        raise TERM ("check_equation_format_term failed: Number of arguments mismatch", [t])
    8.49 -  | _ => raise TERM ("check_equation_format_term failed: Not a constant", [t]))
    8.50 +      (case strip_comb u of
    8.51 +        (Const (_, T), args) =>
    8.52 +          if (length (binder_types T) = length args) then
    8.53 +            true
    8.54 +          else
    8.55 +            raise TERM ("check_equation_format_term failed: Number of arguments mismatch", [t])
    8.56 +      | _ => raise TERM ("check_equation_format_term failed: Not a constant", [t]))
    8.57    | check_equation_format_term t =
    8.58 -    raise TERM ("check_equation_format_term failed: Not an equation", [t])
    8.59 +      raise TERM ("check_equation_format_term failed: Not an equation", [t])
    8.60  
    8.61  val check_equation_format = check_equation_format_term o prop_of
    8.62  
    8.63  
    8.64  fun defining_term_of_equation_term (Const ("==", _) $ u $ _) = fst (strip_comb u)
    8.65    | defining_term_of_equation_term t =
    8.66 -    raise TERM ("defining_const_of_equation_term failed: Not an equation", [t])
    8.67 +      raise TERM ("defining_const_of_equation_term failed: Not an equation", [t])
    8.68  
    8.69  val defining_term_of_equation = defining_term_of_equation_term o prop_of
    8.70  
    8.71  fun defining_const_of_equation th =
    8.72 -  case defining_term_of_equation th
    8.73 -   of Const (c, _) => c
    8.74 -    | _ => raise TERM ("defining_const_of_equation failed: Not a constant", [prop_of th])
    8.75 +  (case defining_term_of_equation th of
    8.76 +    Const (c, _) => c
    8.77 +  | _ => raise TERM ("defining_const_of_equation failed: Not a constant", [prop_of th]))
    8.78  
    8.79  
    8.80  
    8.81 @@ -115,9 +115,10 @@
    8.82  (* Normalizing equations *)
    8.83  
    8.84  fun mk_meta_equation th =
    8.85 -  case prop_of th of
    8.86 -    Const (@{const_name Trueprop}, _) $ (Const (@{const_name HOL.eq}, _) $ _ $ _) => th RS @{thm eq_reflection}
    8.87 -  | _ => th
    8.88 +  (case prop_of th of
    8.89 +    Const (@{const_name Trueprop}, _) $ (Const (@{const_name HOL.eq}, _) $ _ $ _) =>
    8.90 +      th RS @{thm eq_reflection}
    8.91 +  | _ => th)
    8.92  
    8.93  val meta_fun_cong = @{lemma "f == g ==> f x == g x" by simp}
    8.94  
    8.95 @@ -131,13 +132,13 @@
    8.96    let
    8.97      val res = Name.invent_names ctxt s xs
    8.98    in (res, fold Name.declare (map fst res) ctxt) end
    8.99 -  
   8.100 +
   8.101  fun split_all_pairs thy th =
   8.102    let
   8.103      val ctxt = Proof_Context.init_global thy  (* FIXME proper context!? *)
   8.104      val ((_, [th']), _) = Variable.import true [th] ctxt
   8.105      val t = prop_of th'
   8.106 -    val frees = Term.add_frees t [] 
   8.107 +    val frees = Term.add_frees t []
   8.108      val freenames = Term.add_free_names t []
   8.109      val nctxt = Name.make_context freenames
   8.110      fun mk_tuple_rewrites (x, T) nctxt =
   8.111 @@ -146,7 +147,7 @@
   8.112          val (xTs, nctxt') = declare_names x Ts nctxt
   8.113          val paths = HOLogic.flat_tupleT_paths T
   8.114        in ((Free (x, T), HOLogic.mk_ptuple paths T (map Free xTs)), nctxt') end
   8.115 -    val (rewr, _) = fold_map mk_tuple_rewrites frees nctxt 
   8.116 +    val (rewr, _) = fold_map mk_tuple_rewrites frees nctxt
   8.117      val t' = Pattern.rewrite_term thy rewr [] t
   8.118      val th'' =
   8.119        Goal.prove ctxt (Term.add_free_names t' []) [] t'
   8.120 @@ -162,7 +163,7 @@
   8.121      val ctxt = Proof_Context.init_global thy
   8.122      val inline_defs = Predicate_Compile_Inline_Defs.get ctxt
   8.123      val th' = (Simplifier.full_simplify (put_simpset HOL_basic_ss ctxt addsimps inline_defs)) th
   8.124 -    (*val _ = print_step options 
   8.125 +    (*val _ = print_step options
   8.126        ("Inlining " ^ (Syntax.string_of_term_global thy (prop_of th))
   8.127         ^ "with " ^ (commas (map ((Syntax.string_of_term_global thy) o prop_of) inline_defs))
   8.128         ^" to " ^ (Syntax.string_of_term_global thy (prop_of th')))*)
   8.129 @@ -206,11 +207,13 @@
   8.130          else
   8.131            NONE
   8.132      fun filter_defs ths = map_filter filtering (map (normalize thy o Thm.transfer thy) ths)
   8.133 -    val spec = case filter_defs (Predicate_Compile_Alternative_Defs.get ctxt) of
   8.134 -      [] => (case Spec_Rules.retrieve ctxt t of
   8.135 -          [] => error ("No specification for " ^ (Syntax.string_of_term_global thy t))
   8.136 -        | ((_, (_, ths)) :: _) => filter_defs ths)
   8.137 -    | ths => rev ths
   8.138 +    val spec =
   8.139 +      (case filter_defs (Predicate_Compile_Alternative_Defs.get ctxt) of
   8.140 +        [] =>
   8.141 +          (case Spec_Rules.retrieve ctxt t of
   8.142 +            [] => error ("No specification for " ^ Syntax.string_of_term_global thy t)
   8.143 +          | ((_, (_, ths)) :: _) => filter_defs ths)
   8.144 +      | ths => rev ths)
   8.145      val _ =
   8.146        if show_intermediate_results options then
   8.147          tracing ("Specification for " ^ (Syntax.string_of_term_global thy t) ^ ":\n" ^
   8.148 @@ -221,38 +224,38 @@
   8.149    end
   8.150  
   8.151  val logic_operator_names =
   8.152 -  [@{const_name "=="}, 
   8.153 +  [@{const_name "=="},
   8.154     @{const_name "==>"},
   8.155     @{const_name Trueprop},
   8.156     @{const_name Not},
   8.157     @{const_name HOL.eq},
   8.158     @{const_name HOL.implies},
   8.159     @{const_name All},
   8.160 -   @{const_name Ex}, 
   8.161 +   @{const_name Ex},
   8.162     @{const_name HOL.conj},
   8.163     @{const_name HOL.disj}]
   8.164  
   8.165 -fun special_cases (c, _) = member (op =) [
   8.166 -  @{const_name Product_Type.Unity},
   8.167 -  @{const_name False},
   8.168 -  @{const_name Suc}, @{const_name Nat.zero_nat_inst.zero_nat},
   8.169 -  @{const_name Nat.one_nat_inst.one_nat},
   8.170 -  @{const_name Orderings.less}, @{const_name Orderings.less_eq},
   8.171 -  @{const_name Groups.zero},
   8.172 -  @{const_name Groups.one},  @{const_name Groups.plus},
   8.173 -  @{const_name Nat.ord_nat_inst.less_eq_nat},
   8.174 -  @{const_name Nat.ord_nat_inst.less_nat},
   8.175 -(* FIXME
   8.176 -  @{const_name number_nat_inst.number_of_nat},
   8.177 -*)
   8.178 -  @{const_name Num.Bit0},
   8.179 -  @{const_name Num.Bit1},
   8.180 -  @{const_name Num.One},
   8.181 -  @{const_name Int.zero_int_inst.zero_int},
   8.182 -  @{const_name List.filter},
   8.183 -  @{const_name HOL.If},
   8.184 -  @{const_name Groups.minus}
   8.185 -  ] c
   8.186 +fun special_cases (c, _) =
   8.187 +  member (op =)
   8.188 +   [@{const_name Product_Type.Unity},
   8.189 +    @{const_name False},
   8.190 +    @{const_name Suc}, @{const_name Nat.zero_nat_inst.zero_nat},
   8.191 +    @{const_name Nat.one_nat_inst.one_nat},
   8.192 +    @{const_name Orderings.less}, @{const_name Orderings.less_eq},
   8.193 +    @{const_name Groups.zero},
   8.194 +    @{const_name Groups.one},  @{const_name Groups.plus},
   8.195 +    @{const_name Nat.ord_nat_inst.less_eq_nat},
   8.196 +    @{const_name Nat.ord_nat_inst.less_nat},
   8.197 +  (* FIXME
   8.198 +    @{const_name number_nat_inst.number_of_nat},
   8.199 +  *)
   8.200 +    @{const_name Num.Bit0},
   8.201 +    @{const_name Num.Bit1},
   8.202 +    @{const_name Num.One},
   8.203 +    @{const_name Int.zero_int_inst.zero_int},
   8.204 +    @{const_name List.filter},
   8.205 +    @{const_name HOL.If},
   8.206 +    @{const_name Groups.minus}] c
   8.207  
   8.208  
   8.209  fun obtain_specification_graph options thy t =
   8.210 @@ -306,13 +309,12 @@
   8.211        |> map (the o Termtab.lookup mapping)
   8.212        |> distinct (eq_list eq_cname);
   8.213      val conn = [] |> fold (fn consts => cons (consts, succs consts)) constss;
   8.214 -    
   8.215 +
   8.216      fun namify consts = map string_of_const consts
   8.217        |> commas;
   8.218      val prgr = map (fn (consts, constss) =>
   8.219 -      { name = namify consts, ID = namify consts, dir = "", unfold = true,
   8.220 -        path = "", parents = map namify constss, content = [] }) conn;
   8.221 -  in Graph_Display.display_graph prgr end;
   8.222 +      {name = namify consts, ID = namify consts, dir = "", unfold = true,
   8.223 +       path = "", parents = map namify constss, content = [] }) conn
   8.224 +  in Graph_Display.display_graph prgr end
   8.225  
   8.226 -
   8.227 -end;
   8.228 +end
     9.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_fun.ML	Wed Feb 12 13:31:18 2014 +0100
     9.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_fun.ML	Wed Feb 12 13:33:05 2014 +0100
     9.3 @@ -32,16 +32,16 @@
     9.4      SOME (Envir.subst_term (Pattern.match thy (f, t) (Vartab.empty, Vartab.empty)) p)
     9.5      handle Pattern.MATCH => NONE) (Item_Net.retrieve net t)
     9.6    in
     9.7 -    case poss_preds of
     9.8 +    (case poss_preds of
     9.9        [p] => SOME p
    9.10 -    | _ => NONE
    9.11 +    | _ => NONE)
    9.12    end
    9.13  
    9.14  fun pred_of_function thy name =
    9.15 -  case Item_Net.retrieve (Fun_Pred.get thy) (Const (name, dummyT)) of
    9.16 +  (case Item_Net.retrieve (Fun_Pred.get thy) (Const (name, dummyT)) of
    9.17      [] => NONE
    9.18    | [(_, p)] => SOME (fst (dest_Const p))
    9.19 -  | _ => error ("Multiple matches possible for lookup of constant " ^ name)
    9.20 +  | _ => error ("Multiple matches possible for lookup of constant " ^ name))
    9.21  
    9.22  fun defined_const thy name = is_some (pred_of_function thy name)
    9.23  
    9.24 @@ -49,18 +49,18 @@
    9.25    Fun_Pred.map (Item_Net.update (f, p))
    9.26  
    9.27  fun transform_ho_typ (T as Type ("fun", _)) =
    9.28 -  let
    9.29 -    val (Ts, T') = strip_type T
    9.30 -  in if T' = HOLogic.boolT then T else (Ts @ [T']) ---> HOLogic.boolT end
    9.31 -| transform_ho_typ t = t
    9.32 +      let
    9.33 +        val (Ts, T') = strip_type T
    9.34 +      in if T' = HOLogic.boolT then T else (Ts @ [T']) ---> HOLogic.boolT end
    9.35 +  | transform_ho_typ t = t
    9.36  
    9.37 -fun transform_ho_arg arg = 
    9.38 -  case (fastype_of arg) of
    9.39 +fun transform_ho_arg arg =
    9.40 +  (case (fastype_of arg) of
    9.41      (T as Type ("fun", _)) =>
    9.42        (case arg of
    9.43          Free (name, _) => Free (name, transform_ho_typ T)
    9.44        | _ => raise Fail "A non-variable term at a higher-order position")
    9.45 -  | _ => arg
    9.46 +  | _ => arg)
    9.47  
    9.48  fun pred_type T =
    9.49    let
    9.50 @@ -88,43 +88,43 @@
    9.51      end;
    9.52  
    9.53  fun keep_functions thy t =
    9.54 -  case try dest_Const (fst (strip_comb t)) of
    9.55 +  (case try dest_Const (fst (strip_comb t)) of
    9.56      SOME (c, _) => Predicate_Compile_Data.keep_function thy c
    9.57 -  | _ => false
    9.58 +  | _ => false)
    9.59  
    9.60  fun flatten thy lookup_pred t (names, prems) =
    9.61    let
    9.62      fun lift t (names, prems) =
    9.63 -      case lookup_pred (Envir.eta_contract t) of
    9.64 +      (case lookup_pred (Envir.eta_contract t) of
    9.65          SOME pred => [(pred, (names, prems))]
    9.66        | NONE =>
    9.67 -        let
    9.68 -          val (vars, body) = strip_abs t
    9.69 -          val _ = @{assert} (fastype_of body = body_type (fastype_of body))
    9.70 -          val absnames = Name.variant_list names (map fst vars)
    9.71 -          val frees = map2 (curry Free) absnames (map snd vars)
    9.72 -          val body' = subst_bounds (rev frees, body)
    9.73 -          val resname = singleton (Name.variant_list (absnames @ names)) "res"
    9.74 -          val resvar = Free (resname, fastype_of body)
    9.75 -          val t = flatten' body' ([], [])
    9.76 -            |> map (fn (res, (inner_names, inner_prems)) =>
    9.77 -              let
    9.78 -                fun mk_exists (x, T) t = HOLogic.mk_exists (x, T, t)
    9.79 -                val vTs = 
    9.80 -                  fold Term.add_frees inner_prems []
    9.81 -                  |> filter (fn (x, _) => member (op =) inner_names x)
    9.82 -                val t = 
    9.83 -                  fold mk_exists vTs
    9.84 -                  (foldr1 HOLogic.mk_conj (HOLogic.mk_eq (res, resvar) ::
    9.85 -                    map HOLogic.dest_Trueprop inner_prems))
    9.86 -              in
    9.87 -                t
    9.88 -              end)
    9.89 -              |> foldr1 HOLogic.mk_disj
    9.90 -              |> fold lambda (resvar :: rev frees)
    9.91 -        in
    9.92 -          [(t, (names, prems))]
    9.93 -        end
    9.94 +          let
    9.95 +            val (vars, body) = strip_abs t
    9.96 +            val _ = @{assert} (fastype_of body = body_type (fastype_of body))
    9.97 +            val absnames = Name.variant_list names (map fst vars)
    9.98 +            val frees = map2 (curry Free) absnames (map snd vars)
    9.99 +            val body' = subst_bounds (rev frees, body)
   9.100 +            val resname = singleton (Name.variant_list (absnames @ names)) "res"
   9.101 +            val resvar = Free (resname, fastype_of body)
   9.102 +            val t = flatten' body' ([], [])
   9.103 +              |> map (fn (res, (inner_names, inner_prems)) =>
   9.104 +                let
   9.105 +                  fun mk_exists (x, T) t = HOLogic.mk_exists (x, T, t)
   9.106 +                  val vTs =
   9.107 +                    fold Term.add_frees inner_prems []
   9.108 +                    |> filter (fn (x, _) => member (op =) inner_names x)
   9.109 +                  val t =
   9.110 +                    fold mk_exists vTs
   9.111 +                    (foldr1 HOLogic.mk_conj (HOLogic.mk_eq (res, resvar) ::
   9.112 +                      map HOLogic.dest_Trueprop inner_prems))
   9.113 +                in
   9.114 +                  t
   9.115 +                end)
   9.116 +                |> foldr1 HOLogic.mk_disj
   9.117 +                |> fold lambda (resvar :: rev frees)
   9.118 +          in
   9.119 +            [(t, (names, prems))]
   9.120 +          end)
   9.121      and flatten_or_lift (t, T) (names, prems) =
   9.122        if fastype_of t = T then
   9.123          flatten' t (names, prems)
   9.124 @@ -134,7 +134,7 @@
   9.125            lift t (names, prems)
   9.126          else
   9.127            error ("unexpected input for flatten or lift" ^ Syntax.string_of_term_global thy t ^
   9.128 -          ", " ^  Syntax.string_of_typ_global thy T)
   9.129 +            ", " ^  Syntax.string_of_typ_global thy T)
   9.130      and flatten' (t as Const _) (names, prems) = [(t, (names, prems))]
   9.131        | flatten' (t as Free _) (names, prems) = [(t, (names, prems))]
   9.132        | flatten' (t as Abs _) (names, prems) = [(t, (names, prems))]
   9.133 @@ -156,7 +156,7 @@
   9.134                    (* in general unsound! *)
   9.135                    (res, (names, (HOLogic.mk_Trueprop (HOLogic.mk_not B')) :: prems)))))
   9.136              end)
   9.137 -        | Const (@{const_name "Let"}, _) => 
   9.138 +        | Const (@{const_name "Let"}, _) =>
   9.139              (let
   9.140                val (_, [f, g]) = strip_comb t
   9.141              in
   9.142 @@ -199,9 +199,10 @@
   9.143              val args = map (Envir.eta_long []) args
   9.144              val _ = @{assert} (fastype_of t = body_type (fastype_of t))
   9.145              val f' = lookup_pred f
   9.146 -            val Ts = case f' of
   9.147 -              SOME pred => (fst (split_last (binder_types (fastype_of pred))))
   9.148 -            | NONE => binder_types (fastype_of f)
   9.149 +            val Ts =
   9.150 +              (case f' of
   9.151 +                SOME pred => (fst (split_last (binder_types (fastype_of pred))))
   9.152 +              | NONE => binder_types (fastype_of f))
   9.153            in
   9.154              folds_map flatten_or_lift (args ~~ Ts) (names, prems) |>
   9.155              (case f' of
   9.156 @@ -272,7 +273,8 @@
   9.157        fun mk_intros ((func, pred), (args, rhs)) =
   9.158          if (body_type (fastype_of func) = @{typ bool}) then
   9.159           (* TODO: preprocess predicate definition of rhs *)
   9.160 -          [Logic.list_implies ([HOLogic.mk_Trueprop rhs], HOLogic.mk_Trueprop (list_comb (pred, args)))]
   9.161 +          [Logic.list_implies
   9.162 +            ([HOLogic.mk_Trueprop rhs], HOLogic.mk_Trueprop (list_comb (pred, args)))]
   9.163          else
   9.164            let
   9.165              val names = Term.add_free_names rhs []
   9.166 @@ -316,9 +318,10 @@
   9.167        let
   9.168          (*val _ = tracing ("Rewriting premise " ^ Syntax.string_of_term_global thy prem ^ "...")*)
   9.169          val t = HOLogic.dest_Trueprop prem
   9.170 -        val (lit, mk_lit) = case try HOLogic.dest_not t of
   9.171 +        val (lit, mk_lit) =
   9.172 +          (case try HOLogic.dest_not t of
   9.173              SOME t => (t, HOLogic.mk_not)
   9.174 -          | NONE => (t, I)
   9.175 +          | NONE => (t, I))
   9.176          val (P, args) = strip_comb lit
   9.177        in
   9.178          folds_map (flatten thy lookup_pred) args (names, [])
   9.179 @@ -342,4 +345,4 @@
   9.180      map (Drule.export_without_context o Skip_Proof.make_thm thy) intro_ts'
   9.181    end
   9.182  
   9.183 -end;
   9.184 +end
    10.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_pred.ML	Wed Feb 12 13:31:18 2014 +0100
    10.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_pred.ML	Wed Feb 12 13:33:05 2014 +0100
    10.3 @@ -20,15 +20,15 @@
    10.4  open Predicate_Compile_Aux
    10.5  
    10.6  fun is_compound ((Const (@{const_name Not}, _)) $ _) =
    10.7 -    error "is_compound: Negation should not occur; preprocessing is defect"
    10.8 +      error "is_compound: Negation should not occur; preprocessing is defect"
    10.9    | is_compound ((Const (@{const_name Ex}, _)) $ _) = true
   10.10    | is_compound ((Const (@{const_name HOL.disj}, _)) $ _ $ _) = true
   10.11    | is_compound ((Const (@{const_name HOL.conj}, _)) $ _ $ _) =
   10.12 -    error "is_compound: Conjunction should not occur; preprocessing is defect"
   10.13 +      error "is_compound: Conjunction should not occur; preprocessing is defect"
   10.14    | is_compound _ = false
   10.15  
   10.16  fun try_destruct_case thy names atom =
   10.17 -  case find_split_thm thy (fst (strip_comb atom)) of
   10.18 +  (case find_split_thm thy (fst (strip_comb atom)) of
   10.19      NONE => NONE
   10.20    | SOME raw_split_thm =>
   10.21      let
   10.22 @@ -48,17 +48,17 @@
   10.23            val vars = map Free (var_names ~~ (map snd vTs))
   10.24            val (prems', pre_res) = Logic.strip_horn (subst_bounds (rev vars, assm'))
   10.25            fun partition_prem_subst prem =
   10.26 -            case HOLogic.dest_eq (HOLogic.dest_Trueprop prem) of
   10.27 +            (case HOLogic.dest_eq (HOLogic.dest_Trueprop prem) of
   10.28                (Free (x, T), r) => (NONE, SOME ((x, T), r))
   10.29 -            | _ => (SOME prem, NONE)
   10.30 +            | _ => (SOME prem, NONE))
   10.31            fun partition f xs =
   10.32              let
   10.33                fun partition' acc1 acc2 [] = (rev acc1, rev acc2)
   10.34                  | partition' acc1 acc2 (x :: xs) =
   10.35                    let
   10.36                      val (y, z) = f x
   10.37 -                    val acc1' = case y of NONE => acc1 | SOME y' => y' :: acc1
   10.38 -                    val acc2' = case z of NONE => acc2 | SOME z' => z' :: acc2
   10.39 +                    val acc1' = (case y of NONE => acc1 | SOME y' => y' :: acc1)
   10.40 +                    val acc2' = (case z of NONE => acc2 | SOME z' => z' :: acc2)
   10.41                    in partition' acc1' acc2' xs end
   10.42              in partition' [] [] xs end
   10.43            val (prems'', subst) = partition partition_prem_subst prems'
   10.44 @@ -67,18 +67,19 @@
   10.45              fold (curry HOLogic.mk_conj) (map HOLogic.dest_Trueprop prems'') inner_t
   10.46            val rhs = Envir.expand_term_frees subst pre_rhs
   10.47          in
   10.48 -          case try_destruct_case thy (var_names @ names') rhs of
   10.49 +          (case try_destruct_case thy (var_names @ names') rhs of
   10.50              NONE => [(subst, rhs)]
   10.51 -          | SOME (_, srs) => map (fn (subst', rhs') => (subst @ subst', rhs')) srs
   10.52 +          | SOME (_, srs) => map (fn (subst', rhs') => (subst @ subst', rhs')) srs)
   10.53          end
   10.54 -     in SOME (atom', maps mk_subst_rhs assms) end
   10.55 +     in SOME (atom', maps mk_subst_rhs assms) end)
   10.56       
   10.57  fun flatten constname atom (defs, thy) =
   10.58    if is_compound atom then
   10.59      let
   10.60        val atom = Envir.beta_norm (Envir.eta_long [] atom)
   10.61 -      val constname = singleton (Name.variant_list (map (Long_Name.base_name o fst) defs))
   10.62 -        ((Long_Name.base_name constname) ^ "_aux")
   10.63 +      val constname =
   10.64 +        singleton (Name.variant_list (map (Long_Name.base_name o fst) defs))
   10.65 +          ((Long_Name.base_name constname) ^ "_aux")
   10.66        val full_constname = Sign.full_bname thy constname
   10.67        val (params, args) = List.partition (is_predT o fastype_of)
   10.68          (map Free (Term.add_frees atom []))
   10.69 @@ -92,7 +93,7 @@
   10.70        (lhs, ((full_constname, [definition]) :: defs, thy'))
   10.71      end
   10.72    else
   10.73 -    case (fst (strip_comb atom)) of
   10.74 +    (case (fst (strip_comb atom)) of
   10.75        (Const (@{const_name If}, _)) =>
   10.76          let
   10.77            val if_beta = @{lemma "(if c then x else y) z = (if c then x z else y z)" by simp}
   10.78 @@ -103,28 +104,28 @@
   10.79            flatten constname atom' (defs, thy)
   10.80          end
   10.81      | _ =>
   10.82 -      case try_destruct_case thy [] atom of
   10.83 -        NONE => (atom, (defs, thy))
   10.84 -      | SOME (atom', srs) =>
   10.85 -        let      
   10.86 -          val frees = map Free (Term.add_frees atom' [])
   10.87 -          val constname = singleton (Name.variant_list (map (Long_Name.base_name o fst) defs))
   10.88 -           ((Long_Name.base_name constname) ^ "_aux")
   10.89 -          val full_constname = Sign.full_bname thy constname
   10.90 -          val constT = map fastype_of frees ---> HOLogic.boolT
   10.91 -          val lhs = list_comb (Const (full_constname, constT), frees)
   10.92 -          fun mk_def (subst, rhs) =
   10.93 -            Logic.mk_equals (fold Envir.expand_term_frees (map single subst) lhs, rhs)
   10.94 -          val new_defs = map mk_def srs
   10.95 -          val (definition, thy') = thy
   10.96 -          |> Sign.add_consts_i [(Binding.name constname, constT, NoSyn)]
   10.97 -          |> fold_map Specification.axiom  (* FIXME !?!?!?! *)
   10.98 -            (map_index (fn (i, t) =>
   10.99 -              ((Binding.name (constname ^ "_def" ^ string_of_int i), []), t)) new_defs)
  10.100 -        in
  10.101 -          (lhs, ((full_constname, map Drule.export_without_context definition) :: defs, thy'))
  10.102 -        end
  10.103 -
  10.104 +        (case try_destruct_case thy [] atom of
  10.105 +          NONE => (atom, (defs, thy))
  10.106 +        | SOME (atom', srs) =>
  10.107 +            let      
  10.108 +              val frees = map Free (Term.add_frees atom' [])
  10.109 +              val constname =
  10.110 +                singleton (Name.variant_list (map (Long_Name.base_name o fst) defs))
  10.111 +                  ((Long_Name.base_name constname) ^ "_aux")
  10.112 +              val full_constname = Sign.full_bname thy constname
  10.113 +              val constT = map fastype_of frees ---> HOLogic.boolT
  10.114 +              val lhs = list_comb (Const (full_constname, constT), frees)
  10.115 +              fun mk_def (subst, rhs) =
  10.116 +                Logic.mk_equals (fold Envir.expand_term_frees (map single subst) lhs, rhs)
  10.117 +              val new_defs = map mk_def srs
  10.118 +              val (definition, thy') = thy
  10.119 +              |> Sign.add_consts_i [(Binding.name constname, constT, NoSyn)]
  10.120 +              |> fold_map Specification.axiom  (* FIXME !?!?!?! *)
  10.121 +                (map_index (fn (i, t) =>
  10.122 +                  ((Binding.name (constname ^ "_def" ^ string_of_int i), []), t)) new_defs)
  10.123 +            in
  10.124 +              (lhs, ((full_constname, map Drule.export_without_context definition) :: defs, thy'))
  10.125 +            end))
  10.126  
  10.127  fun flatten_intros constname intros thy =
  10.128    let
  10.129 @@ -143,7 +144,7 @@
  10.130  (* TODO: same function occurs in inductive package *)
  10.131  fun select_disj 1 1 = []
  10.132    | select_disj _ 1 = [rtac @{thm disjI1}]
  10.133 -  | select_disj n i = (rtac @{thm disjI2})::(select_disj (n - 1) (i - 1));
  10.134 +  | select_disj n i = (rtac @{thm disjI2})::(select_disj (n - 1) (i - 1))
  10.135  
  10.136  fun introrulify thy ths = 
  10.137    let
  10.138 @@ -258,8 +259,9 @@
  10.139                  |> process constname t1 
  10.140                  ||>> process constname t2
  10.141                  |>> HOLogic.mk_prod
  10.142 -            | NONE => (warning ("Replacing higher order arguments " ^
  10.143 -              "is not applied in an undestructable product type"); (arg, (new_defs, thy))))
  10.144 +            | NONE =>
  10.145 +              (warning ("Replacing higher order arguments " ^
  10.146 +                "is not applied in an undestructable product type"); (arg, (new_defs, thy))))
  10.147            else if (is_predT (fastype_of arg)) then
  10.148              process constname arg (new_defs, thy)
  10.149            else
  10.150 @@ -274,7 +276,8 @@
  10.151        let
  10.152          val constname = fst (dest_Const (fst (strip_comb
  10.153            (HOLogic.dest_Trueprop (Logic.strip_imp_concl (prop_of intro))))))
  10.154 -        val (intro_ts, (new_defs, thy)) = fold_map_atoms (process constname) (prop_of intro) (new_defs, thy)
  10.155 +        val (intro_ts, (new_defs, thy)) =
  10.156 +          fold_map_atoms (process constname) (prop_of intro) (new_defs, thy)
  10.157          val th = Skip_Proof.make_thm thy intro_ts
  10.158        in
  10.159          (th, (new_defs, thy))
  10.160 @@ -290,4 +293,4 @@
  10.161      (intross', (new_defs, thy'))
  10.162    end
  10.163  
  10.164 -end;
  10.165 +end
    11.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_proof.ML	Wed Feb 12 13:31:18 2014 +0100
    11.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_proof.ML	Wed Feb 12 13:33:05 2014 +0100
    11.3 @@ -22,28 +22,34 @@
    11.4  open Core_Data;
    11.5  open Mode_Inference;
    11.6  
    11.7 +
    11.8  (* debug stuff *)
    11.9  
   11.10  fun print_tac options s = 
   11.11    if show_proof_trace options then Tactical.print_tac s else Seq.single;
   11.12  
   11.13 +
   11.14  (** auxiliary **)
   11.15  
   11.16  datatype assertion = Max_number_of_subgoals of int
   11.17 +
   11.18  fun assert_tac (Max_number_of_subgoals i) st =
   11.19    if (nprems_of st <= i) then Seq.single st
   11.20 -  else raise Fail ("assert_tac: Numbers of subgoals mismatch at goal state :"
   11.21 -    ^ "\n" ^ Pretty.string_of (Pretty.chunks
   11.22 -      (Goal_Display.pretty_goals_without_context st)));
   11.23 +  else
   11.24 +    raise Fail ("assert_tac: Numbers of subgoals mismatch at goal state :\n" ^
   11.25 +      Pretty.string_of (Pretty.chunks
   11.26 +        (Goal_Display.pretty_goals_without_context st)))
   11.27  
   11.28  
   11.29  (** special setup for simpset **)
   11.30 +
   11.31  val HOL_basic_ss' =
   11.32    simpset_of (put_simpset HOL_basic_ss @{context}
   11.33      addsimps @{thms simp_thms Pair_eq}
   11.34      setSolver (mk_solver "all_tac_solver" (fn _ => fn _ => all_tac))
   11.35      setSolver (mk_solver "True_solver" (fn _ => rtac @{thm TrueI})))
   11.36  
   11.37 +
   11.38  (* auxillary functions *)
   11.39  
   11.40  fun is_Type (Type _) = true
   11.41 @@ -53,15 +59,18 @@
   11.42  (* which then consequently would be splitted *)
   11.43  (* else false *)
   11.44  fun is_constructor thy t =
   11.45 -  if (is_Type (fastype_of t)) then
   11.46 +  if is_Type (fastype_of t) then
   11.47      (case Datatype.get_info thy ((fst o dest_Type o fastype_of) t) of
   11.48        NONE => false
   11.49 -    | SOME info => (let
   11.50 -      val constr_consts = maps (fn (_, (_, _, constrs)) => map fst constrs) (#descr info)
   11.51 -      val (c, _) = strip_comb t
   11.52 -      in (case c of
   11.53 -        Const (name, _) => member (op =) constr_consts name
   11.54 -        | _ => false) end))
   11.55 +    | SOME info =>
   11.56 +        let
   11.57 +          val constr_consts = maps (fn (_, (_, _, constrs)) => map fst constrs) (#descr info)
   11.58 +          val (c, _) = strip_comb t
   11.59 +        in
   11.60 +          (case c of
   11.61 +            Const (name, _) => member (op =) constr_consts name
   11.62 +          | _ => false)
   11.63 +        end)
   11.64    else false
   11.65  
   11.66  (* MAJOR FIXME:  prove_params should be simple
   11.67 @@ -73,19 +82,20 @@
   11.68      val mode = head_mode_of deriv
   11.69      val param_derivations = param_derivations_of deriv
   11.70      val ho_args = ho_args_of mode args
   11.71 -    val f_tac = case f of
   11.72 -      Const (name, _) => simp_tac (put_simpset HOL_basic_ss ctxt addsimps
   11.73 -         [@{thm eval_pred}, predfun_definition_of ctxt name mode,
   11.74 -         @{thm split_eta}, @{thm split_beta}, @{thm fst_conv},
   11.75 -         @{thm snd_conv}, @{thm pair_collapse}, @{thm Product_Type.split_conv}]) 1
   11.76 -    | Free _ =>
   11.77 -      Subgoal.FOCUS_PREMS (fn {context = ctxt', params = params, prems, asms, concl, schematics} =>
   11.78 -        let
   11.79 -          val prems' = maps dest_conjunct_prem (take nargs prems)
   11.80 -        in
   11.81 -          rewrite_goal_tac ctxt' (map (fn th => th RS @{thm sym} RS @{thm eq_reflection}) prems') 1
   11.82 -        end) ctxt 1
   11.83 -    | Abs _ => raise Fail "prove_param: No valid parameter term"
   11.84 +    val f_tac =
   11.85 +      (case f of
   11.86 +        Const (name, _) => simp_tac (put_simpset HOL_basic_ss ctxt addsimps
   11.87 +           [@{thm eval_pred}, predfun_definition_of ctxt name mode,
   11.88 +           @{thm split_eta}, @{thm split_beta}, @{thm fst_conv},
   11.89 +           @{thm snd_conv}, @{thm pair_collapse}, @{thm Product_Type.split_conv}]) 1
   11.90 +      | Free _ =>
   11.91 +        Subgoal.FOCUS_PREMS (fn {context = ctxt', params = params, prems, asms, concl, schematics} =>
   11.92 +          let
   11.93 +            val prems' = maps dest_conjunct_prem (take nargs prems)
   11.94 +          in
   11.95 +            rewrite_goal_tac ctxt' (map (fn th => th RS @{thm sym} RS @{thm eq_reflection}) prems') 1
   11.96 +          end) ctxt 1
   11.97 +      | Abs _ => raise Fail "prove_param: No valid parameter term")
   11.98    in
   11.99      REPEAT_DETERM (rtac @{thm ext} 1)
  11.100      THEN print_tac options "prove_param"
  11.101 @@ -97,7 +107,7 @@
  11.102    end
  11.103  
  11.104  fun prove_expr options ctxt nargs (premposition : int) (t, deriv) =
  11.105 -  case strip_comb t of
  11.106 +  (case strip_comb t of
  11.107      (Const (name, _), args) =>
  11.108        let
  11.109          val mode = head_mode_of deriv
  11.110 @@ -117,25 +127,25 @@
  11.111          THEN (REPEAT_DETERM (atac 1))
  11.112        end
  11.113    | (Free _, _) =>
  11.114 -    print_tac options "proving parameter call.."
  11.115 -    THEN Subgoal.FOCUS_PREMS (fn {context = ctxt', params, prems, asms, concl, schematics} =>
  11.116 -        let
  11.117 -          val param_prem = nth prems premposition
  11.118 -          val (param, _) = strip_comb (HOLogic.dest_Trueprop (prop_of param_prem))
  11.119 -          val prems' = maps dest_conjunct_prem (take nargs prems)
  11.120 -          fun param_rewrite prem =
  11.121 -            param = snd (HOLogic.dest_eq (HOLogic.dest_Trueprop (prop_of prem)))
  11.122 -          val SOME rew_eq = find_first param_rewrite prems'
  11.123 -          val param_prem' = rewrite_rule ctxt'
  11.124 -            (map (fn th => th RS @{thm eq_reflection})
  11.125 -              [rew_eq RS @{thm sym}, @{thm split_beta}, @{thm fst_conv}, @{thm snd_conv}])
  11.126 -            param_prem
  11.127 -        in
  11.128 -          rtac param_prem' 1
  11.129 -        end) ctxt 1
  11.130 -    THEN print_tac options "after prove parameter call"
  11.131 +      print_tac options "proving parameter call.."
  11.132 +      THEN Subgoal.FOCUS_PREMS (fn {context = ctxt', params, prems, asms, concl, schematics} =>
  11.133 +          let
  11.134 +            val param_prem = nth prems premposition
  11.135 +            val (param, _) = strip_comb (HOLogic.dest_Trueprop (prop_of param_prem))
  11.136 +            val prems' = maps dest_conjunct_prem (take nargs prems)
  11.137 +            fun param_rewrite prem =
  11.138 +              param = snd (HOLogic.dest_eq (HOLogic.dest_Trueprop (prop_of prem)))
  11.139 +            val SOME rew_eq = find_first param_rewrite prems'
  11.140 +            val param_prem' = rewrite_rule ctxt'
  11.141 +              (map (fn th => th RS @{thm eq_reflection})
  11.142 +                [rew_eq RS @{thm sym}, @{thm split_beta}, @{thm fst_conv}, @{thm snd_conv}])
  11.143 +              param_prem
  11.144 +          in
  11.145 +            rtac param_prem' 1
  11.146 +          end) ctxt 1
  11.147 +      THEN print_tac options "after prove parameter call")
  11.148  
  11.149 -fun SOLVED tac st = FILTER (fn st' => nprems_of st' = nprems_of st - 1) tac st;
  11.150 +fun SOLVED tac st = FILTER (fn st' => nprems_of st' = nprems_of st - 1) tac st
  11.151  
  11.152  fun prove_match options ctxt nargs out_ts =
  11.153    let
  11.154 @@ -154,7 +164,7 @@
  11.155        (fold (union Thm.eq_thm) (map get_case_rewrite out_ts) []))
  11.156    (* replace TRY by determining if it necessary - are there equations when calling compile match? *)
  11.157    in
  11.158 -     (* make this simpset better! *)
  11.159 +    (* make this simpset better! *)
  11.160      asm_full_simp_tac (put_simpset HOL_basic_ss' ctxt addsimps simprules) 1
  11.161      THEN print_tac options "after prove_match:"
  11.162      THEN (DETERM (TRY 
  11.163 @@ -176,15 +186,17 @@
  11.164      THEN print_tac options "after if simplification"
  11.165    end;
  11.166  
  11.167 +
  11.168  (* corresponds to compile_fun -- maybe call that also compile_sidecond? *)
  11.169  
  11.170  fun prove_sidecond ctxt t =
  11.171    let
  11.172 -    fun preds_of t nameTs = case strip_comb t of 
  11.173 -      (Const (name, T), args) =>
  11.174 -        if is_registered ctxt name then (name, T) :: nameTs
  11.175 -          else fold preds_of args nameTs
  11.176 -      | _ => nameTs
  11.177 +    fun preds_of t nameTs =
  11.178 +      (case strip_comb t of
  11.179 +        (Const (name, T), args) =>
  11.180 +          if is_registered ctxt name then (name, T) :: nameTs
  11.181 +            else fold preds_of args nameTs
  11.182 +      | _ => nameTs)
  11.183      val preds = preds_of t []
  11.184      val defs = map
  11.185        (fn (pred, T) => predfun_definition_of ctxt pred
  11.186 @@ -200,88 +212,88 @@
  11.187    let
  11.188      val (in_ts, clause_out_ts) = split_mode mode ts;
  11.189      fun prove_prems out_ts [] =
  11.190 -      (prove_match options ctxt nargs out_ts)
  11.191 -      THEN print_tac options "before simplifying assumptions"
  11.192 -      THEN asm_full_simp_tac (put_simpset HOL_basic_ss' ctxt) 1
  11.193 -      THEN print_tac options "before single intro rule"
  11.194 -      THEN Subgoal.FOCUS_PREMS
  11.195 -         (fn {context = ctxt', params, prems, asms, concl, schematics} =>
  11.196 -          let
  11.197 -            val prems' = maps dest_conjunct_prem (take nargs prems)
  11.198 -          in
  11.199 -            rewrite_goal_tac ctxt' (map (fn th => th RS @{thm sym} RS @{thm eq_reflection}) prems') 1
  11.200 -          end) ctxt 1
  11.201 -      THEN (rtac (if null clause_out_ts then @{thm singleI_unit} else @{thm singleI}) 1)
  11.202 -    | prove_prems out_ts ((p, deriv) :: ps) =
  11.203 -      let
  11.204 -        val premposition = (find_index (equal p) clauses) + nargs
  11.205 -        val mode = head_mode_of deriv
  11.206 -        val rest_tac =
  11.207 -          rtac @{thm bindI} 1
  11.208 -          THEN (case p of Prem t =>
  11.209 -            let
  11.210 -              val (_, us) = strip_comb t
  11.211 -              val (_, out_ts''') = split_mode mode us
  11.212 -              val rec_tac = prove_prems out_ts''' ps
  11.213 -            in
  11.214 -              print_tac options "before clause:"
  11.215 -              (*THEN asm_simp_tac (put_simpset HOL_basic_ss ctxt) 1*)
  11.216 -              THEN print_tac options "before prove_expr:"
  11.217 -              THEN prove_expr options ctxt nargs premposition (t, deriv)
  11.218 -              THEN print_tac options "after prove_expr:"
  11.219 -              THEN rec_tac
  11.220 -            end
  11.221 -          | Negprem t =>
  11.222 +        (prove_match options ctxt nargs out_ts)
  11.223 +        THEN print_tac options "before simplifying assumptions"
  11.224 +        THEN asm_full_simp_tac (put_simpset HOL_basic_ss' ctxt) 1
  11.225 +        THEN print_tac options "before single intro rule"
  11.226 +        THEN Subgoal.FOCUS_PREMS
  11.227 +           (fn {context = ctxt', params, prems, asms, concl, schematics} =>
  11.228              let
  11.229 -              val (t, args) = strip_comb t
  11.230 -              val (_, out_ts''') = split_mode mode args
  11.231 -              val rec_tac = prove_prems out_ts''' ps
  11.232 -              val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE)
  11.233 -              val neg_intro_rule =
  11.234 -                Option.map (fn name =>
  11.235 -                  the (predfun_neg_intro_of ctxt name mode)) name
  11.236 -              val param_derivations = param_derivations_of deriv
  11.237 -              val params = ho_args_of mode args
  11.238 +              val prems' = maps dest_conjunct_prem (take nargs prems)
  11.239              in
  11.240 -              print_tac options "before prove_neg_expr:"
  11.241 -              THEN full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps
  11.242 -                [@{thm split_eta}, @{thm split_beta}, @{thm fst_conv},
  11.243 -                 @{thm snd_conv}, @{thm pair_collapse}, @{thm Product_Type.split_conv}]) 1
  11.244 -              THEN (if (is_some name) then
  11.245 -                  print_tac options "before applying not introduction rule"
  11.246 -                  THEN Subgoal.FOCUS_PREMS
  11.247 -                    (fn {context, params = params, prems, asms, concl, schematics} =>
  11.248 -                      rtac (the neg_intro_rule) 1
  11.249 -                      THEN rtac (nth prems premposition) 1) ctxt 1
  11.250 -                  THEN print_tac options "after applying not introduction rule"
  11.251 -                  THEN (EVERY (map2 (prove_param options ctxt nargs) params param_derivations))
  11.252 -                  THEN (REPEAT_DETERM (atac 1))
  11.253 -                else
  11.254 -                  rtac @{thm not_predI'} 1
  11.255 -                  (* test: *)
  11.256 -                  THEN dtac @{thm sym} 1
  11.257 -                  THEN asm_full_simp_tac
  11.258 -                    (put_simpset HOL_basic_ss ctxt addsimps [@{thm not_False_eq_True}]) 1)
  11.259 -                  THEN simp_tac
  11.260 -                    (put_simpset HOL_basic_ss ctxt addsimps [@{thm not_False_eq_True}]) 1
  11.261 -              THEN rec_tac
  11.262 -            end
  11.263 -          | Sidecond t =>
  11.264 -           rtac @{thm if_predI} 1
  11.265 -           THEN print_tac options "before sidecond:"
  11.266 -           THEN prove_sidecond ctxt t
  11.267 -           THEN print_tac options "after sidecond:"
  11.268 -           THEN prove_prems [] ps)
  11.269 -      in (prove_match options ctxt nargs out_ts)
  11.270 -          THEN rest_tac
  11.271 -      end;
  11.272 +              rewrite_goal_tac ctxt' (map (fn th => th RS @{thm sym} RS @{thm eq_reflection}) prems') 1
  11.273 +            end) ctxt 1
  11.274 +        THEN (rtac (if null clause_out_ts then @{thm singleI_unit} else @{thm singleI}) 1)
  11.275 +    | prove_prems out_ts ((p, deriv) :: ps) =
  11.276 +        let
  11.277 +          val premposition = (find_index (equal p) clauses) + nargs
  11.278 +          val mode = head_mode_of deriv
  11.279 +          val rest_tac =
  11.280 +            rtac @{thm bindI} 1
  11.281 +            THEN (case p of Prem t =>
  11.282 +              let
  11.283 +                val (_, us) = strip_comb t
  11.284 +                val (_, out_ts''') = split_mode mode us
  11.285 +                val rec_tac = prove_prems out_ts''' ps
  11.286 +              in
  11.287 +                print_tac options "before clause:"
  11.288 +                (*THEN asm_simp_tac (put_simpset HOL_basic_ss ctxt) 1*)
  11.289 +                THEN print_tac options "before prove_expr:"
  11.290 +                THEN prove_expr options ctxt nargs premposition (t, deriv)
  11.291 +                THEN print_tac options "after prove_expr:"
  11.292 +                THEN rec_tac
  11.293 +              end
  11.294 +            | Negprem t =>
  11.295 +              let
  11.296 +                val (t, args) = strip_comb t
  11.297 +                val (_, out_ts''') = split_mode mode args
  11.298 +                val rec_tac = prove_prems out_ts''' ps
  11.299 +                val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE)
  11.300 +                val neg_intro_rule =
  11.301 +                  Option.map (fn name =>
  11.302 +                    the (predfun_neg_intro_of ctxt name mode)) name
  11.303 +                val param_derivations = param_derivations_of deriv
  11.304 +                val params = ho_args_of mode args
  11.305 +              in
  11.306 +                print_tac options "before prove_neg_expr:"
  11.307 +                THEN full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps
  11.308 +                  [@{thm split_eta}, @{thm split_beta}, @{thm fst_conv},
  11.309 +                   @{thm snd_conv}, @{thm pair_collapse}, @{thm Product_Type.split_conv}]) 1
  11.310 +                THEN (if (is_some name) then
  11.311 +                    print_tac options "before applying not introduction rule"
  11.312 +                    THEN Subgoal.FOCUS_PREMS
  11.313 +                      (fn {context, params = params, prems, asms, concl, schematics} =>
  11.314 +                        rtac (the neg_intro_rule) 1
  11.315 +                        THEN rtac (nth prems premposition) 1) ctxt 1
  11.316 +                    THEN print_tac options "after applying not introduction rule"
  11.317 +                    THEN (EVERY (map2 (prove_param options ctxt nargs) params param_derivations))
  11.318 +                    THEN (REPEAT_DETERM (atac 1))
  11.319 +                  else
  11.320 +                    rtac @{thm not_predI'} 1
  11.321 +                    (* test: *)
  11.322 +                    THEN dtac @{thm sym} 1
  11.323 +                    THEN asm_full_simp_tac
  11.324 +                      (put_simpset HOL_basic_ss ctxt addsimps [@{thm not_False_eq_True}]) 1)
  11.325 +                    THEN simp_tac
  11.326 +                      (put_simpset HOL_basic_ss ctxt addsimps [@{thm not_False_eq_True}]) 1
  11.327 +                THEN rec_tac
  11.328 +              end
  11.329 +            | Sidecond t =>
  11.330 +             rtac @{thm if_predI} 1
  11.331 +             THEN print_tac options "before sidecond:"
  11.332 +             THEN prove_sidecond ctxt t
  11.333 +             THEN print_tac options "after sidecond:"
  11.334 +             THEN prove_prems [] ps)
  11.335 +        in (prove_match options ctxt nargs out_ts)
  11.336 +            THEN rest_tac
  11.337 +        end
  11.338      val prems_tac = prove_prems in_ts moded_ps
  11.339    in
  11.340      print_tac options "Proving clause..."
  11.341      THEN rtac @{thm bindI} 1
  11.342      THEN rtac @{thm singleI} 1
  11.343      THEN prems_tac
  11.344 -  end;
  11.345 +  end
  11.346  
  11.347  fun select_sup 1 1 = []
  11.348    | select_sup _ 1 = [rtac @{thm supI1}]
  11.349 @@ -303,7 +315,8 @@
  11.350               (1 upto (length moded_clauses))))
  11.351      THEN (EVERY (map2 (prove_clause options ctxt nargs mode) clauses moded_clauses))
  11.352      THEN print_tac options "proved one direction"
  11.353 -  end;
  11.354 +  end
  11.355 +
  11.356  
  11.357  (** Proof in the other direction **)
  11.358  
  11.359 @@ -348,12 +361,13 @@
  11.360      val mode = head_mode_of deriv
  11.361      val param_derivations = param_derivations_of deriv
  11.362      val ho_args = ho_args_of mode args
  11.363 -    val f_tac = case f of
  11.364 +    val f_tac =
  11.365 +      (case f of
  11.366          Const (name, _) => full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps 
  11.367             (@{thm eval_pred}::(predfun_definition_of ctxt name mode)
  11.368             :: @{thm "Product_Type.split_conv"}::[])) 1
  11.369        | Free _ => all_tac
  11.370 -      | _ => error "prove_param2: illegal parameter term"
  11.371 +      | _ => error "prove_param2: illegal parameter term")
  11.372    in
  11.373      print_tac options "before simplification in prove_args:"
  11.374      THEN f_tac
  11.375 @@ -379,23 +393,25 @@
  11.376          end
  11.377        | _ => etac @{thm bindE} 1)
  11.378  
  11.379 -fun prove_sidecond2 options ctxt t = let
  11.380 -  fun preds_of t nameTs = case strip_comb t of 
  11.381 -    (Const (name, T), args) =>
  11.382 -      if is_registered ctxt name then (name, T) :: nameTs
  11.383 -        else fold preds_of args nameTs
  11.384 -    | _ => nameTs
  11.385 -  val preds = preds_of t []
  11.386 -  val defs = map
  11.387 -    (fn (pred, T) => predfun_definition_of ctxt pred 
  11.388 -      (all_input_of T))
  11.389 -      preds
  11.390 +fun prove_sidecond2 options ctxt t =
  11.391 +  let
  11.392 +    fun preds_of t nameTs =
  11.393 +      (case strip_comb t of
  11.394 +        (Const (name, T), args) =>
  11.395 +          if is_registered ctxt name then (name, T) :: nameTs
  11.396 +            else fold preds_of args nameTs
  11.397 +      | _ => nameTs)
  11.398 +    val preds = preds_of t []
  11.399 +    val defs = map
  11.400 +      (fn (pred, T) => predfun_definition_of ctxt pred 
  11.401 +        (all_input_of T))
  11.402 +        preds
  11.403    in
  11.404 -   (* only simplify the one assumption *)
  11.405 -   full_simp_tac (put_simpset HOL_basic_ss' ctxt addsimps @{thm eval_pred} :: defs) 1 
  11.406 -   (* need better control here! *)
  11.407 -   THEN print_tac options "after sidecond2 simplification"
  11.408 -   end
  11.409 +    (* only simplify the one assumption *)
  11.410 +    full_simp_tac (put_simpset HOL_basic_ss' ctxt addsimps @{thm eval_pred} :: defs) 1 
  11.411 +    (* need better control here! *)
  11.412 +    THEN print_tac options "after sidecond2 simplification"
  11.413 +  end
  11.414    
  11.415  fun prove_clause2 options ctxt pred mode (ts, ps) i =
  11.416    let
  11.417 @@ -426,46 +442,48 @@
  11.418      | prove_prems2 out_ts ((p, deriv) :: ps) =
  11.419        let
  11.420          val mode = head_mode_of deriv
  11.421 -        val rest_tac = (case p of
  11.422 -          Prem t =>
  11.423 -          let
  11.424 -            val (_, us) = strip_comb t
  11.425 -            val (_, out_ts''') = split_mode mode us
  11.426 -            val rec_tac = prove_prems2 out_ts''' ps
  11.427 -          in
  11.428 -            (prove_expr2 options ctxt (t, deriv)) THEN rec_tac
  11.429 -          end
  11.430 -        | Negprem t =>
  11.431 -          let
  11.432 -            val (_, args) = strip_comb t
  11.433 -            val (_, out_ts''') = split_mode mode args
  11.434 -            val rec_tac = prove_prems2 out_ts''' ps
  11.435 -            val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE)
  11.436 -            val param_derivations = param_derivations_of deriv
  11.437 -            val ho_args = ho_args_of mode args
  11.438 -          in
  11.439 -            print_tac options "before neg prem 2"
  11.440 -            THEN etac @{thm bindE} 1
  11.441 -            THEN (if is_some name then
  11.442 -                full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps
  11.443 -                  [predfun_definition_of ctxt (the name) mode]) 1
  11.444 -                THEN etac @{thm not_predE} 1
  11.445 -                THEN simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm not_False_eq_True}]) 1
  11.446 -                THEN (EVERY (map2 (prove_param2 options ctxt) ho_args param_derivations))
  11.447 -              else
  11.448 -                etac @{thm not_predE'} 1)
  11.449 -            THEN rec_tac
  11.450 -          end 
  11.451 -        | Sidecond t =>
  11.452 -          etac @{thm bindE} 1
  11.453 -          THEN etac @{thm if_predE} 1
  11.454 -          THEN prove_sidecond2 options ctxt t
  11.455 -          THEN prove_prems2 [] ps)
  11.456 -      in print_tac options "before prove_match2:"
  11.457 -         THEN prove_match2 options ctxt out_ts
  11.458 -         THEN print_tac options "after prove_match2:"
  11.459 -         THEN rest_tac
  11.460 -      end;
  11.461 +        val rest_tac =
  11.462 +          (case p of
  11.463 +            Prem t =>
  11.464 +              let
  11.465 +                val (_, us) = strip_comb t
  11.466 +                val (_, out_ts''') = split_mode mode us
  11.467 +                val rec_tac = prove_prems2 out_ts''' ps
  11.468 +              in
  11.469 +                (prove_expr2 options ctxt (t, deriv)) THEN rec_tac
  11.470 +              end
  11.471 +          | Negprem t =>
  11.472 +              let
  11.473 +                val (_, args) = strip_comb t
  11.474 +                val (_, out_ts''') = split_mode mode args
  11.475 +                val rec_tac = prove_prems2 out_ts''' ps
  11.476 +                val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE)
  11.477 +                val param_derivations = param_derivations_of deriv
  11.478 +                val ho_args = ho_args_of mode args
  11.479 +              in
  11.480 +                print_tac options "before neg prem 2"
  11.481 +                THEN etac @{thm bindE} 1
  11.482 +                THEN (if is_some name then
  11.483 +                    full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps
  11.484 +                      [predfun_definition_of ctxt (the name) mode]) 1
  11.485 +                    THEN etac @{thm not_predE} 1
  11.486 +                    THEN simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm not_False_eq_True}]) 1
  11.487 +                    THEN (EVERY (map2 (prove_param2 options ctxt) ho_args param_derivations))
  11.488 +                  else
  11.489 +                    etac @{thm not_predE'} 1)
  11.490 +                THEN rec_tac
  11.491 +              end 
  11.492 +          | Sidecond t =>
  11.493 +              etac @{thm bindE} 1
  11.494 +              THEN etac @{thm if_predE} 1
  11.495 +              THEN prove_sidecond2 options ctxt t
  11.496 +              THEN prove_prems2 [] ps)
  11.497 +      in
  11.498 +        print_tac options "before prove_match2:"
  11.499 +        THEN prove_match2 options ctxt out_ts
  11.500 +        THEN print_tac options "after prove_match2:"
  11.501 +        THEN rest_tac
  11.502 +      end
  11.503      val prems_tac = prove_prems2 in_ts ps 
  11.504    in
  11.505      print_tac options "starting prove_clause2"
  11.506 @@ -489,14 +507,15 @@
  11.507       THEN (
  11.508         if null moded_clauses then etac @{thm botE} 1
  11.509         else EVERY (map2 prove_clause moded_clauses (1 upto (length moded_clauses))))
  11.510 -  end;
  11.511 +  end
  11.512 +
  11.513  
  11.514  (** proof procedure **)
  11.515  
  11.516  fun prove_pred options thy clauses preds pred (_, mode) (moded_clauses, compiled_term) =
  11.517    let
  11.518      val ctxt = Proof_Context.init_global thy   (* FIXME proper context!? *)
  11.519 -    val clauses = case AList.lookup (op =) clauses pred of SOME rs => rs | NONE => []
  11.520 +    val clauses = (case AList.lookup (op =) clauses pred of SOME rs => rs | NONE => [])
  11.521    in
  11.522      Goal.prove ctxt (Term.add_free_names compiled_term []) [] compiled_term
  11.523        (if not (skip_proof options) then
  11.524 @@ -508,6 +527,6 @@
  11.525          THEN prove_other_direction options ctxt pred mode moded_clauses
  11.526          THEN print_tac options "proved other direction")
  11.527        else (fn _ => ALLGOALS Skip_Proof.cheat_tac))
  11.528 -  end;
  11.529 +  end
  11.530  
  11.531 -end;
  11.532 \ No newline at end of file
  11.533 +end
  11.534 \ No newline at end of file
    12.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML	Wed Feb 12 13:31:18 2014 +0100
    12.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML	Wed Feb 12 13:33:05 2014 +0100
    12.3 @@ -9,24 +9,28 @@
    12.4    type seed = Random_Engine.seed
    12.5    (*val quickcheck : Proof.context -> term -> int -> term list option*)
    12.6    val put_pred_result :
    12.7 -    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> term list Predicate.pred) ->
    12.8 -      Proof.context -> Proof.context;
    12.9 +    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> Code_Numeral.natural -> seed ->
   12.10 +      term list Predicate.pred) ->
   12.11 +    Proof.context -> Proof.context
   12.12    val put_dseq_result :
   12.13 -    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> term list Limited_Sequence.dseq * seed) ->
   12.14 -      Proof.context -> Proof.context;
   12.15 +    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed ->
   12.16 +      term list Limited_Sequence.dseq * seed) ->
   12.17 +    Proof.context -> Proof.context
   12.18    val put_lseq_result :
   12.19 -    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural -> term list Lazy_Sequence.lazy_sequence) ->
   12.20 -      Proof.context -> Proof.context;
   12.21 -  val put_new_dseq_result : (unit -> Code_Numeral.natural -> term list Lazy_Sequence.lazy_sequence) ->
   12.22 +    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural ->
   12.23 +      term list Lazy_Sequence.lazy_sequence) ->
   12.24 +    Proof.context -> Proof.context
   12.25 +  val put_new_dseq_result :
   12.26 +    (unit -> Code_Numeral.natural -> term list Lazy_Sequence.lazy_sequence) ->
   12.27      Proof.context -> Proof.context
   12.28    val put_cps_result : (unit -> Code_Numeral.natural -> (bool * term list) option) ->
   12.29      Proof.context -> Proof.context
   12.30    val test_goals : (Predicate_Compile_Aux.compilation * bool) ->
   12.31 -    Proof.context -> bool * bool -> (string * typ) list -> (term * term list) list
   12.32 -      -> Quickcheck.result list
   12.33 -  val nrandom : int Unsynchronized.ref;
   12.34 -  val debug : bool Unsynchronized.ref;
   12.35 -  val no_higher_order_predicate : string list Unsynchronized.ref;
   12.36 +    Proof.context -> bool * bool -> (string * typ) list -> (term * term list) list ->
   12.37 +    Quickcheck.result list
   12.38 +  val nrandom : int Unsynchronized.ref
   12.39 +  val debug : bool Unsynchronized.ref
   12.40 +  val no_higher_order_predicate : string list Unsynchronized.ref
   12.41    val setup : theory -> theory
   12.42  end;
   12.43  
   12.44 @@ -44,48 +48,48 @@
   12.45    type T = unit -> Code_Numeral.natural -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> term list Predicate.pred
   12.46    (* FIXME avoid user error with non-user text *)
   12.47    fun init _ () = error "Pred_Result"
   12.48 -);
   12.49 -val put_pred_result = Pred_Result.put;
   12.50 +)
   12.51 +val put_pred_result = Pred_Result.put
   12.52  
   12.53  structure Dseq_Result = Proof_Data
   12.54  (
   12.55    type T = unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> term list Limited_Sequence.dseq * seed
   12.56    (* FIXME avoid user error with non-user text *)
   12.57    fun init _ () = error "Dseq_Result"
   12.58 -);
   12.59 -val put_dseq_result = Dseq_Result.put;
   12.60 +)
   12.61 +val put_dseq_result = Dseq_Result.put
   12.62  
   12.63  structure Lseq_Result = Proof_Data
   12.64  (
   12.65    type T = unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural -> term list Lazy_Sequence.lazy_sequence
   12.66    (* FIXME avoid user error with non-user text *)
   12.67    fun init _ () = error "Lseq_Result"
   12.68 -);
   12.69 -val put_lseq_result = Lseq_Result.put;
   12.70 +)
   12.71 +val put_lseq_result = Lseq_Result.put
   12.72  
   12.73  structure New_Dseq_Result = Proof_Data
   12.74  (
   12.75    type T = unit -> Code_Numeral.natural -> term list Lazy_Sequence.lazy_sequence
   12.76    (* FIXME avoid user error with non-user text *)
   12.77    fun init _ () = error "New_Dseq_Random_Result"
   12.78 -);
   12.79 -val put_new_dseq_result = New_Dseq_Result.put;
   12.80 +)
   12.81 +val put_new_dseq_result = New_Dseq_Result.put
   12.82  
   12.83  structure CPS_Result = Proof_Data
   12.84  (
   12.85    type T = unit -> Code_Numeral.natural -> (bool * term list) option
   12.86    (* FIXME avoid user error with non-user text *)
   12.87    fun init _ () = error "CPS_Result"
   12.88 -);
   12.89 -val put_cps_result = CPS_Result.put;
   12.90 +)
   12.91 +val put_cps_result = CPS_Result.put
   12.92  
   12.93  val target = "Quickcheck"
   12.94  
   12.95 -val nrandom = Unsynchronized.ref 3;
   12.96 +val nrandom = Unsynchronized.ref 3
   12.97  
   12.98 -val debug = Unsynchronized.ref false;
   12.99 +val debug = Unsynchronized.ref false
  12.100  
  12.101 -val no_higher_order_predicate = Unsynchronized.ref ([] : string list);
  12.102 +val no_higher_order_predicate = Unsynchronized.ref ([] : string list)
  12.103  
  12.104  val options = Options {
  12.105    expected_modes = NONE,
  12.106 @@ -98,7 +102,7 @@
  12.107    show_mode_inference = false,
  12.108    show_compilation = false,
  12.109    show_caught_failures = false,
  12.110 -  show_invalid_clauses = false, 
  12.111 +  show_invalid_clauses = false,
  12.112    skip_proof = false,
  12.113    compilation = Random,
  12.114    inductify = true,
  12.115 @@ -141,7 +145,7 @@
  12.116      show_intermediate_results = s_ir, show_proof_trace = s_pt, show_modes = s_m,
  12.117      show_mode_inference = s_mi, show_compilation = s_c, show_caught_failures = s_cf,
  12.118      show_invalid_clauses = s_ic, skip_proof = s_p,
  12.119 -    compilation = c, inductify = i, specialise = sp, detect_switches = ds, function_flattening = _, 
  12.120 +    compilation = c, inductify = i, specialise = sp, detect_switches = ds, function_flattening = _,
  12.121      fail_safe_function_flattening = fs_ff, no_higher_order_predicate = no_ho,
  12.122      smart_depth_limiting = sm_dl, no_topmost_reordering = re}) =
  12.123    (Options { expected_modes = e_m, proposed_modes = p_m, proposed_names = p_n, show_steps = s_s,
  12.124 @@ -157,7 +161,7 @@
  12.125      show_intermediate_results = s_ir, show_proof_trace = s_pt, show_modes = s_m,
  12.126      show_mode_inference = s_mi, show_compilation = s_c, show_caught_failures = s_cf,
  12.127      show_invalid_clauses = s_ic, skip_proof = s_p,
  12.128 -    compilation = c, inductify = i, specialise = sp, detect_switches = ds, function_flattening = f_f, 
  12.129 +    compilation = c, inductify = i, specialise = sp, detect_switches = ds, function_flattening = f_f,
  12.130      fail_safe_function_flattening = _, no_higher_order_predicate = no_ho,
  12.131      smart_depth_limiting = sm_dl, no_topmost_reordering = re}) =
  12.132    (Options { expected_modes = e_m, proposed_modes = p_m, proposed_names = p_n, show_steps = s_s,
  12.133 @@ -173,7 +177,7 @@
  12.134      show_intermediate_results = s_ir, show_proof_trace = s_pt, show_modes = s_m,
  12.135      show_mode_inference = s_mi, show_compilation = s_c, show_caught_failures = s_cf,
  12.136      show_invalid_clauses = s_ic, skip_proof = s_p,
  12.137 -    compilation = c, inductify = i, specialise = sp, detect_switches = ds, function_flattening = f_f, 
  12.138 +    compilation = c, inductify = i, specialise = sp, detect_switches = ds, function_flattening = f_f,
  12.139      fail_safe_function_flattening = fs_ff, no_higher_order_predicate = _,
  12.140      smart_depth_limiting = sm_dl, no_topmost_reordering = re}) =
  12.141    (Options { expected_modes = e_m, proposed_modes = p_m, proposed_names = p_n, show_steps = s_s,
  12.142 @@ -185,7 +189,7 @@
  12.143      smart_depth_limiting = sm_dl, no_topmost_reordering = re})
  12.144  
  12.145  
  12.146 -fun get_options () = 
  12.147 +fun get_options () =
  12.148    set_no_higher_order_predicate (!no_higher_order_predicate)
  12.149      (if !debug then debug_options else options)
  12.150  
  12.151 @@ -210,7 +214,7 @@
  12.152    Predicate_Compile_Aux.mk_single New_Pos_DSequence_CompFuns.depth_unlimited_compfuns
  12.153  val mk_gen_bind =
  12.154    Predicate_Compile_Aux.mk_bind New_Pos_DSequence_CompFuns.depth_unlimited_compfuns
  12.155 -  
  12.156 +
  12.157  
  12.158  val mk_cpsT =
  12.159    Predicate_Compile_Aux.mk_monadT Pos_Bounded_CPS_Comp_Funs.compfuns
  12.160 @@ -251,41 +255,41 @@
  12.161        if member eq_mode modes output_mode then
  12.162          let
  12.163            val name = Core_Data.function_name_of compilation ctxt4 full_constname output_mode
  12.164 -          val T = 
  12.165 -            case compilation of
  12.166 +          val T =
  12.167 +            (case compilation of
  12.168                Pos_Random_DSeq => mk_randompredT (HOLogic.mk_tupleT (map snd vs'))
  12.169              | New_Pos_Random_DSeq => mk_new_randompredT (HOLogic.mk_tupleT (map snd vs'))
  12.170              | Pos_Generator_DSeq => mk_new_dseqT (HOLogic.mk_tupleT (map snd vs'))
  12.171              | Depth_Limited_Random =>
  12.172 -              [@{typ natural}, @{typ natural}, @{typ natural},
  12.173 -              @{typ Random.seed}] ---> mk_predT (HOLogic.mk_tupleT (map snd vs'))
  12.174 -            | Pos_Generator_CPS => mk_cpsT (HOLogic.mk_tupleT (map snd vs'))
  12.175 +                [@{typ natural}, @{typ natural}, @{typ natural},
  12.176 +                 @{typ Random.seed}] ---> mk_predT (HOLogic.mk_tupleT (map snd vs'))
  12.177 +            | Pos_Generator_CPS => mk_cpsT (HOLogic.mk_tupleT (map snd vs')))
  12.178          in
  12.179            Const (name, T)
  12.180          end
  12.181        else error ("Predicate Compile Quickcheck failed: " ^ commas (map string_of_mode modes))
  12.182      fun mk_Some T = Const (@{const_name "Option.Some"}, T --> Type (@{type_name "Option.option"}, [T]))
  12.183      val qc_term =
  12.184 -      case compilation of
  12.185 -          Pos_Random_DSeq => mk_bind (prog,
  12.186 -            mk_split_lambda (map Free vs') (mk_return (HOLogic.mk_list @{typ term}
  12.187 -            (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
  12.188 -        | New_Pos_Random_DSeq => mk_new_bind (prog,
  12.189 -            mk_split_lambda (map Free vs') (mk_new_return (HOLogic.mk_list @{typ term}
  12.190 -            (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
  12.191 -        | Pos_Generator_DSeq => mk_gen_bind (prog,
  12.192 -            mk_split_lambda (map Free vs') (mk_gen_return (HOLogic.mk_list @{typ term}
  12.193 -            (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
  12.194 -        | Pos_Generator_CPS => prog $
  12.195 -            mk_split_lambda (map Free vs') (mk_Some @{typ "bool * term list"} $
  12.196 -            HOLogic.mk_prod (@{term "True"}, HOLogic.mk_list @{typ term}
  12.197 -                (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))     
  12.198 -        | Depth_Limited_Random => fold_rev absdummy
  12.199 -            [@{typ natural}, @{typ natural}, @{typ natural},
  12.200 -             @{typ Random.seed}]
  12.201 -            (mk_bind' (list_comb (prog, map Bound (3 downto 0)),
  12.202 -            mk_split_lambda (map Free vs') (mk_return' (HOLogic.mk_list @{typ term}
  12.203 -            (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))))
  12.204 +      (case compilation of
  12.205 +        Pos_Random_DSeq => mk_bind (prog,
  12.206 +          mk_split_lambda (map Free vs') (mk_return (HOLogic.mk_list @{typ term}
  12.207 +          (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
  12.208 +      | New_Pos_Random_DSeq => mk_new_bind (prog,
  12.209 +          mk_split_lambda (map Free vs') (mk_new_return (HOLogic.mk_list @{typ term}
  12.210 +          (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
  12.211 +      | Pos_Generator_DSeq => mk_gen_bind (prog,
  12.212 +          mk_split_lambda (map Free vs') (mk_gen_return (HOLogic.mk_list @{typ term}
  12.213 +          (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
  12.214 +      | Pos_Generator_CPS => prog $
  12.215 +          mk_split_lambda (map Free vs') (mk_Some @{typ "bool * term list"} $
  12.216 +          HOLogic.mk_prod (@{term "True"}, HOLogic.mk_list @{typ term}
  12.217 +              (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))
  12.218 +      | Depth_Limited_Random => fold_rev absdummy
  12.219 +          [@{typ natural}, @{typ natural}, @{typ natural},
  12.220 +           @{typ Random.seed}]
  12.221 +          (mk_bind' (list_comb (prog, map Bound (3 downto 0)),
  12.222 +          mk_split_lambda (map Free vs') (mk_return' (HOLogic.mk_list @{typ term}
  12.223 +          (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))))
  12.224      val prog =
  12.225        case compilation of
  12.226          Pos_Random_DSeq =>
  12.227 @@ -310,7 +314,7 @@
  12.228                    g nrandom size s depth |> (Lazy_Sequence.map o map) proc)
  12.229                    qc_term []
  12.230            in
  12.231 -            fn size => fn nrandom => fn depth => Option.map fst (Lazy_Sequence.yield 
  12.232 +            fn size => fn nrandom => fn depth => Option.map fst (Lazy_Sequence.yield
  12.233                 (
  12.234                 let
  12.235                   val seed = Random_Engine.next_seed ()
  12.236 @@ -346,7 +350,7 @@
  12.237                    g depth nrandom size seed |> (Predicate.map o map) proc)
  12.238                  qc_term []
  12.239            in
  12.240 -            fn size => fn nrandom => fn depth => Option.map fst (Predicate.yield 
  12.241 +            fn size => fn nrandom => fn depth => Option.map fst (Predicate.yield
  12.242                (compiled_term depth nrandom size (Random_Engine.run (fn s => (s, s)))))
  12.243            end
  12.244    in
  12.245 @@ -368,14 +372,14 @@
  12.246           val _ = if Config.get ctxt Quickcheck.timing then
  12.247             message (fst time ^ ": " ^ string_of_int (snd time) ^ " ms") else ()
  12.248          in
  12.249 -          case result of NONE => try' (i + 1) | SOME q => SOME q
  12.250 +          (case result of NONE => try' (i + 1) | SOME q => SOME q)
  12.251          end
  12.252 -      else
  12.253 -        NONE
  12.254 +      else NONE
  12.255    in
  12.256      try' 0
  12.257    end
  12.258  
  12.259 +
  12.260  (* quickcheck interface functions *)
  12.261  
  12.262  fun compile_term' compilation options ctxt (t, _) =
  12.263 @@ -386,7 +390,8 @@
  12.264        (Code_Numeral.natural_of_integer (!nrandom)) o Code_Numeral.natural_of_integer)
  12.265    in
  12.266      Quickcheck.Result
  12.267 -      {counterexample = Option.map (pair true o (curry (op ~~)) (Term.add_free_names t [])) counterexample,
  12.268 +      {counterexample =
  12.269 +        Option.map (pair true o (curry (op ~~)) (Term.add_free_names t [])) counterexample,
  12.270         evaluation_terms = Option.map (K []) counterexample, timings = [], reports = []}
  12.271    end
  12.272  
  12.273 @@ -412,14 +417,16 @@
  12.274        (maps (map snd) correct_inst_goals) []
  12.275    end
  12.276  
  12.277 -val smart_exhaustive_active = Attrib.setup_config_bool @{binding quickcheck_smart_exhaustive_active} (K true);
  12.278 -val smart_slow_exhaustive_active = Attrib.setup_config_bool @{binding quickcheck_slow_smart_exhaustive_active} (K false);
  12.279 +val smart_exhaustive_active =
  12.280 +  Attrib.setup_config_bool @{binding quickcheck_smart_exhaustive_active} (K true)
  12.281 +val smart_slow_exhaustive_active =
  12.282 +  Attrib.setup_config_bool @{binding quickcheck_slow_smart_exhaustive_active} (K false)
  12.283  
  12.284  val setup =
  12.285 -  Exhaustive_Generators.setup_exhaustive_datatype_interpretation 
  12.286 +  Exhaustive_Generators.setup_exhaustive_datatype_interpretation
  12.287    #> Context.theory_map (Quickcheck.add_tester ("smart_exhaustive",
  12.288      (smart_exhaustive_active, test_goals (Predicate_Compile_Aux.Pos_Generator_CPS, false))))
  12.289    #> Context.theory_map (Quickcheck.add_tester ("smart_slow_exhaustive",
  12.290      (smart_slow_exhaustive_active, test_goals (Predicate_Compile_Aux.Pos_Generator_DSeq, false))))
  12.291  
  12.292 -end;
  12.293 +end
    13.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_specialisation.ML	Wed Feb 12 13:31:18 2014 +0100
    13.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_specialisation.ML	Wed Feb 12 13:33:05 2014 +0100
    13.3 @@ -6,7 +6,8 @@
    13.4  
    13.5  signature PREDICATE_COMPILE_SPECIALISATION =
    13.6  sig
    13.7 -  val find_specialisations : string list -> (string * thm list) list -> theory -> (string * thm list) list * theory
    13.8 +  val find_specialisations : string list -> (string * thm list) list ->
    13.9 +    theory -> (string * thm list) list * theory
   13.10  end;
   13.11  
   13.12  structure Predicate_Compile_Specialisation : PREDICATE_COMPILE_SPECIALISATION =
   13.13 @@ -17,10 +18,10 @@
   13.14  (* table of specialisations *)
   13.15  structure Specialisations = Theory_Data
   13.16  (
   13.17 -  type T = (term * term) Item_Net.T;
   13.18 -  val empty : T = Item_Net.init (op aconv o pairself fst) (single o fst);
   13.19 -  val extend = I;
   13.20 -  val merge = Item_Net.merge;
   13.21 +  type T = (term * term) Item_Net.T
   13.22 +  val empty : T = Item_Net.init (op aconv o pairself fst) (single o fst)
   13.23 +  val extend = I
   13.24 +  val merge = Item_Net.merge
   13.25  )
   13.26  
   13.27  fun specialisation_of thy atom =
   13.28 @@ -29,7 +30,8 @@
   13.29  fun import (_, intros) args ctxt =
   13.30    let
   13.31      val ((_, intros'), ctxt') = Variable.importT intros ctxt
   13.32 -    val pred' = fst (strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl (prop_of (hd intros')))))
   13.33 +    val pred' =
   13.34 +      fst (strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl (prop_of (hd intros')))))
   13.35      val Ts = binder_types (fastype_of pred')
   13.36      val argTs = map fastype_of args
   13.37      val Tsubst = Type.raw_matches (argTs, Ts) Vartab.empty
   13.38 @@ -44,17 +46,19 @@
   13.39      val cnstrs = flat (maps
   13.40        (map (fn (_, (Tname, _, cs)) => map (apsnd (rpair Tname o length)) cs) o #descr o snd)
   13.41        (Symtab.dest (Datatype.get_all thy)));
   13.42 -    fun check t = (case strip_comb t of
   13.43 +    fun check t =
   13.44 +      (case strip_comb t of
   13.45          (Var _, []) => (true, true)
   13.46        | (Free _, []) => (true, true)
   13.47        | (Const (@{const_name Pair}, _), ts) =>
   13.48          pairself (forall I) (split_list (map check ts))
   13.49 -      | (Const (s, T), ts) => (case (AList.lookup (op =) cnstrs s, body_type T) of
   13.50 +      | (Const (s, T), ts) =>
   13.51 +          (case (AList.lookup (op =) cnstrs s, body_type T) of
   13.52              (SOME (i, Tname), Type (Tname', _)) => (false,
   13.53                length ts = i andalso Tname = Tname' andalso forall (snd o check) ts)
   13.54            | _ => (false, false))
   13.55        | _ => (false, false))
   13.56 -  in check t = (false, true) end;
   13.57 +  in check t = (false, true) end
   13.58  
   13.59  fun specialise_intros black_list (pred, intros) pats thy =
   13.60    let
   13.61 @@ -91,7 +95,8 @@
   13.62          SOME intro
   13.63        end handle Pattern.Unif => NONE)
   13.64      val specialised_intros_t = map_filter I (map specialise_intro intros)
   13.65 -    val thy' = Sign.add_consts_i [(Binding.name (Long_Name.base_name constname), constT, NoSyn)] thy
   13.66 +    val thy' =
   13.67 +      Sign.add_consts_i [(Binding.name (Long_Name.base_name constname), constT, NoSyn)] thy
   13.68      val specialised_intros = map (Skip_Proof.make_thm thy') specialised_intros_t
   13.69      val exported_intros = Variable.exportT ctxt' ctxt specialised_intros
   13.70      val [t, specialised_t] = Variable.exportT_terms ctxt' ctxt
   13.71 @@ -124,29 +129,31 @@
   13.72        end
   13.73      and restrict_pattern' thy [] free_names = ([], free_names)
   13.74        | restrict_pattern' thy ((T, Free (x, _)) :: Tts) free_names =
   13.75 -      let
   13.76 -        val (ts', free_names') = restrict_pattern' thy Tts free_names
   13.77 -      in
   13.78 -        (Free (x, T) :: ts', free_names')
   13.79 -      end
   13.80 +          let
   13.81 +            val (ts', free_names') = restrict_pattern' thy Tts free_names
   13.82 +          in
   13.83 +            (Free (x, T) :: ts', free_names')
   13.84 +          end
   13.85        | restrict_pattern' thy ((T as TFree _, t) :: Tts) free_names =
   13.86 -        replace_term_and_restrict thy T t Tts free_names
   13.87 +          replace_term_and_restrict thy T t Tts free_names
   13.88        | restrict_pattern' thy ((T as Type (Tcon, _), t) :: Tts) free_names =
   13.89 -        case Datatype.get_constrs thy Tcon of
   13.90 -          NONE => replace_term_and_restrict thy T t Tts free_names
   13.91 -        | SOME constrs => (case strip_comb t of
   13.92 -          (Const (s, _), ats) => (case AList.lookup (op =) constrs s of
   13.93 -            SOME constr_T =>
   13.94 -              let
   13.95 -                val (Ts', T') = strip_type constr_T
   13.96 -                val Tsubst = Type.raw_match (T', T) Vartab.empty
   13.97 -                val Ts = map (Envir.subst_type Tsubst) Ts'
   13.98 -                val (bts', free_names') = restrict_pattern' thy ((Ts ~~ ats) @ Tts) free_names
   13.99 -                val (ats', ts') = chop (length ats) bts'
  13.100 -              in
  13.101 -                (list_comb (Const (s, map fastype_of ats' ---> T), ats') :: ts', free_names')
  13.102 -              end
  13.103 -            | NONE => replace_term_and_restrict thy T t Tts free_names))
  13.104 +          (case Datatype.get_constrs thy Tcon of
  13.105 +            NONE => replace_term_and_restrict thy T t Tts free_names
  13.106 +          | SOME constrs =>
  13.107 +              (case strip_comb t of
  13.108 +                (Const (s, _), ats) =>
  13.109 +                  (case AList.lookup (op =) constrs s of
  13.110 +                    SOME constr_T =>
  13.111 +                      let
  13.112 +                        val (Ts', T') = strip_type constr_T
  13.113 +                        val Tsubst = Type.raw_match (T', T) Vartab.empty
  13.114 +                        val Ts = map (Envir.subst_type Tsubst) Ts'
  13.115 +                        val (bts', free_names') = restrict_pattern' thy ((Ts ~~ ats) @ Tts) free_names
  13.116 +                        val (ats', ts') = chop (length ats) bts'
  13.117 +                      in
  13.118 +                        (list_comb (Const (s, map fastype_of ats' ---> T), ats') :: ts', free_names')
  13.119 +                      end
  13.120 +                    | NONE => replace_term_and_restrict thy T t Tts free_names)))
  13.121      fun restrict_pattern thy Ts args =
  13.122        let
  13.123          val args = map Logic.unvarify_global args
  13.124 @@ -155,42 +162,42 @@
  13.125          val (pat, _) = restrict_pattern' thy (Ts ~~ args) free_names
  13.126        in map Logic.varify_global pat end
  13.127      fun detect' atom thy =
  13.128 -      case strip_comb atom of
  13.129 +      (case strip_comb atom of
  13.130          (pred as Const (pred_name, _), args) =>
  13.131            let
  13.132 -          val Ts = binder_types (Sign.the_const_type thy pred_name)
  13.133 -          val pats = restrict_pattern thy Ts args
  13.134 -        in
  13.135 -          if (exists (is_nontrivial_constrt thy) pats)
  13.136 -            orelse (has_duplicates (op =) (fold add_vars pats [])) then
  13.137 -            let
  13.138 -              val thy' =
  13.139 -                case specialisation_of thy atom of
  13.140 -                  [] =>
  13.141 -                    if member (op =) ((map fst specs) @ black_list) pred_name then
  13.142 -                      thy
  13.143 -                    else
  13.144 -                      (case try (Core_Data.intros_of (Proof_Context.init_global thy)) pred_name of
  13.145 -                        NONE => thy
  13.146 -                      | SOME [] => thy
  13.147 -                      | SOME intros =>
  13.148 -                          specialise_intros ((map fst specs) @ (pred_name :: black_list))
  13.149 -                            (pred, intros) pats thy)
  13.150 -                  | _ :: _ => thy
  13.151 +            val Ts = binder_types (Sign.the_const_type thy pred_name)
  13.152 +            val pats = restrict_pattern thy Ts args
  13.153 +          in
  13.154 +            if (exists (is_nontrivial_constrt thy) pats)
  13.155 +              orelse (has_duplicates (op =) (fold add_vars pats [])) then
  13.156 +              let
  13.157 +                val thy' =
  13.158 +                  (case specialisation_of thy atom of
  13.159 +                    [] =>
  13.160 +                      if member (op =) ((map fst specs) @ black_list) pred_name then
  13.161 +                        thy
  13.162 +                      else
  13.163 +                        (case try (Core_Data.intros_of (Proof_Context.init_global thy)) pred_name of
  13.164 +                          NONE => thy
  13.165 +                        | SOME [] => thy
  13.166 +                        | SOME intros =>
  13.167 +                            specialise_intros ((map fst specs) @ (pred_name :: black_list))
  13.168 +                              (pred, intros) pats thy)
  13.169 +                  | _ :: _ => thy)
  13.170                  val atom' =
  13.171 -                  case specialisation_of thy' atom of
  13.172 +                  (case specialisation_of thy' atom of
  13.173                      [] => atom
  13.174                    | (t, specialised_t) :: _ =>
  13.175                      let
  13.176                        val subst = Pattern.match thy' (t, atom) (Vartab.empty, Vartab.empty)
  13.177 -                    in Envir.subst_term subst specialised_t end handle Pattern.MATCH => atom
  13.178 -                    (*FIXME: this exception could be caught earlier in specialisation_of *)
  13.179 -            in
  13.180 -              (atom', thy')
  13.181 -            end
  13.182 -          else (atom, thy)
  13.183 -        end
  13.184 -      | _ => (atom, thy)
  13.185 +                    in Envir.subst_term subst specialised_t end handle Pattern.MATCH => atom)
  13.186 +                    (*FIXME: this exception could be handled earlier in specialisation_of *)
  13.187 +              in
  13.188 +                (atom', thy')
  13.189 +              end
  13.190 +            else (atom, thy)
  13.191 +          end
  13.192 +      | _ => (atom, thy))
  13.193      fun specialise' (constname, intros) thy =
  13.194        let
  13.195          (* FIXME: only necessary because of sloppy Logic.unvarify in restrict_pattern *)