merged, resolving some conflicts;
authorwenzelm
Wed Feb 12 14:32:45 2014 +0100 (2014-02-12)
changeset 55440721b4561007a
parent 55428 0ab52bf7b5e6
parent 55439 db691cc79289
child 55441 b445c39cc7e9
merged, resolving some conflicts;
src/HOL/Divides.thy
src/HOL/Tools/Predicate_Compile/code_prolog.ML
src/HOL/Tools/Predicate_Compile/mode_inference.ML
src/HOL/Tools/Predicate_Compile/predicate_compile_aux.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_proof.ML
src/HOL/Tools/Predicate_Compile/predicate_compile_specialisation.ML
     1.1 --- a/Admin/PLATFORMS	Wed Feb 12 10:59:25 2014 +0100
     1.2 +++ b/Admin/PLATFORMS	Wed Feb 12 14:32:45 2014 +0100
     1.3 @@ -122,3 +122,6 @@
     1.4    identifies the JVM platform.  Since a particular Java version is
     1.5    always bundled with Isabelle, the resulting settings also provide
     1.6    some clues about its platform, without running it.
     1.7 +
     1.8 +* Common Unix tools like /bin/sh, /bin/kill, sed, ulimit are
     1.9 +  notoriously non-portable an should be avoided.
    1.10 \ No newline at end of file
     2.1 --- a/src/HOL/Divides.thy	Wed Feb 12 10:59:25 2014 +0100
     2.2 +++ b/src/HOL/Divides.thy	Wed Feb 12 14:32:45 2014 +0100
     2.3 @@ -1968,13 +1968,13 @@
     2.4  lemma [simp]:
     2.5    shows div_one_bit0: "1 div numeral (Num.Bit0 v) = (0 :: int)"
     2.6      and mod_one_bit0: "1 mod numeral (Num.Bit0 v) = (1 :: int)"
     2.7 -	  and div_one_bit1: "1 div numeral (Num.Bit1 v) = (0 :: int)"
     2.8 -	  and mod_one_bit1: "1 mod numeral (Num.Bit1 v) = (1 :: int)"
     2.9 -	  and div_one_neg_numeral: "1 div - numeral v = (- 1 :: int)"
    2.10 -	  and mod_one_neg_numeral: "1 mod - numeral v = (1 :: int) - numeral v"
    2.11 +    and div_one_bit1: "1 div numeral (Num.Bit1 v) = (0 :: int)"
    2.12 +    and mod_one_bit1: "1 mod numeral (Num.Bit1 v) = (1 :: int)"
    2.13 +    and div_one_neg_numeral: "1 div - numeral v = (- 1 :: int)"
    2.14 +    and mod_one_neg_numeral: "1 mod - numeral v = (1 :: int) - numeral v"
    2.15    by (simp_all del: arith_special
    2.16      add: div_pos_pos mod_pos_pos div_pos_neg mod_pos_neg posDivAlg_eqn)
    2.17 -	
    2.18 +
    2.19  lemma [simp]:
    2.20    shows div_neg_one_numeral: "- 1 div numeral v = (- 1 :: int)"
    2.21      and mod_neg_one_numeral: "- 1 mod numeral v = numeral v - (1 :: int)"
     3.1 --- a/src/HOL/Tools/Predicate_Compile/code_prolog.ML	Wed Feb 12 10:59:25 2014 +0100
     3.2 +++ b/src/HOL/Tools/Predicate_Compile/code_prolog.ML	Wed Feb 12 14:32:45 2014 +0100
     3.3 @@ -18,9 +18,9 @@
     3.4    val set_ensure_groundness : code_options -> code_options
     3.5    val map_limit_predicates : ((string list * int) list -> (string list * int) list)
     3.6      -> code_options -> code_options
     3.7 -  val code_options_of : theory -> code_options 
     3.8 +  val code_options_of : theory -> code_options
     3.9    val map_code_options : (code_options -> code_options) -> theory -> theory
    3.10 -  
    3.11 +
    3.12    datatype arith_op = Plus | Minus
    3.13    datatype prol_term = Var of string | Cons of string | AppF of string * prol_term list
    3.14      | Number of int | ArithOp of arith_op * prol_term list;
    3.15 @@ -33,20 +33,20 @@
    3.16    type clause = ((string * prol_term list) * prem);
    3.17    type logic_program = clause list;
    3.18    type constant_table = (string * string) list
    3.19 -  
    3.20 +
    3.21    val generate : Predicate_Compile_Aux.mode option * bool ->
    3.22      Proof.context -> string -> (logic_program * constant_table)
    3.23    val write_program : logic_program -> string
    3.24    val run : (Time.time * prolog_system) -> logic_program -> (string * prol_term list) ->
    3.25      string list -> int option -> prol_term list list
    3.26 -  
    3.27 +
    3.28    val active : bool Config.T
    3.29    val test_goals :
    3.30      Proof.context -> bool -> (string * typ) list -> (term * term list) list ->
    3.31        Quickcheck.result list
    3.32  
    3.33    val trace : bool Unsynchronized.ref
    3.34 -  
    3.35 +
    3.36    val replace : ((string * string) * string) -> logic_program -> logic_program
    3.37  end;
    3.38  
    3.39 @@ -57,11 +57,11 @@
    3.40  
    3.41  val trace = Unsynchronized.ref false
    3.42  
    3.43 -fun tracing s = if !trace then Output.tracing s else () 
    3.44 +fun tracing s = if !trace then Output.tracing s else ()
    3.45 +
    3.46  
    3.47  (* code generation options *)
    3.48  
    3.49 -
    3.50  type code_options =
    3.51    {ensure_groundness : bool,
    3.52     limit_globally : int option,
    3.53 @@ -79,15 +79,15 @@
    3.54  
    3.55  fun map_limit_predicates f {ensure_groundness, limit_globally, limited_types, limited_predicates,
    3.56    replacing, manual_reorder} =
    3.57 -  {ensure_groundness = ensure_groundness, limit_globally = limit_globally, limited_types = limited_types,
    3.58 -   limited_predicates = f limited_predicates, replacing = replacing,
    3.59 -   manual_reorder = manual_reorder}
    3.60 +  {ensure_groundness = ensure_groundness, limit_globally = limit_globally,
    3.61 +   limited_types = limited_types, limited_predicates = f limited_predicates,
    3.62 +   replacing = replacing, manual_reorder = manual_reorder}
    3.63  
    3.64  fun merge_global_limit (NONE, NONE) = NONE
    3.65    | merge_global_limit (NONE, SOME n) = SOME n
    3.66    | merge_global_limit (SOME n, NONE) = SOME n
    3.67    | merge_global_limit (SOME n, SOME m) = SOME (Int.max (n, m))  (* FIXME odd merge *)
    3.68 -   
    3.69 +
    3.70  structure Options = Theory_Data
    3.71  (
    3.72    type T = code_options
    3.73 @@ -113,6 +113,7 @@
    3.74  
    3.75  val map_code_options = Options.map
    3.76  
    3.77 +
    3.78  (* system configuration *)
    3.79  
    3.80  datatype prolog_system = SWI_PROLOG | YAP
    3.81 @@ -121,7 +122,7 @@
    3.82    | string_of_system YAP = "yap"
    3.83  
    3.84  type system_configuration = {timeout : Time.time, prolog_system : prolog_system}
    3.85 -                                                
    3.86 +
    3.87  structure System_Config = Generic_Data
    3.88  (
    3.89    type T = system_configuration
    3.90 @@ -130,11 +131,13 @@
    3.91    fun merge (a, _) = a
    3.92  )
    3.93  
    3.94 +
    3.95  (* general string functions *)
    3.96  
    3.97  val first_upper = implode o nth_map 0 Symbol.to_ascii_upper o raw_explode;
    3.98  val first_lower = implode o nth_map 0 Symbol.to_ascii_lower o raw_explode;
    3.99  
   3.100 +
   3.101  (* internal program representation *)
   3.102  
   3.103  datatype arith_op = Plus | Minus
   3.104 @@ -153,7 +156,7 @@
   3.105    | map_vars f (ArithOp (opr, ts)) = ArithOp (opr, map (map_vars f) ts)
   3.106    | map_vars f (AppF (fs, ts)) = AppF (fs, map (map_vars f) ts)
   3.107    | map_vars f t = t
   3.108 -  
   3.109 +
   3.110  fun maybe_AppF (c, []) = Cons c
   3.111    | maybe_AppF (c, xs) = AppF (c, xs)
   3.112  
   3.113 @@ -167,7 +170,7 @@
   3.114  
   3.115  fun string_of_prol_term (Var s) = "Var " ^ s
   3.116    | string_of_prol_term (Cons s) = "Cons " ^ s
   3.117 -  | string_of_prol_term (AppF (f, args)) = f ^ "(" ^ commas (map string_of_prol_term args) ^ ")" 
   3.118 +  | string_of_prol_term (AppF (f, args)) = f ^ "(" ^ commas (map string_of_prol_term args) ^ ")"
   3.119    | string_of_prol_term (Number n) = "Number " ^ string_of_int n
   3.120  
   3.121  datatype prem = Conj of prem list
   3.122 @@ -195,11 +198,12 @@
   3.123    | fold_prem_terms f (ArithEq (l, r)) = f l #> f r
   3.124    | fold_prem_terms f (NotArithEq (l, r)) = f l #> f r
   3.125    | fold_prem_terms f (Ground (v, T)) = f (Var v)
   3.126 -  
   3.127 +
   3.128  type clause = ((string * prol_term list) * prem);
   3.129  
   3.130  type logic_program = clause list;
   3.131 - 
   3.132 +
   3.133 +
   3.134  (* translation from introduction rules to internal representation *)
   3.135  
   3.136  fun mk_conform f empty avoid name =
   3.137 @@ -211,6 +215,7 @@
   3.138      val name'' = f (if name' = "" then empty else name')
   3.139    in if member (op =) avoid name'' then singleton (Name.variant_list avoid) name'' else name'' end
   3.140  
   3.141 +
   3.142  (** constant table **)
   3.143  
   3.144  type constant_table = (string * string) list
   3.145 @@ -227,11 +232,11 @@
   3.146    in
   3.147      fold update' consts constant_table
   3.148    end
   3.149 -  
   3.150 +
   3.151  fun translate_const constant_table c =
   3.152 -  case AList.lookup (op =) constant_table c of
   3.153 +  (case AList.lookup (op =) constant_table c of
   3.154      SOME c' => c'
   3.155 -  | NONE => error ("No such constant: " ^ c)
   3.156 +  | NONE => error ("No such constant: " ^ c))
   3.157  
   3.158  fun inv_lookup _ [] _ = NONE
   3.159    | inv_lookup eq ((key, value)::xs) value' =
   3.160 @@ -239,9 +244,10 @@
   3.161        else inv_lookup eq xs value';
   3.162  
   3.163  fun restore_const constant_table c =
   3.164 -  case inv_lookup (op =) constant_table c of
   3.165 +  (case inv_lookup (op =) constant_table c of
   3.166      SOME c' => c'
   3.167 -  | NONE => error ("No constant corresponding to "  ^ c)
   3.168 +  | NONE => error ("No constant corresponding to "  ^ c))
   3.169 +
   3.170  
   3.171  (** translation of terms, literals, premises, and clauses **)
   3.172  
   3.173 @@ -256,52 +262,53 @@
   3.174    in funpow n (fn t => AppF (Suc, [t])) (Cons zero) end
   3.175  
   3.176  fun translate_term ctxt constant_table t =
   3.177 -  case try HOLogic.dest_number t of
   3.178 +  (case try HOLogic.dest_number t of
   3.179      SOME (@{typ "int"}, n) => Number n
   3.180    | SOME (@{typ "nat"}, n) => mk_nat_term constant_table n
   3.181    | NONE =>
   3.182        (case strip_comb t of
   3.183 -        (Free (v, T), []) => Var v 
   3.184 +        (Free (v, T), []) => Var v
   3.185        | (Const (c, _), []) => Cons (translate_const constant_table c)
   3.186        | (Const (c, _), args) =>
   3.187 -        (case translate_arith_const c of
   3.188 -          SOME aop => ArithOp (aop, map (translate_term ctxt constant_table) args)
   3.189 -        | NONE =>                                                             
   3.190 -            AppF (translate_const constant_table c, map (translate_term ctxt constant_table) args))
   3.191 -      | _ => error ("illegal term for translation: " ^ Syntax.string_of_term ctxt t))
   3.192 +          (case translate_arith_const c of
   3.193 +            SOME aop => ArithOp (aop, map (translate_term ctxt constant_table) args)
   3.194 +          | NONE =>
   3.195 +              AppF (translate_const constant_table c, map (translate_term ctxt constant_table) args))
   3.196 +      | _ => error ("illegal term for translation: " ^ Syntax.string_of_term ctxt t)))
   3.197  
   3.198  fun translate_literal ctxt constant_table t =
   3.199 -  case strip_comb t of
   3.200 +  (case strip_comb t of
   3.201      (Const (@{const_name HOL.eq}, _), [l, r]) =>
   3.202        let
   3.203          val l' = translate_term ctxt constant_table l
   3.204          val r' = translate_term ctxt constant_table r
   3.205        in
   3.206 -        (if is_Var l' andalso is_arith_term r' andalso not (is_Var r') then ArithEq else Eq) (l', r')
   3.207 +        (if is_Var l' andalso is_arith_term r' andalso not (is_Var r') then ArithEq else Eq)
   3.208 +          (l', r')
   3.209        end
   3.210    | (Const (c, _), args) =>
   3.211        Rel (translate_const constant_table c, map (translate_term ctxt constant_table) args)
   3.212 -  | _ => error ("illegal literal for translation: " ^ Syntax.string_of_term ctxt t)
   3.213 +  | _ => error ("illegal literal for translation: " ^ Syntax.string_of_term ctxt t))
   3.214  
   3.215  fun NegRel_of (Rel lit) = NotRel lit
   3.216    | NegRel_of (Eq eq) = NotEq eq
   3.217    | NegRel_of (ArithEq eq) = NotArithEq eq
   3.218  
   3.219  fun mk_groundness_prems t = map Ground (Term.add_frees t [])
   3.220 -  
   3.221 -fun translate_prem ensure_groundness ctxt constant_table t =  
   3.222 -    case try HOLogic.dest_not t of
   3.223 -      SOME t =>
   3.224 -        if ensure_groundness then
   3.225 -          Conj (mk_groundness_prems t @ [NegRel_of (translate_literal ctxt constant_table t)])
   3.226 -        else
   3.227 -          NegRel_of (translate_literal ctxt constant_table t)
   3.228 -    | NONE => translate_literal ctxt constant_table t
   3.229 -    
   3.230 +
   3.231 +fun translate_prem ensure_groundness ctxt constant_table t =
   3.232 +  (case try HOLogic.dest_not t of
   3.233 +    SOME t =>
   3.234 +      if ensure_groundness then
   3.235 +        Conj (mk_groundness_prems t @ [NegRel_of (translate_literal ctxt constant_table t)])
   3.236 +      else
   3.237 +        NegRel_of (translate_literal ctxt constant_table t)
   3.238 +  | NONE => translate_literal ctxt constant_table t)
   3.239 +
   3.240  fun imp_prems_conv cv ct =
   3.241 -  case Thm.term_of ct of
   3.242 +  (case Thm.term_of ct of
   3.243      Const ("==>", _) $ _ $ _ => Conv.combination_conv (Conv.arg_conv cv) (imp_prems_conv cv) ct
   3.244 -  | _ => Conv.all_conv ct
   3.245 +  | _ => Conv.all_conv ct)
   3.246  
   3.247  fun preprocess_intro thy rule =
   3.248    Conv.fconv_rule
   3.249 @@ -330,17 +337,17 @@
   3.250  
   3.251  fun add_edges edges_of key G =
   3.252    let
   3.253 -    fun extend' key (G, visited) = 
   3.254 -      case try (Graph.get_node G) key of
   3.255 -          SOME v =>
   3.256 -            let
   3.257 -              val new_edges = filter (fn k => is_some (try (Graph.get_node G) k)) (edges_of (key, v))
   3.258 -              val (G', visited') = fold extend'
   3.259 -                (subtract (op =) (key :: visited) new_edges) (G, key :: visited)
   3.260 -            in
   3.261 -              (fold (Graph.add_edge o (pair key)) new_edges G', visited')
   3.262 -            end
   3.263 -        | NONE => (G, visited)
   3.264 +    fun extend' key (G, visited) =
   3.265 +      (case try (Graph.get_node G) key of
   3.266 +        SOME v =>
   3.267 +          let
   3.268 +            val new_edges = filter (fn k => is_some (try (Graph.get_node G) k)) (edges_of (key, v))
   3.269 +            val (G', visited') = fold extend'
   3.270 +              (subtract (op =) (key :: visited) new_edges) (G, key :: visited)
   3.271 +          in
   3.272 +            (fold (Graph.add_edge o (pair key)) new_edges G', visited')
   3.273 +          end
   3.274 +      | NONE => (G, visited))
   3.275    in
   3.276      fst (extend' key (G, []))
   3.277    end
   3.278 @@ -350,6 +357,7 @@
   3.279      "Constant " ^ const ^ "has intros:\n" ^
   3.280      cat_lines (map (Display.string_of_thm ctxt) (Graph.get_node gr const))) consts))
   3.281  
   3.282 +
   3.283  (* translation of moded predicates *)
   3.284  
   3.285  (** generating graph of moded predicates **)
   3.286 @@ -361,15 +369,20 @@
   3.287        (case fst (strip_comb t) of
   3.288          Const (c, _) => SOME (c, (pol, Predicate_Compile_Core.head_mode_of derivation))
   3.289        | _ => NONE)
   3.290 -    fun req (Predicate_Compile_Aux.Prem t, derivation) = req_mode_of polarity (t, derivation)
   3.291 -      | req (Predicate_Compile_Aux.Negprem t, derivation) = req_mode_of (not polarity) (t, derivation)
   3.292 +    fun req (Predicate_Compile_Aux.Prem t, derivation) =
   3.293 +          req_mode_of polarity (t, derivation)
   3.294 +      | req (Predicate_Compile_Aux.Negprem t, derivation) =
   3.295 +          req_mode_of (not polarity) (t, derivation)
   3.296        | req _ = NONE
   3.297 -  in      
   3.298 +  in
   3.299      maps (fn (_, prems) => map_filter req prems) cls
   3.300    end
   3.301 - 
   3.302 -structure Mode_Graph = Graph(type key = string * (bool * Predicate_Compile_Aux.mode)
   3.303 -  val ord = prod_ord fast_string_ord (prod_ord bool_ord Predicate_Compile_Aux.mode_ord));
   3.304 +
   3.305 +structure Mode_Graph =
   3.306 +  Graph(
   3.307 +    type key = string * (bool * Predicate_Compile_Aux.mode)
   3.308 +    val ord = prod_ord fast_string_ord (prod_ord bool_ord Predicate_Compile_Aux.mode_ord)
   3.309 +  )
   3.310  
   3.311  fun mk_moded_clauses_graph ctxt scc gr =
   3.312    let
   3.313 @@ -386,14 +399,16 @@
   3.314            Predicate_Compile_Core.prepare_intrs options ctxt prednames
   3.315              (maps (Core_Data.intros_of ctxt) prednames)
   3.316          val ((moded_clauses, random'), _) =
   3.317 -          Mode_Inference.infer_modes mode_analysis_options options 
   3.318 +          Mode_Inference.infer_modes mode_analysis_options options
   3.319              (lookup_modes, lookup_neg_modes, needs_random) ctxt preds all_modes param_vs clauses
   3.320          val modes = map (fn (p, mps) => (p, map fst mps)) moded_clauses
   3.321          val pos_modes' = map (apsnd (map_filter (fn (true, m) => SOME m | _ => NONE))) modes
   3.322          val neg_modes' = map (apsnd (map_filter (fn (false, m) => SOME m | _ => NONE))) modes
   3.323 -        val _ = tracing ("Inferred modes:\n" ^
   3.324 -          cat_lines (map (fn (s, ms) => s ^ ": " ^ commas (map
   3.325 -            (fn (p, m) => Predicate_Compile_Aux.string_of_mode m ^ (if p then "pos" else "neg")) ms)) modes))
   3.326 +        val _ =
   3.327 +          tracing ("Inferred modes:\n" ^
   3.328 +            cat_lines (map (fn (s, ms) => s ^ ": " ^ commas (map
   3.329 +              (fn (p, m) =>
   3.330 +                Predicate_Compile_Aux.string_of_mode m ^ (if p then "pos" else "neg")) ms)) modes))
   3.331          val gr' = gr
   3.332            |> fold (fn (p, mps) => fold (fn (mode, cls) =>
   3.333                  Mode_Graph.new_node ((p, mode), cls)) mps)
   3.334 @@ -406,8 +421,8 @@
   3.335            AList.merge (op =) (op =) (neg_modes, neg_modes'),
   3.336            AList.merge (op =) (op =) (random, random')))
   3.337        end
   3.338 -  in  
   3.339 -    fst (fold infer (rev scc) (Mode_Graph.empty, ([], [], []))) 
   3.340 +  in
   3.341 +    fst (fold infer (rev scc) (Mode_Graph.empty, ([], [], [])))
   3.342    end
   3.343  
   3.344  fun declare_moded_predicate moded_preds table =
   3.345 @@ -431,32 +446,34 @@
   3.346      fun mk_literal pol derivation constant_table' t =
   3.347        let
   3.348          val (p, args) = strip_comb t
   3.349 -        val mode = Predicate_Compile_Core.head_mode_of derivation 
   3.350 +        val mode = Predicate_Compile_Core.head_mode_of derivation
   3.351          val name = fst (dest_Const p)
   3.352 -        
   3.353 +
   3.354          val p' = the (AList.lookup (op =) moded_pred_table' (name, (pol, mode)))
   3.355          val args' = map (translate_term ctxt constant_table') args
   3.356        in
   3.357          Rel (p', args')
   3.358        end
   3.359      fun mk_prem pol (indprem, derivation) constant_table =
   3.360 -      case indprem of
   3.361 +      (case indprem of
   3.362          Predicate_Compile_Aux.Generator (s, T) => (Ground (s, T), constant_table)
   3.363        | _ =>
   3.364 -        declare_consts (Term.add_const_names (Predicate_Compile_Aux.dest_indprem indprem) []) constant_table
   3.365 +        declare_consts (Term.add_const_names (Predicate_Compile_Aux.dest_indprem indprem) [])
   3.366 +          constant_table
   3.367          |> (fn constant_table' =>
   3.368            (case indprem of Predicate_Compile_Aux.Negprem t =>
   3.369              NegRel_of (mk_literal (not pol) derivation constant_table' t)
   3.370            | _ =>
   3.371 -            mk_literal pol derivation constant_table' (Predicate_Compile_Aux.dest_indprem indprem), constant_table'))
   3.372 +            mk_literal pol derivation constant_table' (Predicate_Compile_Aux.dest_indprem indprem),
   3.373 +              constant_table')))
   3.374      fun mk_clause pred_name pol (ts, prems) (prog, constant_table) =
   3.375 -    let
   3.376 -      val constant_table' = declare_consts (fold Term.add_const_names ts []) constant_table
   3.377 -      val args = map (translate_term ctxt constant_table') ts
   3.378 -      val (prems', constant_table'') = fold_map (mk_prem pol) prems constant_table'
   3.379 -    in
   3.380 -      (((pred_name, args), Conj prems') :: prog, constant_table'')
   3.381 -    end
   3.382 +      let
   3.383 +        val constant_table' = declare_consts (fold Term.add_const_names ts []) constant_table
   3.384 +        val args = map (translate_term ctxt constant_table') ts
   3.385 +        val (prems', constant_table'') = fold_map (mk_prem pol) prems constant_table'
   3.386 +      in
   3.387 +        (((pred_name, args), Conj prems') :: prog, constant_table'')
   3.388 +      end
   3.389      fun mk_clauses (pred, mode as (pol, _)) =
   3.390        let
   3.391          val clauses = Mode_Graph.get_node moded_gr (pred, mode)
   3.392 @@ -469,35 +486,37 @@
   3.393    end
   3.394  
   3.395  fun generate (use_modes, ensure_groundness) ctxt const =
   3.396 -  let 
   3.397 +  let
   3.398      fun strong_conn_of gr keys =
   3.399        Graph.strong_conn (Graph.restrict (member (op =) (Graph.all_succs gr keys)) gr)
   3.400      val gr = Core_Data.intros_graph_of ctxt
   3.401      val gr' = add_edges depending_preds_of const gr
   3.402      val scc = strong_conn_of gr' [const]
   3.403 -    val initial_constant_table = 
   3.404 +    val initial_constant_table =
   3.405        declare_consts [@{const_name "Groups.zero_class.zero"}, @{const_name "Suc"}] []
   3.406    in
   3.407 -    case use_modes of
   3.408 +    (case use_modes of
   3.409        SOME mode =>
   3.410          let
   3.411            val moded_gr = mk_moded_clauses_graph ctxt scc gr
   3.412            val moded_gr' = Mode_Graph.restrict
   3.413              (member (op =) (Mode_Graph.all_succs moded_gr [(const, (true, mode))])) moded_gr
   3.414 -          val scc = Mode_Graph.strong_conn moded_gr' 
   3.415 +          val scc = Mode_Graph.strong_conn moded_gr'
   3.416          in
   3.417            apfst rev (apsnd snd
   3.418              (fold (mk_program ctxt moded_gr') (rev scc) ([], ([], initial_constant_table))))
   3.419          end
   3.420 -      | NONE =>
   3.421 -        let 
   3.422 +    | NONE =>
   3.423 +        let
   3.424            val _ = print_intros ctxt gr (flat scc)
   3.425            val constant_table = declare_consts (flat scc) initial_constant_table
   3.426          in
   3.427 -          apfst flat (fold_map (translate_intros ensure_groundness ctxt gr) (flat scc) constant_table)
   3.428 -        end
   3.429 +          apfst flat
   3.430 +            (fold_map (translate_intros ensure_groundness ctxt gr) (flat scc) constant_table)
   3.431 +        end)
   3.432    end
   3.433 -  
   3.434 +
   3.435 +
   3.436  (* implementation for fully enumerating predicates and
   3.437    for size-limited predicates for enumerating the values of a datatype upto a specific size *)
   3.438  
   3.439 @@ -506,20 +525,21 @@
   3.440    | add_ground_typ _ = I
   3.441  
   3.442  fun mk_relname (Type (Tcon, Targs)) =
   3.443 -  first_lower (Long_Name.base_name Tcon) ^ space_implode "_" (map mk_relname Targs)
   3.444 +      first_lower (Long_Name.base_name Tcon) ^ space_implode "_" (map mk_relname Targs)
   3.445    | mk_relname _ = raise Fail "unexpected type"
   3.446  
   3.447  fun mk_lim_relname T = "lim_" ^  mk_relname T
   3.448  
   3.449  fun is_recursive_constr T (Const (constr_name, T')) = member (op =) (binder_types T') T
   3.450 -  
   3.451 +
   3.452  fun mk_ground_impl ctxt limited_types (T as Type (Tcon, Targs)) (seen, constant_table) =
   3.453    if member (op =) seen T then ([], (seen, constant_table))
   3.454    else
   3.455      let
   3.456 -      val (limited, size) = case AList.lookup (op =) limited_types T of
   3.457 -        SOME s => (true, s)
   3.458 -      | NONE => (false, 0)      
   3.459 +      val (limited, size) =
   3.460 +        (case AList.lookup (op =) limited_types T of
   3.461 +          SOME s => (true, s)
   3.462 +        | NONE => (false, 0))
   3.463        val rel_name = (if limited then mk_lim_relname else mk_relname) T
   3.464        fun mk_impl (Const (constr_name, cT), recursive) (seen, constant_table) =
   3.465          let
   3.466 @@ -530,9 +550,9 @@
   3.467            val vars = map (fn i => Var ("x" ^ string_of_int i)) (1 upto (length Ts))
   3.468            val lim_var =
   3.469              if limited then
   3.470 -              if recursive then [AppF ("suc", [Var "Lim"])]              
   3.471 +              if recursive then [AppF ("suc", [Var "Lim"])]
   3.472                else [Var "Lim"]
   3.473 -            else [] 
   3.474 +            else []
   3.475            fun mk_prem v T' =
   3.476              if limited andalso T' = T then Rel (mk_lim_relname T', [Var "Lim", v])
   3.477              else Rel (mk_relname T', [v])
   3.478 @@ -558,18 +578,20 @@
   3.479  
   3.480  fun replace_ground (Conj prems) = Conj (map replace_ground prems)
   3.481    | replace_ground (Ground (x, T)) =
   3.482 -    Rel (mk_relname T, [Var x])  
   3.483 +    Rel (mk_relname T, [Var x])
   3.484    | replace_ground p = p
   3.485 -  
   3.486 +
   3.487  fun add_ground_predicates ctxt limited_types (p, constant_table) =
   3.488    let
   3.489      val ground_typs = fold (add_ground_typ o snd) p []
   3.490 -    val (grs, (_, constant_table')) = fold_map (mk_ground_impl ctxt limited_types) ground_typs ([], constant_table)
   3.491 +    val (grs, (_, constant_table')) =
   3.492 +      fold_map (mk_ground_impl ctxt limited_types) ground_typs ([], constant_table)
   3.493      val p' = map (apsnd replace_ground) p
   3.494    in
   3.495      ((flat grs) @ p', constant_table')
   3.496    end
   3.497  
   3.498 +
   3.499  (* make depth-limited version of predicate *)
   3.500  
   3.501  fun mk_lim_rel_name rel_name = "lim_" ^ rel_name
   3.502 @@ -593,8 +615,8 @@
   3.503  fun nat_term_of n = funpow n (fn t => AppF ("suc", [t])) (Cons "zero")
   3.504  
   3.505  fun add_limited_predicates limited_predicates (p, constant_table) =
   3.506 -  let                                     
   3.507 -    fun add (rel_names, limit) p = 
   3.508 +  let
   3.509 +    fun add (rel_names, limit) p =
   3.510        let
   3.511          val clauses = filter (fn ((rel, _), _) => member (op =) rel_names rel) p
   3.512          val clauses' = map (mk_depth_limited rel_names) clauses
   3.513 @@ -602,7 +624,7 @@
   3.514            let
   3.515              val nargs = length (snd (fst
   3.516                (the (find_first (fn ((rel, _), _) => rel = rel_name) clauses))))
   3.517 -            val vars = map (fn i => Var ("x" ^ string_of_int i)) (1 upto nargs)        
   3.518 +            val vars = map (fn i => Var ("x" ^ string_of_int i)) (1 upto nargs)
   3.519            in
   3.520              (("limited_" ^ rel_name, vars), Rel ("lim_" ^ rel_name, nat_term_of limit :: vars))
   3.521            end
   3.522 @@ -622,10 +644,12 @@
   3.523            if rel = from then Rel (to, ts) else r
   3.524        | replace_prem r = r
   3.525    in
   3.526 -    map (fn ((rel, args), prem) => ((rel, args), (if rel = location then replace_prem else I) prem)) p
   3.527 +    map
   3.528 +      (fn ((rel, args), prem) => ((rel, args), (if rel = location then replace_prem else I) prem))
   3.529 +      p
   3.530    end
   3.531  
   3.532 -  
   3.533 +
   3.534  (* reorder manually : reorder premises of ith clause of predicate p by a permutation perm *)
   3.535  
   3.536  fun reorder_manually reorder p =
   3.537 @@ -635,14 +659,16 @@
   3.538          val seen' = AList.map_default (op =) (rel, 0) (fn x => x + 1) seen
   3.539          val i = the (AList.lookup (op =) seen' rel)
   3.540          val perm = AList.lookup (op =) reorder (rel, i)
   3.541 -        val prem' = (case perm of 
   3.542 -          SOME p => (case prem of Conj prems => Conj (map (nth prems) p) | _ => prem)
   3.543 -        | NONE => prem)
   3.544 +        val prem' =
   3.545 +          (case perm of
   3.546 +            SOME p => (case prem of Conj prems => Conj (map (nth prems) p) | _ => prem)
   3.547 +          | NONE => prem)
   3.548        in (((rel, args), prem'), seen') end
   3.549    in
   3.550      fst (fold_map reorder' p [])
   3.551    end
   3.552  
   3.553 +
   3.554  (* rename variables to prolog-friendly names *)
   3.555  
   3.556  fun rename_vars_term renaming = map_vars (fn v => the (AList.lookup (op =) renaming v))
   3.557 @@ -651,7 +677,7 @@
   3.558  
   3.559  fun is_prolog_conform v =
   3.560    forall (fn s => Symbol.is_ascii_letter s orelse Symbol.is_ascii_digit s) (Symbol.explode v)
   3.561 -  
   3.562 +
   3.563  fun mk_renaming v renaming =
   3.564    (v, mk_conform first_upper "Var" (map snd renaming) v) :: renaming
   3.565  
   3.566 @@ -660,9 +686,10 @@
   3.567      val vars = fold_prem_terms add_vars prem (fold add_vars args [])
   3.568      val renaming = fold mk_renaming vars []
   3.569    in ((rel, map (rename_vars_term renaming) args), rename_vars_prem renaming prem) end
   3.570 -  
   3.571 +
   3.572  val rename_vars_program = map rename_vars_clause
   3.573  
   3.574 +
   3.575  (* limit computation globally by some threshold *)
   3.576  
   3.577  fun limit_globally ctxt limit const_name (p, constant_table) =
   3.578 @@ -679,6 +706,7 @@
   3.579      (entry_clause :: p' @ p'', constant_table)
   3.580    end
   3.581  
   3.582 +
   3.583  (* post processing of generated prolog program *)
   3.584  
   3.585  fun post_process ctxt options const_name (p, constant_table) =
   3.586 @@ -696,6 +724,7 @@
   3.587    |> apfst (reorder_manually (#manual_reorder options))
   3.588    |> apfst rename_vars_program
   3.589  
   3.590 +
   3.591  (* code printer *)
   3.592  
   3.593  fun write_arith_op Plus = "+"
   3.594 @@ -703,15 +732,17 @@
   3.595  
   3.596  fun write_term (Var v) = v
   3.597    | write_term (Cons c) = c
   3.598 -  | write_term (AppF (f, args)) = f ^ "(" ^ space_implode ", " (map write_term args) ^ ")"
   3.599 -  | write_term (ArithOp (oper, [a1, a2])) = write_term a1 ^ " " ^ write_arith_op oper ^ " " ^ write_term a2
   3.600 +  | write_term (AppF (f, args)) =
   3.601 +      f ^ "(" ^ space_implode ", " (map write_term args) ^ ")"
   3.602 +  | write_term (ArithOp (oper, [a1, a2])) =
   3.603 +      write_term a1 ^ " " ^ write_arith_op oper ^ " " ^ write_term a2
   3.604    | write_term (Number n) = string_of_int n
   3.605  
   3.606  fun write_rel (pred, args) =
   3.607 -  pred ^ "(" ^ space_implode ", " (map write_term args) ^ ")" 
   3.608 +  pred ^ "(" ^ space_implode ", " (map write_term args) ^ ")"
   3.609  
   3.610  fun write_prem (Conj prems) = space_implode ", " (map write_prem prems)
   3.611 -  | write_prem (Rel p) = write_rel p  
   3.612 +  | write_prem (Rel p) = write_rel p
   3.613    | write_prem (NotRel p) = "not(" ^ write_rel p ^ ")"
   3.614    | write_prem (Eq (l, r)) = write_term l ^ " = " ^ write_term r
   3.615    | write_prem (NotEq (l, r)) = write_term l ^ " \\= " ^ write_term r
   3.616 @@ -723,7 +754,8 @@
   3.617    write_rel head ^ (if prem = Conj [] then "." else " :- " ^ write_prem prem ^ ".")
   3.618  
   3.619  fun write_program p =
   3.620 -  cat_lines (map write_clause p) 
   3.621 +  cat_lines (map write_clause p)
   3.622 +
   3.623  
   3.624  (* query templates *)
   3.625  
   3.626 @@ -733,7 +765,7 @@
   3.627    "eval :- once("  ^ rel ^ "(" ^ space_implode ", " (map write_term args) ^ ")),\n" ^
   3.628    "writef('" ^ space_implode ";" (map (fn v => v ^ " = %w") vnames) ^
   3.629    "\\n', [" ^ space_implode ", " vnames ^ "]).\n"
   3.630 -  
   3.631 +
   3.632  fun swi_prolog_query_firstn n (rel, args) vnames =
   3.633    "eval :- findnsols(" ^ string_of_int n ^ ", (" ^ space_implode ", " vnames ^ "), " ^
   3.634      rel ^ "(" ^ space_implode ", " (map write_term args) ^ "), Sols), writelist(Sols).\n" ^
   3.635 @@ -741,7 +773,7 @@
   3.636      "writelist([(" ^ space_implode ", " vnames ^ ")|SolutionTail]) :- " ^
   3.637      "writef('" ^ space_implode ";" (map (fn v => v ^ " = %w") vnames) ^
   3.638      "\\n', [" ^ space_implode ", " vnames ^ "]), writelist(SolutionTail).\n"
   3.639 -  
   3.640 +
   3.641  val swi_prolog_prelude =
   3.642    ":- use_module(library('dialect/ciao/aggregates')).\n" ^
   3.643    ":- style_check(-singleton).\n" ^
   3.644 @@ -750,6 +782,7 @@
   3.645    "main :- catch(eval, E, (print_message(error, E), fail)), halt.\n" ^
   3.646    "main :- halt(1).\n"
   3.647  
   3.648 +
   3.649  (** query and prelude for yap **)
   3.650  
   3.651  fun yap_query_first (rel, args) vnames =
   3.652 @@ -760,18 +793,25 @@
   3.653  val yap_prelude =
   3.654    ":- initialization(eval).\n"
   3.655  
   3.656 +
   3.657  (* system-dependent query, prelude and invocation *)
   3.658  
   3.659 -fun query system nsols = 
   3.660 -  case system of
   3.661 +fun query system nsols =
   3.662 +  (case system of
   3.663      SWI_PROLOG =>
   3.664 -      (case nsols of NONE => swi_prolog_query_first | SOME n => swi_prolog_query_firstn n)
   3.665 +      (case nsols of
   3.666 +        NONE => swi_prolog_query_first
   3.667 +      | SOME n => swi_prolog_query_firstn n)
   3.668    | YAP =>
   3.669 -      case nsols of NONE => yap_query_first | SOME n =>
   3.670 -        error "No support for querying multiple solutions in the prolog system yap"
   3.671 +      (case nsols of
   3.672 +        NONE => yap_query_first
   3.673 +      | SOME n =>
   3.674 +          error "No support for querying multiple solutions in the prolog system yap"))
   3.675  
   3.676  fun prelude system =
   3.677 -  case system of SWI_PROLOG => swi_prolog_prelude | YAP => yap_prelude
   3.678 +  (case system of
   3.679 +    SWI_PROLOG => swi_prolog_prelude
   3.680 +  | YAP => yap_prelude)
   3.681  
   3.682  fun invoke system file =
   3.683    let
   3.684 @@ -797,7 +837,8 @@
   3.685    Scan.many1 Symbol.is_ascii_digit
   3.686  
   3.687  val scan_atom =
   3.688 -  Scan.many1 (fn s => Symbol.is_ascii_lower s orelse Symbol.is_ascii_digit s orelse Symbol.is_ascii_quasi s)
   3.689 +  Scan.many1
   3.690 +    (fn s => Symbol.is_ascii_lower s orelse Symbol.is_ascii_digit s orelse Symbol.is_ascii_quasi s)
   3.691  
   3.692  val scan_var =
   3.693    Scan.many1
   3.694 @@ -814,7 +855,8 @@
   3.695  val is_atom_ident = forall Symbol.is_ascii_lower
   3.696  
   3.697  val is_var_ident =
   3.698 -  forall (fn s => Symbol.is_ascii_upper s orelse Symbol.is_ascii_digit s orelse Symbol.is_ascii_quasi s)
   3.699 +  forall (fn s =>
   3.700 +    Symbol.is_ascii_upper s orelse Symbol.is_ascii_digit s orelse Symbol.is_ascii_quasi s)
   3.701  
   3.702  fun int_of_symbol_list xs = fold (fn x => fn s => s * 10 + (ord x - ord "0")) xs 0
   3.703  
   3.704 @@ -830,23 +872,25 @@
   3.705  val parse_term = fst o Scan.finite Symbol.stopper
   3.706      (Scan.error (!! (fn _ => raise Fail "parsing prolog output failed")) scan_term)
   3.707    o raw_explode
   3.708 -  
   3.709 +
   3.710  fun parse_solutions sol =
   3.711    let
   3.712 -    fun dest_eq s = case space_explode "=" s of
   3.713 +    fun dest_eq s =
   3.714 +      (case space_explode "=" s of
   3.715          (l :: r :: []) => parse_term (unprefix " " r)
   3.716 -      | _ => raise Fail "unexpected equation in prolog output"
   3.717 +      | _ => raise Fail "unexpected equation in prolog output")
   3.718      fun parse_solution s = map dest_eq (space_explode ";" s)
   3.719 -    val sols = case space_explode "\n" sol of [] => [] | s => fst (split_last s)  
   3.720 +    val sols = (case space_explode "\n" sol of [] => [] | s => fst (split_last s))
   3.721    in
   3.722      map parse_solution sols
   3.723 -  end 
   3.724 -  
   3.725 +  end
   3.726 +
   3.727 +
   3.728  (* calling external interpreter and getting results *)
   3.729  
   3.730  fun run (timeout, system) p (query_rel, args) vnames nsols =
   3.731    let
   3.732 -    val renaming = fold mk_renaming (fold add_vars args vnames) [] 
   3.733 +    val renaming = fold mk_renaming (fold add_vars args vnames) []
   3.734      val vnames' = map (fn v => the (AList.lookup (op =) renaming v)) vnames
   3.735      val args' = map (rename_vars_term renaming) args
   3.736      val prog = prelude system ^ query system nsols (query_rel, args') vnames' ^ write_program p
   3.737 @@ -860,26 +904,27 @@
   3.738      tss
   3.739    end
   3.740  
   3.741 +
   3.742  (* restoring types in terms *)
   3.743  
   3.744  fun restore_term ctxt constant_table (Var s, T) = Free (s, T)
   3.745    | restore_term ctxt constant_table (Number n, @{typ "int"}) = HOLogic.mk_number @{typ "int"} n
   3.746 -  | restore_term ctxt constant_table (Number n, _) = raise (Fail "unexpected type for number") 
   3.747 +  | restore_term ctxt constant_table (Number n, _) = raise (Fail "unexpected type for number")
   3.748    | restore_term ctxt constant_table (Cons s, T) = Const (restore_const constant_table s, T)
   3.749    | restore_term ctxt constant_table (AppF (f, args), T) =
   3.750 -    let
   3.751 -      val thy = Proof_Context.theory_of ctxt
   3.752 -      val c = restore_const constant_table f
   3.753 -      val cT = Sign.the_const_type thy c
   3.754 -      val (argsT, resT) = strip_type cT
   3.755 -      val subst = Sign.typ_match thy (resT, T) Vartab.empty
   3.756 -      val argsT' = map (Envir.subst_type subst) argsT
   3.757 -    in
   3.758 -      list_comb (Const (c, Envir.subst_type subst cT),
   3.759 -        map (restore_term ctxt constant_table) (args ~~ argsT'))
   3.760 -    end
   3.761 +      let
   3.762 +        val thy = Proof_Context.theory_of ctxt
   3.763 +        val c = restore_const constant_table f
   3.764 +        val cT = Sign.the_const_type thy c
   3.765 +        val (argsT, resT) = strip_type cT
   3.766 +        val subst = Sign.typ_match thy (resT, T) Vartab.empty
   3.767 +        val argsT' = map (Envir.subst_type subst) argsT
   3.768 +      in
   3.769 +        list_comb (Const (c, Envir.subst_type subst cT),
   3.770 +          map (restore_term ctxt constant_table) (args ~~ argsT'))
   3.771 +      end
   3.772  
   3.773 -    
   3.774 +
   3.775  (* restore numerals in natural numbers *)
   3.776  
   3.777  fun restore_nat_numerals t =
   3.778 @@ -887,9 +932,10 @@
   3.779      HOLogic.mk_number @{typ nat} (HOLogic.dest_nat t)
   3.780    else
   3.781      (case t of
   3.782 -        t1 $ t2 => restore_nat_numerals t1 $ restore_nat_numerals t2
   3.783 -      | t => t)
   3.784 -  
   3.785 +      t1 $ t2 => restore_nat_numerals t1 $ restore_nat_numerals t2
   3.786 +    | t => t)
   3.787 +
   3.788 +
   3.789  (* values command *)
   3.790  
   3.791  val preprocess_options = Predicate_Compile_Aux.Options {
   3.792 @@ -919,17 +965,19 @@
   3.793  fun values ctxt soln t_compr =
   3.794    let
   3.795      val options = code_options_of (Proof_Context.theory_of ctxt)
   3.796 -    val split = case t_compr of (Const (@{const_name Collect}, _) $ t) => t
   3.797 -      | _ => error ("Not a set comprehension: " ^ Syntax.string_of_term ctxt t_compr);
   3.798 -    val (body, Ts, fp) = HOLogic.strip_psplits split;
   3.799 +    val split =
   3.800 +      (case t_compr of
   3.801 +        (Const (@{const_name Collect}, _) $ t) => t
   3.802 +      | _ => error ("Not a set comprehension: " ^ Syntax.string_of_term ctxt t_compr))
   3.803 +    val (body, Ts, fp) = HOLogic.strip_psplits split
   3.804      val output_names = Name.variant_list (Term.add_free_names body [])
   3.805        (map (fn i => "x" ^ string_of_int i) (1 upto length Ts))
   3.806      val output_frees = rev (map2 (curry Free) output_names Ts)
   3.807      val body = subst_bounds (output_frees, body)
   3.808      val (pred as Const (name, T), all_args) =
   3.809 -      case strip_comb body of
   3.810 +      (case strip_comb body of
   3.811          (Const (name, T), all_args) => (Const (name, T), all_args)
   3.812 -      | (head, _) => error ("Not a constant: " ^ Syntax.string_of_term ctxt head)
   3.813 +      | (head, _) => error ("Not a constant: " ^ Syntax.string_of_term ctxt head))
   3.814      val _ = tracing "Preprocessing specification..."
   3.815      val T = Sign.the_const_type (Proof_Context.theory_of ctxt) name
   3.816      val t = Const (name, T)
   3.817 @@ -949,7 +997,7 @@
   3.818      val _ = tracing "Restoring terms..."
   3.819      val empty = Const(@{const_name bot}, fastype_of t_compr)
   3.820      fun mk_insert x S =
   3.821 -      Const (@{const_name "Set.insert"}, fastype_of x --> fastype_of S --> fastype_of S) $ x $ S 
   3.822 +      Const (@{const_name "Set.insert"}, fastype_of x --> fastype_of S --> fastype_of S) $ x $ S
   3.823      fun mk_set_compr in_insert [] xs =
   3.824         rev ((Free ("dots", fastype_of t_compr)) ::  (* FIXME proper name!? *)
   3.825          (if null in_insert then xs else (fold mk_insert in_insert empty) :: xs))
   3.826 @@ -961,19 +1009,22 @@
   3.827              mk_set_compr (t :: in_insert) ts xs
   3.828            else
   3.829              let
   3.830 -              val uu as (uuN, uuT) = singleton (Variable.variant_frees ctxt' [t]) ("uu", fastype_of t)
   3.831 +              val uu as (uuN, uuT) =
   3.832 +                singleton (Variable.variant_frees ctxt' [t]) ("uu", fastype_of t)
   3.833                val set_compr =
   3.834 -                HOLogic.mk_Collect (uuN, uuT, fold (fn (s, T) => fn t => HOLogic.mk_exists (s, T, t))
   3.835 -                  frees (HOLogic.mk_conj (HOLogic.mk_eq (Free uu, t), @{term "True"})))
   3.836 +                HOLogic.mk_Collect (uuN, uuT,
   3.837 +                  fold (fn (s, T) => fn t => HOLogic.mk_exists (s, T, t))
   3.838 +                    frees (HOLogic.mk_conj (HOLogic.mk_eq (Free uu, t), @{term "True"})))
   3.839              in
   3.840                mk_set_compr [] ts
   3.841 -                (set_compr :: (if null in_insert then xs else (fold mk_insert in_insert empty) :: xs))  
   3.842 +                (set_compr ::
   3.843 +                  (if null in_insert then xs else (fold mk_insert in_insert empty) :: xs))
   3.844              end
   3.845          end
   3.846    in
   3.847 -      foldl1 (HOLogic.mk_binop @{const_name sup}) (mk_set_compr []
   3.848 -        (map (fn ts => HOLogic.mk_tuple 
   3.849 -          (map (restore_nat_numerals o restore_term ctxt' constant_table) (ts ~~ Ts))) tss) [])
   3.850 +    foldl1 (HOLogic.mk_binop @{const_name sup}) (mk_set_compr []
   3.851 +      (map (fn ts => HOLogic.mk_tuple
   3.852 +        (map (restore_nat_numerals o restore_term ctxt' constant_table) (ts ~~ Ts))) tss) [])
   3.853    end
   3.854  
   3.855  fun values_cmd print_modes soln raw_t state =
   3.856 @@ -984,30 +1035,31 @@
   3.857      val ty' = Term.type_of t'
   3.858      val ctxt' = Variable.auto_fixes t' ctxt
   3.859      val _ = tracing "Printing terms..."
   3.860 -    val p = Print_Mode.with_modes print_modes (fn () =>
   3.861 +  in
   3.862 +    Print_Mode.with_modes print_modes (fn () =>
   3.863        Pretty.block [Pretty.quote (Syntax.pretty_term ctxt' t'), Pretty.fbrk,
   3.864 -        Pretty.str "::", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt' ty')]) ();
   3.865 -  in Pretty.writeln p end;
   3.866 +        Pretty.str "::", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt' ty')]) ()
   3.867 +  end |> Pretty.writeln p
   3.868  
   3.869  
   3.870  (* renewing the values command for Prolog queries *)
   3.871  
   3.872  val opt_print_modes =
   3.873 -  Scan.optional (@{keyword "("} |-- Parse.!!! (Scan.repeat1 Parse.xname --| @{keyword ")"})) [];
   3.874 +  Scan.optional (@{keyword "("} |-- Parse.!!! (Scan.repeat1 Parse.xname --| @{keyword ")"})) []
   3.875  
   3.876  val _ =
   3.877    Outer_Syntax.improper_command @{command_spec "values"}
   3.878      "enumerate and print comprehensions"
   3.879      (opt_print_modes -- Scan.optional (Parse.nat >> SOME) NONE -- Parse.term
   3.880       >> (fn ((print_modes, soln), t) => Toplevel.keep
   3.881 -          (values_cmd print_modes soln t))); (*FIXME does not preserve the previous functionality*)
   3.882 +          (values_cmd print_modes soln t))) (*FIXME does not preserve the previous functionality*)
   3.883  
   3.884  
   3.885  (* quickcheck generator *)
   3.886  
   3.887  (* FIXME: a small clone of Predicate_Compile_Quickcheck - maybe refactor out commons *)
   3.888  
   3.889 -val active = Attrib.setup_config_bool @{binding quickcheck_prolog_active} (K true);
   3.890 +val active = Attrib.setup_config_bool @{binding quickcheck_prolog_active} (K true)
   3.891  
   3.892  fun test_term ctxt (t, eval_terms) =
   3.893    let
   3.894 @@ -1028,14 +1080,17 @@
   3.895        p (translate_const constant_table full_constname, map (Var o fst) vs') (map fst vs') (SOME 1)
   3.896      val _ = tracing "Restoring terms..."
   3.897      val counterexample =
   3.898 -      case tss of
   3.899 +      (case tss of
   3.900          [ts] => SOME (map (restore_term ctxt' constant_table) (ts ~~ map snd vs'))
   3.901 -      | _ => NONE
   3.902 +      | _ => NONE)
   3.903    in
   3.904      Quickcheck.Result
   3.905 -      {counterexample = Option.map (pair true o curry (op ~~) (Term.add_free_names t [])) counterexample,
   3.906 -       evaluation_terms = Option.map (K []) counterexample, timings = [], reports = []}
   3.907 -  end;
   3.908 +      {counterexample =
   3.909 +        Option.map (pair true o curry (op ~~) (Term.add_free_names t [])) counterexample,
   3.910 +       evaluation_terms = Option.map (K []) counterexample,
   3.911 +       timings = [],
   3.912 +       reports = []}
   3.913 +  end
   3.914  
   3.915  fun test_goals ctxt _ insts goals =
   3.916    let
   3.917 @@ -1043,6 +1098,5 @@
   3.918    in
   3.919      Quickcheck_Common.collect_results (test_term ctxt) (maps (map snd) correct_inst_goals) []
   3.920    end
   3.921 -  
   3.922 -  
   3.923 -end;
   3.924 +
   3.925 +end
     4.1 --- a/src/HOL/Tools/Predicate_Compile/core_data.ML	Wed Feb 12 10:59:25 2014 +0100
     4.2 +++ b/src/HOL/Tools/Predicate_Compile/core_data.ML	Wed Feb 12 14:32:45 2014 +0100
     4.3 @@ -133,14 +133,16 @@
     4.4    val merge = Graph.merge eq_pred_data;
     4.5  );
     4.6  
     4.7 +
     4.8  (* queries *)
     4.9  
    4.10  fun lookup_pred_data ctxt name =
    4.11    Option.map rep_pred_data (try (Graph.get_node (PredData.get (Proof_Context.theory_of ctxt))) name)
    4.12  
    4.13 -fun the_pred_data ctxt name = case lookup_pred_data ctxt name
    4.14 - of NONE => error ("No such predicate " ^ quote name)  
    4.15 -  | SOME data => data;
    4.16 +fun the_pred_data ctxt name =
    4.17 +  (case lookup_pred_data ctxt name of
    4.18 +    NONE => error ("No such predicate " ^ quote name)  
    4.19 +  | SOME data => data)
    4.20  
    4.21  val is_registered = is_some oo lookup_pred_data
    4.22  
    4.23 @@ -150,24 +152,26 @@
    4.24  
    4.25  val names_of = map fst o #intros oo the_pred_data
    4.26  
    4.27 -fun the_elim_of ctxt name = case #elim (the_pred_data ctxt name)
    4.28 - of NONE => error ("No elimination rule for predicate " ^ quote name)
    4.29 -  | SOME thm => thm
    4.30 +fun the_elim_of ctxt name =
    4.31 +  (case #elim (the_pred_data ctxt name) of
    4.32 +    NONE => error ("No elimination rule for predicate " ^ quote name)
    4.33 +  | SOME thm => thm)
    4.34    
    4.35  val has_elim = is_some o #elim oo the_pred_data
    4.36  
    4.37  fun function_names_of compilation ctxt name =
    4.38 -  case AList.lookup (op =) (#function_names (the_pred_data ctxt name)) compilation of
    4.39 -    NONE => error ("No " ^ string_of_compilation compilation
    4.40 -      ^ " functions defined for predicate " ^ quote name)
    4.41 -  | SOME fun_names => fun_names
    4.42 +  (case AList.lookup (op =) (#function_names (the_pred_data ctxt name)) compilation of
    4.43 +    NONE =>
    4.44 +      error ("No " ^ string_of_compilation compilation ^
    4.45 +        " functions defined for predicate " ^ quote name)
    4.46 +  | SOME fun_names => fun_names)
    4.47  
    4.48  fun function_name_of compilation ctxt name mode =
    4.49 -  case AList.lookup eq_mode
    4.50 -    (function_names_of compilation ctxt name) mode of
    4.51 -    NONE => error ("No " ^ string_of_compilation compilation
    4.52 -      ^ " function defined for mode " ^ string_of_mode mode ^ " of predicate " ^ quote name)
    4.53 -  | SOME function_name => function_name
    4.54 +  (case AList.lookup eq_mode (function_names_of compilation ctxt name) mode of
    4.55 +    NONE =>
    4.56 +      error ("No " ^ string_of_compilation compilation ^
    4.57 +        " function defined for mode " ^ string_of_mode mode ^ " of predicate " ^ quote name)
    4.58 +  | SOME function_name => function_name)
    4.59  
    4.60  fun modes_of compilation ctxt name = map fst (function_names_of compilation ctxt name)
    4.61  
    4.62 @@ -177,9 +181,10 @@
    4.63  
    4.64  val all_random_modes_of = all_modes_of Random
    4.65  
    4.66 -fun defined_functions compilation ctxt name = case lookup_pred_data ctxt name of
    4.67 +fun defined_functions compilation ctxt name =
    4.68 +  (case lookup_pred_data ctxt name of
    4.69      NONE => false
    4.70 -  | SOME data => AList.defined (op =) (#function_names data) compilation
    4.71 +  | SOME data => AList.defined (op =) (#function_names data) compilation)
    4.72  
    4.73  fun needs_random ctxt s m =
    4.74    member (op =) (#needs_random (the_pred_data ctxt s)) m
    4.75 @@ -189,10 +194,11 @@
    4.76      (AList.lookup eq_mode (#predfun_data (the_pred_data ctxt name)) mode)
    4.77  
    4.78  fun the_predfun_data ctxt name mode =
    4.79 -  case lookup_predfun_data ctxt name mode of
    4.80 -    NONE => error ("No function defined for mode " ^ string_of_mode mode ^
    4.81 -      " of predicate " ^ name)
    4.82 -  | SOME data => data;
    4.83 +  (case lookup_predfun_data ctxt name mode of
    4.84 +    NONE =>
    4.85 +      error ("No function defined for mode " ^ string_of_mode mode ^
    4.86 +        " of predicate " ^ name)
    4.87 +  | SOME data => data)
    4.88  
    4.89  val predfun_definition_of = #definition ooo the_predfun_data
    4.90  
    4.91 @@ -221,7 +227,8 @@
    4.92          val case_th =
    4.93            rewrite_rule ctxt (@{thm Predicate.eq_is_eq} :: map meta_eq_of eqs) (nth cases (i - 1))
    4.94          val prems' = maps (dest_conjunct_prem o rewrite_rule ctxt tuple_rew_rules) prems
    4.95 -        val pats = map (swap o HOLogic.dest_eq o HOLogic.dest_Trueprop) (take nargs (prems_of case_th))
    4.96 +        val pats =
    4.97 +          map (swap o HOLogic.dest_eq o HOLogic.dest_Trueprop) (take nargs (prems_of case_th))
    4.98          val case_th' = Thm.instantiate ([], inst_of_matches pats) case_th
    4.99            OF (replicate nargs @{thm refl})
   4.100          val thesis =
   4.101 @@ -242,6 +249,7 @@
   4.102      Goal.prove ctxt (Term.add_free_names cases_rule []) [] cases_rule (fn _ => tac)
   4.103    end
   4.104  
   4.105 +
   4.106  (* updaters *)
   4.107  
   4.108  (* fetching introduction rules or registering introduction rules *)
   4.109 @@ -249,7 +257,7 @@
   4.110  val no_compilation = ([], ([], []))
   4.111  
   4.112  fun fetch_pred_data ctxt name =
   4.113 -  case try (Inductive.the_inductive ctxt) name of
   4.114 +  (case try (Inductive.the_inductive ctxt) name of
   4.115      SOME (info as (_, result)) => 
   4.116        let
   4.117          fun is_intro_of intro =
   4.118 @@ -267,7 +275,7 @@
   4.119        in
   4.120          mk_pred_data (((map (pair NONE) intros, SOME elim), true), no_compilation)
   4.121        end
   4.122 -  | NONE => error ("No such predicate: " ^ quote name)
   4.123 +  | NONE => error ("No such predicate: " ^ quote name))
   4.124  
   4.125  fun add_predfun_data name mode data =
   4.126    let
   4.127 @@ -294,16 +302,19 @@
   4.128    let
   4.129      val (name, _) = dest_Const (fst (strip_intro_concl thm))
   4.130      fun cons_intro gr =
   4.131 -     case try (Graph.get_node gr) name of
   4.132 -       SOME _ => Graph.map_node name (map_pred_data
   4.133 -         (apfst (apfst (apfst (fn intros => intros @ [(opt_case_name, thm)]))))) gr
   4.134 -     | NONE => Graph.new_node (name, mk_pred_data ((([(opt_case_name, thm)], NONE), false), no_compilation)) gr
   4.135 +      (case try (Graph.get_node gr) name of
   4.136 +        SOME _ =>
   4.137 +          Graph.map_node name (map_pred_data
   4.138 +            (apfst (apfst (apfst (fn intros => intros @ [(opt_case_name, thm)]))))) gr
   4.139 +      | NONE =>
   4.140 +          Graph.new_node
   4.141 +            (name, mk_pred_data ((([(opt_case_name, thm)], NONE), false), no_compilation)) gr)
   4.142    in PredData.map cons_intro thy end
   4.143  
   4.144  fun set_elim thm =
   4.145    let
   4.146 -    val (name, _) = dest_Const (fst 
   4.147 -      (strip_comb (HOLogic.dest_Trueprop (hd (prems_of thm)))))
   4.148 +    val (name, _) =
   4.149 +      dest_Const (fst (strip_comb (HOLogic.dest_Trueprop (hd (prems_of thm)))))
   4.150    in PredData.map (Graph.map_node name (map_pred_data (apfst (apfst (apsnd (K (SOME thm))))))) end
   4.151  
   4.152  fun register_predicate (constname, intros, elim) thy =
   4.153 @@ -356,12 +367,14 @@
   4.154  
   4.155  fun extend' value_of edges_of key (G, visited) =
   4.156    let
   4.157 -    val (G', v) = case try (Graph.get_node G) key of
   4.158 +    val (G', v) =
   4.159 +      (case try (Graph.get_node G) key of
   4.160          SOME v => (G, v)
   4.161 -      | NONE => (Graph.new_node (key, value_of key) G, value_of key)
   4.162 -    val (G'', visited') = fold (extend' value_of edges_of)
   4.163 -      (subtract (op =) visited (edges_of (key, v)))
   4.164 -      (G', key :: visited)
   4.165 +      | NONE => (Graph.new_node (key, value_of key) G, value_of key))
   4.166 +    val (G'', visited') =
   4.167 +      fold (extend' value_of edges_of)
   4.168 +        (subtract (op =) visited (edges_of (key, v)))
   4.169 +        (G', key :: visited)
   4.170    in
   4.171      (fold (Graph.add_edge o (pair key)) (edges_of (key, v)) G'', visited')
   4.172    end;
   4.173 @@ -391,14 +404,15 @@
   4.174        end))))
   4.175      thy  
   4.176  
   4.177 +
   4.178  (* registration of alternative function names *)
   4.179  
   4.180  structure Alt_Compilations_Data = Theory_Data
   4.181  (
   4.182 -  type T = (mode * (compilation_funs -> typ -> term)) list Symtab.table;
   4.183 -  val empty = Symtab.empty;
   4.184 -  val extend = I;
   4.185 -  fun merge data : T = Symtab.merge (K true) data;
   4.186 +  type T = (mode * (compilation_funs -> typ -> term)) list Symtab.table
   4.187 +  val empty = Symtab.empty
   4.188 +  val extend = I
   4.189 +  fun merge data : T = Symtab.merge (K true) data
   4.190  );
   4.191  
   4.192  fun alternative_compilation_of_global thy pred_name mode =
   4.193 @@ -416,19 +430,21 @@
   4.194        (List.partition (fn (_, (_, random)) => random) compilations)
   4.195      val non_random_dummys = map (rpair "dummy") non_random_modes
   4.196      val all_dummys = map (rpair "dummy") modes
   4.197 -    val dummy_function_names = map (rpair all_dummys) Predicate_Compile_Aux.random_compilations
   4.198 -      @ map (rpair non_random_dummys) Predicate_Compile_Aux.non_random_compilations
   4.199 +    val dummy_function_names =
   4.200 +      map (rpair all_dummys) Predicate_Compile_Aux.random_compilations @
   4.201 +      map (rpair non_random_dummys) Predicate_Compile_Aux.non_random_compilations
   4.202      val alt_compilations = map (apsnd fst) compilations
   4.203    in
   4.204 -    PredData.map (Graph.new_node
   4.205 -      (pred_name, mk_pred_data ((([], SOME @{thm refl}), true), (dummy_function_names, ([], needs_random)))))
   4.206 +    PredData.map
   4.207 +      (Graph.new_node
   4.208 +        (pred_name,
   4.209 +          mk_pred_data ((([], SOME @{thm refl}), true), (dummy_function_names, ([], needs_random)))))
   4.210      #> Alt_Compilations_Data.map (Symtab.insert (K false) (pred_name, alt_compilations))
   4.211    end
   4.212  
   4.213  fun functional_compilation fun_name mode compfuns T =
   4.214    let
   4.215 -    val (inpTs, outpTs) = split_map_modeT (fn _ => fn T => (SOME T, NONE))
   4.216 -      mode (binder_types T)
   4.217 +    val (inpTs, outpTs) = split_map_modeT (fn _ => fn T => (SOME T, NONE)) mode (binder_types T)
   4.218      val bs = map (pair "x") inpTs
   4.219      val bounds = map Bound (rev (0 upto (length bs) - 1))
   4.220      val f = Const (fun_name, inpTs ---> HOLogic.mk_tupleT outpTs)
   4.221 @@ -443,4 +459,4 @@
   4.222      (map (fn (mode, (fun_name, random)) => (mode, (functional_compilation fun_name mode, random)))
   4.223      fun_names)
   4.224  
   4.225 -end;
   4.226 \ No newline at end of file
   4.227 +end
   4.228 \ No newline at end of file
     5.1 --- a/src/HOL/Tools/Predicate_Compile/mode_inference.ML	Wed Feb 12 10:59:25 2014 +0100
     5.2 +++ b/src/HOL/Tools/Predicate_Compile/mode_inference.ML	Wed Feb 12 14:32:45 2014 +0100
     5.3 @@ -71,8 +71,10 @@
     5.4  fun mode_of (Context m) = m
     5.5    | mode_of (Term m) = m
     5.6    | mode_of (Mode_App (d1, d2)) =
     5.7 -    (case mode_of d1 of Fun (m, m') =>
     5.8 -        (if eq_mode (m, mode_of d2) then m' else raise Fail "mode_of: derivation has mismatching modes")
     5.9 +      (case mode_of d1 of
    5.10 +        Fun (m, m') =>
    5.11 +          (if eq_mode (m, mode_of d2) then m'
    5.12 +           else raise Fail "mode_of: derivation has mismatching modes")
    5.13        | _ => raise Fail "mode_of: derivation has a non-functional mode")
    5.14    | mode_of (Mode_Pair (d1, d2)) =
    5.15      Pair (mode_of d1, mode_of d2)
    5.16 @@ -109,12 +111,12 @@
    5.17      (Syntax.string_of_term ctxt (HOLogic.mk_not t)) ^ "(negative premise)"
    5.18    | string_of_prem ctxt (Sidecond t) =
    5.19      (Syntax.string_of_term ctxt t) ^ "(sidecondition)"
    5.20 -  | string_of_prem ctxt _ = raise Fail "string_of_prem: unexpected input"
    5.21 +  | string_of_prem _ _ = raise Fail "string_of_prem: unexpected input"
    5.22  
    5.23  type mode_analysis_options =
    5.24    {use_generators : bool,
    5.25 -  reorder_premises : bool,
    5.26 -  infer_pos_and_neg_modes : bool}
    5.27 +   reorder_premises : bool,
    5.28 +   infer_pos_and_neg_modes : bool}
    5.29  
    5.30  (*** check if a type is an equality type (i.e. doesn't contain fun)
    5.31    FIXME this is only an approximation ***)
    5.32 @@ -134,7 +136,7 @@
    5.33  
    5.34  fun error_of p (_, m) is =
    5.35    "  Clauses " ^ commas (map (fn i => string_of_int (i + 1)) is) ^ " of " ^
    5.36 -        p ^ " violates mode " ^ string_of_mode m
    5.37 +  p ^ " violates mode " ^ string_of_mode m
    5.38  
    5.39  fun is_all_input mode =
    5.40    let
     6.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile.ML	Wed Feb 12 10:59:25 2014 +0100
     6.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile.ML	Wed Feb 12 14:32:45 2014 +0100
     6.3 @@ -24,18 +24,20 @@
     6.4  
     6.5  fun print_intross options thy msg intross =
     6.6    if show_intermediate_results options then
     6.7 -    tracing (msg ^ 
     6.8 -      (space_implode "\n" (map 
     6.9 +    tracing (msg ^
    6.10 +      (space_implode "\n" (map
    6.11          (fn (c, intros) => "Introduction rule(s) of " ^ c ^ ":\n" ^
    6.12             commas (map (Display.string_of_thm_global thy) intros)) intross)))
    6.13    else ()
    6.14 -      
    6.15 +
    6.16  fun print_specs options thy specs =
    6.17    if show_intermediate_results options then
    6.18 -    map (fn (c, thms) => "Constant " ^ c ^ " has specification:\n"
    6.19 -      ^ (space_implode "\n" (map (Display.string_of_thm_global thy) thms)) ^ "\n") specs
    6.20 +    map (fn (c, thms) =>
    6.21 +      "Constant " ^ c ^ " has specification:\n" ^
    6.22 +        (space_implode "\n" (map (Display.string_of_thm_global thy) thms)) ^ "\n") specs
    6.23      |> space_implode "\n" |> tracing
    6.24    else ()
    6.25 +
    6.26  fun overload_const thy s = the_default s (Option.map fst (Axclass.inst_of_param thy s))
    6.27  
    6.28  fun map_specs f specs =
    6.29 @@ -44,8 +46,12 @@
    6.30  fun process_specification options specs thy' =
    6.31    let
    6.32      val _ = print_step options "Compiling predicates to flat introrules..."
    6.33 -    val specs = map (apsnd (map
    6.34 -      (fn th => if is_equationlike th then Predicate_Compile_Data.normalize_equation thy' th else th))) specs
    6.35 +    val specs =
    6.36 +      map
    6.37 +        (apsnd (map
    6.38 +          (fn th =>
    6.39 +            if is_equationlike th then Predicate_Compile_Data.normalize_equation thy' th else th)))
    6.40 +        specs
    6.41      val (intross1, thy'') =
    6.42        apfst flat (fold_map (Predicate_Compile_Pred.preprocess options) specs thy')
    6.43      val _ = print_intross options thy'' "Flattened introduction rules: " intross1
    6.44 @@ -53,21 +59,24 @@
    6.45      val intross2 =
    6.46        if function_flattening options then
    6.47          if fail_safe_function_flattening options then
    6.48 -          case try (map_specs (maps (Predicate_Compile_Fun.rewrite_intro thy''))) intross1 of
    6.49 +          (case try (map_specs (maps (Predicate_Compile_Fun.rewrite_intro thy''))) intross1 of
    6.50              SOME intross => intross
    6.51            | NONE =>
    6.52              (if show_caught_failures options then tracing "Function replacement failed!" else ();
    6.53 -            intross1)
    6.54 +             intross1))
    6.55          else map_specs (maps (Predicate_Compile_Fun.rewrite_intro thy'')) intross1
    6.56        else
    6.57          intross1
    6.58      val _ = print_intross options thy'' "Introduction rules with replaced functions: " intross2
    6.59 -    val _ = print_step options "Introducing new constants for abstractions at higher-order argument positions..."
    6.60 -    val (intross3, (new_defs, thy''')) = Predicate_Compile_Pred.flat_higher_order_arguments (intross2, thy'')
    6.61 -    val (new_intross, thy'''')  =
    6.62 +    val _ = print_step options
    6.63 +      "Introducing new constants for abstractions at higher-order argument positions..."
    6.64 +    val (intross3, (new_defs, thy''')) =
    6.65 +      Predicate_Compile_Pred.flat_higher_order_arguments (intross2, thy'')
    6.66 +    val (new_intross, thy'''') =
    6.67        if not (null new_defs) then
    6.68          let
    6.69 -          val _ = print_step options "Recursively obtaining introduction rules for new definitions..."
    6.70 +          val _ =
    6.71 +            print_step options "Recursively obtaining introduction rules for new definitions..."
    6.72          in process_specification options new_defs thy''' end
    6.73        else ([], thy''')
    6.74    in
    6.75 @@ -75,9 +84,8 @@
    6.76    end
    6.77  
    6.78  fun preprocess_strong_conn_constnames options gr ts thy =
    6.79 -  if forall (fn (Const (c, _)) =>
    6.80 -      Core_Data.is_registered (Proof_Context.init_global thy) c) ts then
    6.81 -    thy
    6.82 +  if forall (fn (Const (c, _)) => Core_Data.is_registered (Proof_Context.init_global thy) c) ts
    6.83 +  then thy
    6.84    else
    6.85      let
    6.86        fun get_specs ts = map_filter (fn t =>
    6.87 @@ -94,9 +102,9 @@
    6.88        val (fun_pred_specs, thy1) =
    6.89          (if function_flattening options andalso (not (null funnames)) then
    6.90            if fail_safe_function_flattening options then
    6.91 -            case try (Predicate_Compile_Fun.define_predicates (get_specs funnames)) thy of
    6.92 +            (case try (Predicate_Compile_Fun.define_predicates (get_specs funnames)) thy of
    6.93                SOME (intross, thy) => (intross, thy)
    6.94 -            | NONE => ([], thy)
    6.95 +            | NONE => ([], thy))
    6.96            else Predicate_Compile_Fun.define_predicates (get_specs funnames) thy
    6.97          else ([], thy))
    6.98        val _ = print_specs options thy1 fun_pred_specs
    6.99 @@ -111,8 +119,9 @@
   6.100          map (fn (s, ths) => (overload_const thy2 s, map (Axclass.overload thy2) ths)) intross5
   6.101        val intross7 = map_specs (map (expand_tuples thy2)) intross6
   6.102        val intross8 = map_specs (map (eta_contract_ho_arguments thy2)) intross7
   6.103 -      val _ = case !intro_hook of NONE => () | SOME f => (map_specs (map (f thy2)) intross8; ())
   6.104 -      val _ = print_step options ("Looking for specialisations in " ^ commas (map fst intross8) ^ "...")
   6.105 +      val _ = (case !intro_hook of NONE => () | SOME f => (map_specs (map (f thy2)) intross8; ()))
   6.106 +      val _ =
   6.107 +        print_step options ("Looking for specialisations in " ^ commas (map fst intross8) ^ "...")
   6.108        val (intross9, thy3) =
   6.109          if specialise options then
   6.110            Predicate_Compile_Specialisation.find_specialisations [] intross8 thy2
   6.111 @@ -129,14 +138,17 @@
   6.112  fun preprocess options t thy =
   6.113    let
   6.114      val _ = print_step options "Fetching definitions from theory..."
   6.115 -    val gr = cond_timeit (Config.get_global thy Quickcheck.timing) "preprocess-obtain graph"
   6.116 -          (fn () => Predicate_Compile_Data.obtain_specification_graph options thy t
   6.117 +    val gr =
   6.118 +      cond_timeit (Config.get_global thy Quickcheck.timing) "preprocess-obtain graph"
   6.119 +        (fn () =>
   6.120 +          Predicate_Compile_Data.obtain_specification_graph options thy t
   6.121            |> (fn gr => Term_Graph.restrict (member (op =) (Term_Graph.all_succs gr [t])) gr))
   6.122      val _ = if !present_graph then Predicate_Compile_Data.present_graph gr else ()
   6.123    in
   6.124      cond_timeit (Config.get_global thy Quickcheck.timing) "preprocess-process"
   6.125 -      (fn () => (fold_rev (preprocess_strong_conn_constnames options gr)
   6.126 -        (Term_Graph.strong_conn gr) thy))
   6.127 +      (fn () =>
   6.128 +        fold_rev (preprocess_strong_conn_constnames options gr)
   6.129 +          (Term_Graph.strong_conn gr) thy)
   6.130    end
   6.131  
   6.132  datatype proposed_modes = Multiple_Preds of (string * (mode * string option) list) list
   6.133 @@ -145,14 +157,15 @@
   6.134  fun extract_options lthy (((expected_modes, proposed_modes), (compilation, raw_options)), const) =
   6.135    let
   6.136      fun chk s = member (op =) raw_options s
   6.137 -    val proposed_modes = case proposed_modes of
   6.138 -          Single_Pred proposed_modes => [(const, proposed_modes)]
   6.139 -        | Multiple_Preds proposed_modes => map
   6.140 -          (apfst (Code.read_const (Proof_Context.theory_of lthy))) proposed_modes
   6.141 +    val proposed_modes =
   6.142 +      (case proposed_modes of
   6.143 +        Single_Pred proposed_modes => [(const, proposed_modes)]
   6.144 +      | Multiple_Preds proposed_modes =>
   6.145 +          map (apfst (Code.read_const (Proof_Context.theory_of lthy))) proposed_modes)
   6.146    in
   6.147      Options {
   6.148        expected_modes = Option.map (pair const) expected_modes,
   6.149 -      proposed_modes = 
   6.150 +      proposed_modes =
   6.151          map (apsnd (map fst)) proposed_modes,
   6.152        proposed_names =
   6.153          maps (fn (predname, ms) => (map_filter
   6.154 @@ -190,15 +203,14 @@
   6.155        let
   6.156          val lthy' = Local_Theory.background_theory (preprocess options t) lthy
   6.157          val const =
   6.158 -          case Predicate_Compile_Fun.pred_of_function (Proof_Context.theory_of lthy') const of
   6.159 +          (case Predicate_Compile_Fun.pred_of_function (Proof_Context.theory_of lthy') const of
   6.160              SOME c => c
   6.161 -          | NONE => const
   6.162 +          | NONE => const)
   6.163          val _ = print_step options "Starting Predicate Compile Core..."
   6.164        in
   6.165          Predicate_Compile_Core.code_pred options const lthy'
   6.166        end
   6.167 -    else
   6.168 -      Predicate_Compile_Core.code_pred_cmd options raw_const lthy
   6.169 +    else Predicate_Compile_Core.code_pred_cmd options raw_const lthy
   6.170    end
   6.171  
   6.172  val setup = Predicate_Compile_Core.setup
   6.173 @@ -210,10 +222,11 @@
   6.174    (Args.$$$ "i" >> K Input || Args.$$$ "o" >> K Output ||
   6.175      Args.$$$ "bool" >> K Bool || Args.$$$ "(" |-- parse_mode_expr --| Args.$$$ ")") xs
   6.176  and parse_mode_tuple_expr xs =
   6.177 -  (parse_mode_basic_expr --| (Args.$$$ "*" || Args.$$$ "\<times>") -- parse_mode_tuple_expr >> Pair || parse_mode_basic_expr)
   6.178 -    xs
   6.179 +  (parse_mode_basic_expr --| (Args.$$$ "*" || Args.$$$ "\<times>") -- parse_mode_tuple_expr >> Pair ||
   6.180 +    parse_mode_basic_expr) xs
   6.181  and parse_mode_expr xs =
   6.182 -  (parse_mode_tuple_expr --| (Args.$$$ "=>" || Args.$$$ "\<Rightarrow>") -- parse_mode_expr >> Fun || parse_mode_tuple_expr) xs
   6.183 +  (parse_mode_tuple_expr --| (Args.$$$ "=>" || Args.$$$ "\<Rightarrow>") -- parse_mode_expr >> Fun ||
   6.184 +    parse_mode_tuple_expr) xs
   6.185  
   6.186  val mode_and_opt_proposal = parse_mode_expr --
   6.187    Scan.optional (Args.$$$ "as" |-- Parse.xname >> SOME) NONE
   6.188 @@ -230,6 +243,7 @@
   6.189    Scan.optional (@{keyword "("} |-- Args.$$$ "expected_modes" |-- @{keyword ":"} |--
   6.190      Parse.enum "," parse_mode_expr --| @{keyword ")"} >> SOME) NONE
   6.191  
   6.192 +
   6.193  (* Parser for options *)
   6.194  
   6.195  val scan_options =
   6.196 @@ -243,7 +257,7 @@
   6.197    end
   6.198  
   6.199  val opt_print_modes =
   6.200 -  Scan.optional (@{keyword "("} |-- Parse.!!! (Scan.repeat1 Parse.xname --| @{keyword ")"})) [];
   6.201 +  Scan.optional (@{keyword "("} |-- Parse.!!! (Scan.repeat1 Parse.xname --| @{keyword ")"})) []
   6.202  
   6.203  val opt_mode = (Args.$$$ "_" >> K NONE) || (parse_mode_expr >> SOME)
   6.204  
   6.205 @@ -267,6 +281,7 @@
   6.206        ((NONE, false), (Pred, []))
   6.207    end
   6.208  
   6.209 +
   6.210  (* code_pred command and values command *)
   6.211  
   6.212  val _ =
     7.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_aux.ML	Wed Feb 12 10:59:25 2014 +0100
     7.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_aux.ML	Wed Feb 12 14:32:45 2014 +0100
     7.3 @@ -90,17 +90,17 @@
     7.4    val funT_of : compilation_funs -> mode -> typ -> typ
     7.5    (* Different compilations *)
     7.6    datatype compilation = Pred | Depth_Limited | Random | Depth_Limited_Random | DSeq | Annotated
     7.7 -    | Pos_Random_DSeq | Neg_Random_DSeq | New_Pos_Random_DSeq | New_Neg_Random_DSeq 
     7.8 +    | Pos_Random_DSeq | Neg_Random_DSeq | New_Pos_Random_DSeq | New_Neg_Random_DSeq
     7.9      | Pos_Generator_DSeq | Neg_Generator_DSeq | Pos_Generator_CPS | Neg_Generator_CPS
    7.10    val negative_compilation_of : compilation -> compilation
    7.11    val compilation_for_polarity : bool -> compilation -> compilation
    7.12 -  val is_depth_limited_compilation : compilation -> bool 
    7.13 +  val is_depth_limited_compilation : compilation -> bool
    7.14    val string_of_compilation : compilation -> string
    7.15    val compilation_names : (string * compilation) list
    7.16    val non_random_compilations : compilation list
    7.17    val random_compilations : compilation list
    7.18    (* Different options for compiler *)
    7.19 -  datatype options = Options of {  
    7.20 +  datatype options = Options of {
    7.21      expected_modes : (string * mode list) option,
    7.22      proposed_modes : (string * mode list) list,
    7.23      proposed_names : ((string * mode) * string) list,
    7.24 @@ -162,10 +162,10 @@
    7.25    val unify_consts : theory -> term list -> term list -> (term list * term list)
    7.26    val mk_casesrule : Proof.context -> term -> thm list -> term
    7.27    val preprocess_intro : theory -> thm -> thm
    7.28 -  
    7.29 +
    7.30    val define_quickcheck_predicate :
    7.31      term -> theory -> (((string * typ) * (string * typ) list) * thm) * theory
    7.32 -end;
    7.33 +end
    7.34  
    7.35  structure Predicate_Compile_Aux : PREDICATE_COMPILE_AUX =
    7.36  struct
    7.37 @@ -212,7 +212,7 @@
    7.38    | mode_ord (Bool, Bool) = EQUAL
    7.39    | mode_ord (Pair (m1, m2), Pair (m3, m4)) = prod_ord mode_ord mode_ord ((m1, m2), (m3, m4))
    7.40    | mode_ord (Fun (m1, m2), Fun (m3, m4)) = prod_ord mode_ord mode_ord ((m1, m2), (m3, m4))
    7.41 - 
    7.42 +
    7.43  fun list_fun_mode [] = Bool
    7.44    | list_fun_mode (m :: ms) = Fun (m, list_fun_mode ms)
    7.45  
    7.46 @@ -228,7 +228,7 @@
    7.47  fun dest_tuple_mode (Pair (mode, mode')) = mode :: dest_tuple_mode mode'
    7.48    | dest_tuple_mode _ = []
    7.49  
    7.50 -fun all_modes_of_typ' (T as Type ("fun", _)) = 
    7.51 +fun all_modes_of_typ' (T as Type ("fun", _)) =
    7.52    let
    7.53      val (S, U) = strip_type T
    7.54    in
    7.55 @@ -238,7 +238,7 @@
    7.56      else
    7.57        [Input, Output]
    7.58    end
    7.59 -  | all_modes_of_typ' (Type (@{type_name Product_Type.prod}, [T1, T2])) = 
    7.60 +  | all_modes_of_typ' (Type (@{type_name Product_Type.prod}, [T1, T2])) =
    7.61      map_product (curry Pair) (all_modes_of_typ' T1) (all_modes_of_typ' T2)
    7.62    | all_modes_of_typ' _ = [Input, Output]
    7.63  
    7.64 @@ -259,7 +259,7 @@
    7.65  fun all_smodes_of_typ (T as Type ("fun", _)) =
    7.66    let
    7.67      val (S, U) = strip_type T
    7.68 -    fun all_smodes (Type (@{type_name Product_Type.prod}, [T1, T2])) = 
    7.69 +    fun all_smodes (Type (@{type_name Product_Type.prod}, [T1, T2])) =
    7.70        map_product (curry Pair) (all_smodes T1) (all_smodes T2)
    7.71        | all_smodes _ = [Input, Output]
    7.72    in
    7.73 @@ -292,8 +292,9 @@
    7.74  
    7.75  fun ho_args_of_typ T ts =
    7.76    let
    7.77 -    fun ho_arg (T as Type("fun", [_,_])) (SOME t) = if body_type T = @{typ bool} then [t] else []
    7.78 -      | ho_arg (Type("fun", [_,_])) NONE = raise Fail "mode and term do not match"
    7.79 +    fun ho_arg (T as Type ("fun", [_, _])) (SOME t) =
    7.80 +          if body_type T = @{typ bool} then [t] else []
    7.81 +      | ho_arg (Type ("fun", [_, _])) NONE = raise Fail "mode and term do not match"
    7.82        | ho_arg (Type(@{type_name "Product_Type.prod"}, [T1, T2]))
    7.83           (SOME (Const (@{const_name Pair}, _) $ t1 $ t2)) =
    7.84            ho_arg T1 (SOME t1) @ ho_arg T2 (SOME t2)
    7.85 @@ -307,25 +308,25 @@
    7.86  fun ho_argsT_of_typ Ts =
    7.87    let
    7.88      fun ho_arg (T as Type("fun", [_,_])) = if body_type T = @{typ bool} then [T] else []
    7.89 -      | ho_arg (Type(@{type_name "Product_Type.prod"}, [T1, T2])) =
    7.90 +      | ho_arg (Type (@{type_name "Product_Type.prod"}, [T1, T2])) =
    7.91            ho_arg T1 @ ho_arg T2
    7.92        | ho_arg _ = []
    7.93    in
    7.94      maps ho_arg Ts
    7.95    end
    7.96 -  
    7.97 +
    7.98  
    7.99  (* temporary function should be replaced by unsplit_input or so? *)
   7.100  fun replace_ho_args mode hoargs ts =
   7.101    let
   7.102      fun replace (Fun _, _) (arg' :: hoargs') = (arg', hoargs')
   7.103        | replace (Pair (m1, m2), Const (@{const_name Pair}, T) $ t1 $ t2) hoargs =
   7.104 -        let
   7.105 -          val (t1', hoargs') = replace (m1, t1) hoargs
   7.106 -          val (t2', hoargs'') = replace (m2, t2) hoargs'
   7.107 -        in
   7.108 -          (Const (@{const_name Pair}, T) $ t1' $ t2', hoargs'')
   7.109 -        end
   7.110 +          let
   7.111 +            val (t1', hoargs') = replace (m1, t1) hoargs
   7.112 +            val (t2', hoargs'') = replace (m2, t2) hoargs'
   7.113 +          in
   7.114 +            (Const (@{const_name Pair}, T) $ t1' $ t2', hoargs'')
   7.115 +          end
   7.116        | replace (_, t) hoargs = (t, hoargs)
   7.117    in
   7.118      fst (fold_map replace (strip_fun_mode mode ~~ ts) hoargs)
   7.119 @@ -334,7 +335,8 @@
   7.120  fun ho_argsT_of mode Ts =
   7.121    let
   7.122      fun ho_arg (Fun _) T = [T]
   7.123 -      | ho_arg (Pair (m1, m2)) (Type (@{type_name Product_Type.prod}, [T1, T2])) = ho_arg m1 T1 @ ho_arg m2 T2
   7.124 +      | ho_arg (Pair (m1, m2)) (Type (@{type_name Product_Type.prod}, [T1, T2])) =
   7.125 +          ho_arg m1 T1 @ ho_arg m2 T2
   7.126        | ho_arg _ _ = []
   7.127    in
   7.128      flat (map2 ho_arg (strip_fun_mode mode) Ts)
   7.129 @@ -380,28 +382,28 @@
   7.130  fun split_mode mode ts = split_map_mode (fn _ => fn _ => (NONE, NONE)) mode ts
   7.131  
   7.132  fun fold_map_aterms_prodT comb f (Type (@{type_name Product_Type.prod}, [T1, T2])) s =
   7.133 -  let
   7.134 -    val (x1, s') = fold_map_aterms_prodT comb f T1 s
   7.135 -    val (x2, s'') = fold_map_aterms_prodT comb f T2 s'
   7.136 -  in
   7.137 -    (comb x1 x2, s'')
   7.138 -  end
   7.139 -  | fold_map_aterms_prodT comb f T s = f T s
   7.140 +      let
   7.141 +        val (x1, s') = fold_map_aterms_prodT comb f T1 s
   7.142 +        val (x2, s'') = fold_map_aterms_prodT comb f T2 s'
   7.143 +      in
   7.144 +        (comb x1 x2, s'')
   7.145 +      end
   7.146 +  | fold_map_aterms_prodT _ f T s = f T s
   7.147  
   7.148  fun map_filter_prod f (Const (@{const_name Pair}, _) $ t1 $ t2) =
   7.149 -  comb_option HOLogic.mk_prod (map_filter_prod f t1, map_filter_prod f t2)
   7.150 +      comb_option HOLogic.mk_prod (map_filter_prod f t1, map_filter_prod f t2)
   7.151    | map_filter_prod f t = f t
   7.152 -  
   7.153 +
   7.154  fun split_modeT mode Ts =
   7.155    let
   7.156      fun split_arg_mode (Fun _) _ = ([], [])
   7.157        | split_arg_mode (Pair (m1, m2)) (Type (@{type_name Product_Type.prod}, [T1, T2])) =
   7.158 -        let
   7.159 -          val (i1, o1) = split_arg_mode m1 T1
   7.160 -          val (i2, o2) = split_arg_mode m2 T2
   7.161 -        in
   7.162 -          (i1 @ i2, o1 @ o2)
   7.163 -        end
   7.164 +          let
   7.165 +            val (i1, o1) = split_arg_mode m1 T1
   7.166 +            val (i2, o2) = split_arg_mode m2 T2
   7.167 +          in
   7.168 +            (i1 @ i2, o1 @ o2)
   7.169 +          end
   7.170        | split_arg_mode Input T = ([T], [])
   7.171        | split_arg_mode Output T = ([], [T])
   7.172        | split_arg_mode _ _ = raise Fail "split_modeT: mode and type do not match"
   7.173 @@ -428,7 +430,7 @@
   7.174        | ascii_string_of_mode' Bool = "b"
   7.175        | ascii_string_of_mode' (Pair (m1, m2)) =
   7.176            "P" ^ ascii_string_of_mode' m1 ^ ascii_string_of_mode'_Pair m2
   7.177 -      | ascii_string_of_mode' (Fun (m1, m2)) = 
   7.178 +      | ascii_string_of_mode' (Fun (m1, m2)) =
   7.179            "F" ^ ascii_string_of_mode' m1 ^ ascii_string_of_mode'_Fun m2 ^ "B"
   7.180      and ascii_string_of_mode'_Fun (Fun (m1, m2)) =
   7.181            ascii_string_of_mode' m1 ^ (if m2 = Bool then "" else "_" ^ ascii_string_of_mode'_Fun m2)
   7.182 @@ -439,10 +441,11 @@
   7.183        | ascii_string_of_mode'_Pair m = ascii_string_of_mode' m
   7.184    in ascii_string_of_mode'_Fun mode' end
   7.185  
   7.186 +
   7.187  (* premises *)
   7.188  
   7.189 -datatype indprem = Prem of term | Negprem of term | Sidecond of term
   7.190 -  | Generator of (string * typ);
   7.191 +datatype indprem =
   7.192 +  Prem of term | Negprem of term | Sidecond of term | Generator of (string * typ)
   7.193  
   7.194  fun dest_indprem (Prem t) = t
   7.195    | dest_indprem (Negprem t) = t
   7.196 @@ -454,25 +457,28 @@
   7.197    | map_indprem f (Sidecond t) = Sidecond (f t)
   7.198    | map_indprem f (Generator (v, T)) = Generator (dest_Free (f (Free (v, T))))
   7.199  
   7.200 +
   7.201  (* general syntactic functions *)
   7.202  
   7.203  fun is_equationlike_term (Const ("==", _) $ _ $ _) = true
   7.204 -  | is_equationlike_term (Const (@{const_name Trueprop}, _) $ (Const (@{const_name HOL.eq}, _) $ _ $ _)) = true
   7.205 +  | is_equationlike_term
   7.206 +      (Const (@{const_name Trueprop}, _) $ (Const (@{const_name HOL.eq}, _) $ _ $ _)) = true
   7.207    | is_equationlike_term _ = false
   7.208 -  
   7.209 -val is_equationlike = is_equationlike_term o prop_of 
   7.210 +
   7.211 +val is_equationlike = is_equationlike_term o prop_of
   7.212  
   7.213  fun is_pred_equation_term (Const ("==", _) $ u $ v) =
   7.214 -  (fastype_of u = @{typ bool}) andalso (fastype_of v = @{typ bool})
   7.215 +      (fastype_of u = @{typ bool}) andalso (fastype_of v = @{typ bool})
   7.216    | is_pred_equation_term _ = false
   7.217 -  
   7.218 -val is_pred_equation = is_pred_equation_term o prop_of 
   7.219 +
   7.220 +val is_pred_equation = is_pred_equation_term o prop_of
   7.221  
   7.222  fun is_intro_term constname t =
   7.223 -  the_default false (try (fn t => case fst (strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl t))) of
   7.224 -    Const (c, _) => c = constname
   7.225 -  | _ => false) t)
   7.226 -  
   7.227 +  the_default false (try (fn t =>
   7.228 +    case fst (strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl t))) of
   7.229 +      Const (c, _) => c = constname
   7.230 +    | _ => false) t)
   7.231 +
   7.232  fun is_intro constname t = is_intro_term constname (prop_of t)
   7.233  
   7.234  fun is_predT (T as Type("fun", [_, _])) = (body_type T = @{typ bool})
   7.235 @@ -494,44 +500,49 @@
   7.236  fun is_constrt thy =
   7.237    let
   7.238      val cnstrs = get_constrs thy
   7.239 -    fun check t = (case strip_comb t of
   7.240 +    fun check t =
   7.241 +      (case strip_comb t of
   7.242          (Var _, []) => true
   7.243        | (Free _, []) => true
   7.244 -      | (Const (s, T), ts) => (case (AList.lookup (op =) cnstrs s, body_type T) of
   7.245 -            (SOME (i, Tname), Type (Tname', _)) => length ts = i andalso Tname = Tname' andalso forall check ts
   7.246 +      | (Const (s, T), ts) =>
   7.247 +          (case (AList.lookup (op =) cnstrs s, body_type T) of
   7.248 +            (SOME (i, Tname), Type (Tname', _)) =>
   7.249 +              length ts = i andalso Tname = Tname' andalso forall check ts
   7.250            | _ => false)
   7.251        | _ => false)
   7.252 -  in check end;
   7.253 +  in check end
   7.254  
   7.255 -val is_constr = Code.is_constr o Proof_Context.theory_of;
   7.256 +val is_constr = Code.is_constr o Proof_Context.theory_of
   7.257  
   7.258  fun strip_all t = (Term.strip_all_vars t, Term.strip_all_body t)
   7.259  
   7.260  fun strip_ex (Const (@{const_name Ex}, _) $ Abs (x, T, t)) =
   7.261 -  let
   7.262 -    val (xTs, t') = strip_ex t
   7.263 -  in
   7.264 -    ((x, T) :: xTs, t')
   7.265 -  end
   7.266 +      let
   7.267 +        val (xTs, t') = strip_ex t
   7.268 +      in
   7.269 +        ((x, T) :: xTs, t')
   7.270 +      end
   7.271    | strip_ex t = ([], t)
   7.272  
   7.273  fun focus_ex t nctxt =
   7.274    let
   7.275 -    val ((xs, Ts), t') = apfst split_list (strip_ex t) 
   7.276 +    val ((xs, Ts), t') = apfst split_list (strip_ex t)
   7.277      val (xs', nctxt') = fold_map Name.variant xs nctxt;
   7.278      val ps' = xs' ~~ Ts;
   7.279      val vs = map Free ps';
   7.280      val t'' = Term.subst_bounds (rev vs, t');
   7.281 -  in ((ps', t''), nctxt') end;
   7.282 +  in ((ps', t''), nctxt') end
   7.283  
   7.284 -val strip_intro_concl = (strip_comb o HOLogic.dest_Trueprop o Logic.strip_imp_concl o prop_of)
   7.285 -  
   7.286 +val strip_intro_concl = strip_comb o HOLogic.dest_Trueprop o Logic.strip_imp_concl o prop_of
   7.287 +
   7.288 +
   7.289  (* introduction rule combinators *)
   7.290  
   7.291 -fun map_atoms f intro = 
   7.292 +fun map_atoms f intro =
   7.293    let
   7.294      val (literals, head) = Logic.strip_horn intro
   7.295 -    fun appl t = (case t of
   7.296 +    fun appl t =
   7.297 +      (case t of
   7.298          (@{term Not} $ t') => HOLogic.mk_not (f t')
   7.299        | _ => f t)
   7.300    in
   7.301 @@ -542,16 +553,18 @@
   7.302  fun fold_atoms f intro s =
   7.303    let
   7.304      val (literals, _) = Logic.strip_horn intro
   7.305 -    fun appl t s = (case t of
   7.306 -      (@{term Not} $ t') => f t' s
   7.307 +    fun appl t s =
   7.308 +      (case t of
   7.309 +        (@{term Not} $ t') => f t' s
   7.310        | _ => f t s)
   7.311    in fold appl (map HOLogic.dest_Trueprop literals) s end
   7.312  
   7.313  fun fold_map_atoms f intro s =
   7.314    let
   7.315      val (literals, head) = Logic.strip_horn intro
   7.316 -    fun appl t s = (case t of
   7.317 -      (@{term Not} $ t') => apfst HOLogic.mk_not (f t' s)
   7.318 +    fun appl t s =
   7.319 +      (case t of
   7.320 +        (@{term Not} $ t') => apfst HOLogic.mk_not (f t' s)
   7.321        | _ => f t s)
   7.322      val (literals', s') = fold_map appl (map HOLogic.dest_Trueprop literals) s
   7.323    in
   7.324 @@ -579,12 +592,14 @@
   7.325      Logic.list_implies (premises, f head)
   7.326    end
   7.327  
   7.328 +
   7.329  (* combinators to apply a function to all basic parts of nested products *)
   7.330  
   7.331  fun map_products f (Const (@{const_name Pair}, T) $ t1 $ t2) =
   7.332    Const (@{const_name Pair}, T) $ map_products f t1 $ map_products f t2
   7.333    | map_products f t = f t
   7.334  
   7.335 +
   7.336  (* split theorems of case expressions *)
   7.337  
   7.338  fun prepare_split_thm ctxt split_thm =
   7.339 @@ -594,7 +609,8 @@
   7.340  
   7.341  fun find_split_thm thy (Const (name, _)) =
   7.342      Option.map #split (Ctr_Sugar.ctr_sugar_of_case (Proof_Context.init_global thy) name)
   7.343 -  | find_split_thm thy _ = NONE
   7.344 +  | find_split_thm _ _ = NONE
   7.345 +
   7.346  
   7.347  (* lifting term operations to theorems *)
   7.348  
   7.349 @@ -604,10 +620,11 @@
   7.350  (*
   7.351  fun equals_conv lhs_cv rhs_cv ct =
   7.352    case Thm.term_of ct of
   7.353 -    Const ("==", _) $ _ $ _ => Conv.arg_conv cv ct  
   7.354 -  | _ => error "equals_conv"  
   7.355 +    Const ("==", _) $ _ $ _ => Conv.arg_conv cv ct
   7.356 +  | _ => error "equals_conv"
   7.357  *)
   7.358  
   7.359 +
   7.360  (* Different compilations *)
   7.361  
   7.362  datatype compilation = Pred | Depth_Limited | Random | Depth_Limited_Random | DSeq | Annotated
   7.363 @@ -621,9 +638,9 @@
   7.364    | negative_compilation_of Pos_Generator_DSeq = Neg_Generator_DSeq
   7.365    | negative_compilation_of Neg_Generator_DSeq = Pos_Generator_DSeq
   7.366    | negative_compilation_of Pos_Generator_CPS = Neg_Generator_CPS
   7.367 -  | negative_compilation_of Neg_Generator_CPS = Pos_Generator_CPS  
   7.368 +  | negative_compilation_of Neg_Generator_CPS = Pos_Generator_CPS
   7.369    | negative_compilation_of c = c
   7.370 -  
   7.371 +
   7.372  fun compilation_for_polarity false Pos_Random_DSeq = Neg_Random_DSeq
   7.373    | compilation_for_polarity false New_Pos_Random_DSeq = New_Neg_Random_DSeq
   7.374    | compilation_for_polarity _ c = c
   7.375 @@ -633,7 +650,7 @@
   7.376    (c = Pos_Generator_DSeq) orelse (c = Pos_Generator_DSeq)
   7.377  
   7.378  fun string_of_compilation c =
   7.379 -  case c of
   7.380 +  (case c of
   7.381      Pred => ""
   7.382    | Random => "random"
   7.383    | Depth_Limited => "depth limited"
   7.384 @@ -647,9 +664,10 @@
   7.385    | Pos_Generator_DSeq => "pos_generator_dseq"
   7.386    | Neg_Generator_DSeq => "neg_generator_dseq"
   7.387    | Pos_Generator_CPS => "pos_generator_cps"
   7.388 -  | Neg_Generator_CPS => "neg_generator_cps"
   7.389 -  
   7.390 -val compilation_names = [("pred", Pred),
   7.391 +  | Neg_Generator_CPS => "neg_generator_cps")
   7.392 +
   7.393 +val compilation_names =
   7.394 + [("pred", Pred),
   7.395    ("random", Random),
   7.396    ("depth_limited", Depth_Limited),
   7.397    ("depth_limited_random", Depth_Limited_Random),
   7.398 @@ -667,6 +685,7 @@
   7.399    Pos_Random_DSeq, Neg_Random_DSeq, New_Pos_Random_DSeq, New_Neg_Random_DSeq,
   7.400    Pos_Generator_CPS, Neg_Generator_CPS]
   7.401  
   7.402 +
   7.403  (* datastructures and setup for generic compilation *)
   7.404  
   7.405  datatype compilation_funs = CompilationFuns of {
   7.406 @@ -680,7 +699,7 @@
   7.407    mk_iterate_upto : typ -> term * term * term -> term,
   7.408    mk_not : term -> term,
   7.409    mk_map : typ -> typ -> term -> term -> term
   7.410 -};
   7.411 +}
   7.412  
   7.413  fun mk_monadT (CompilationFuns funs) = #mk_monadT funs
   7.414  fun dest_monadT (CompilationFuns funs) = #dest_monadT funs
   7.415 @@ -693,19 +712,22 @@
   7.416  fun mk_not (CompilationFuns funs) = #mk_not funs
   7.417  fun mk_map (CompilationFuns funs) = #mk_map funs
   7.418  
   7.419 +
   7.420  (** function types and names of different compilations **)
   7.421  
   7.422  fun funT_of compfuns mode T =
   7.423    let
   7.424      val Ts = binder_types T
   7.425 -    val (inTs, outTs) = split_map_modeT (fn m => fn T => (SOME (funT_of compfuns m T), NONE)) mode Ts
   7.426 +    val (inTs, outTs) =
   7.427 +      split_map_modeT (fn m => fn T => (SOME (funT_of compfuns m T), NONE)) mode Ts
   7.428    in
   7.429      inTs ---> (mk_monadT compfuns (HOLogic.mk_tupleT outTs))
   7.430 -  end;
   7.431 +  end
   7.432 +
   7.433  
   7.434  (* Different options for compiler *)
   7.435  
   7.436 -datatype options = Options of {  
   7.437 +datatype options = Options of {
   7.438    expected_modes : (string * mode list) option,
   7.439    proposed_modes : (string * mode list) list,
   7.440    proposed_names : ((string * mode) * string) list,
   7.441 @@ -727,7 +749,7 @@
   7.442    detect_switches : bool,
   7.443    smart_depth_limiting : bool,
   7.444    compilation : compilation
   7.445 -};
   7.446 +}
   7.447  
   7.448  fun expected_modes (Options opt) = #expected_modes opt
   7.449  fun proposed_modes (Options opt) = AList.lookup (op =) (#proposed_modes opt)
   7.450 @@ -790,33 +812,37 @@
   7.451  fun print_step options s =
   7.452    if show_steps options then tracing s else ()
   7.453  
   7.454 +
   7.455  (* simple transformations *)
   7.456  
   7.457  (** tuple processing **)
   7.458  
   7.459  fun rewrite_args [] (pats, intro_t, ctxt) = (pats, intro_t, ctxt)
   7.460 -  | rewrite_args (arg::args) (pats, intro_t, ctxt) = 
   7.461 -    (case HOLogic.strip_tupleT (fastype_of arg) of
   7.462 -      (_ :: _ :: _) =>
   7.463 -      let
   7.464 -        fun rewrite_arg' (Const (@{const_name Pair}, _) $ _ $ t2, Type (@{type_name Product_Type.prod}, [_, T2]))
   7.465 -          (args, (pats, intro_t, ctxt)) = rewrite_arg' (t2, T2) (args, (pats, intro_t, ctxt))
   7.466 -          | rewrite_arg' (t, Type (@{type_name Product_Type.prod}, [T1, T2])) (args, (pats, intro_t, ctxt)) =
   7.467 -            let
   7.468 -              val thy = Proof_Context.theory_of ctxt
   7.469 -              val ([x, y], ctxt') = Variable.variant_fixes ["x", "y"] ctxt
   7.470 -              val pat = (t, HOLogic.mk_prod (Free (x, T1), Free (y, T2)))
   7.471 -              val intro_t' = Pattern.rewrite_term thy [pat] [] intro_t
   7.472 -              val args' = map (Pattern.rewrite_term thy [pat] []) args
   7.473 -            in
   7.474 -              rewrite_arg' (Free (y, T2), T2) (args', (pat::pats, intro_t', ctxt'))
   7.475 -            end
   7.476 -          | rewrite_arg' _ (args, (pats, intro_t, ctxt)) = (args, (pats, intro_t, ctxt))
   7.477 -        val (args', (pats, intro_t', ctxt')) = rewrite_arg' (arg, fastype_of arg)
   7.478 -          (args, (pats, intro_t, ctxt))
   7.479 -      in
   7.480 -        rewrite_args args' (pats, intro_t', ctxt')
   7.481 -      end
   7.482 +  | rewrite_args (arg::args) (pats, intro_t, ctxt) =
   7.483 +      (case HOLogic.strip_tupleT (fastype_of arg) of
   7.484 +        (_ :: _ :: _) =>
   7.485 +        let
   7.486 +          fun rewrite_arg'
   7.487 +                (Const (@{const_name Pair}, _) $ _ $ t2, Type (@{type_name Product_Type.prod}, [_, T2]))
   7.488 +                (args, (pats, intro_t, ctxt)) =
   7.489 +                rewrite_arg' (t2, T2) (args, (pats, intro_t, ctxt))
   7.490 +            | rewrite_arg'
   7.491 +                (t, Type (@{type_name Product_Type.prod}, [T1, T2])) (args, (pats, intro_t, ctxt)) =
   7.492 +                let
   7.493 +                  val thy = Proof_Context.theory_of ctxt
   7.494 +                  val ([x, y], ctxt') = Variable.variant_fixes ["x", "y"] ctxt
   7.495 +                  val pat = (t, HOLogic.mk_prod (Free (x, T1), Free (y, T2)))
   7.496 +                  val intro_t' = Pattern.rewrite_term thy [pat] [] intro_t
   7.497 +                  val args' = map (Pattern.rewrite_term thy [pat] []) args
   7.498 +                in
   7.499 +                  rewrite_arg' (Free (y, T2), T2) (args', (pat::pats, intro_t', ctxt'))
   7.500 +                end
   7.501 +            | rewrite_arg' _ (args, (pats, intro_t, ctxt)) = (args, (pats, intro_t, ctxt))
   7.502 +          val (args', (pats, intro_t', ctxt')) =
   7.503 +            rewrite_arg' (arg, fastype_of arg) (args, (pats, intro_t, ctxt))
   7.504 +        in
   7.505 +          rewrite_args args' (pats, intro_t', ctxt')
   7.506 +        end
   7.507    | _ => rewrite_args args (pats, intro_t, ctxt))
   7.508  
   7.509  fun rewrite_prem atom =
   7.510 @@ -826,23 +852,24 @@
   7.511  
   7.512  fun split_conjuncts_in_assms ctxt th =
   7.513    let
   7.514 -    val ((_, [fixed_th]), ctxt') = Variable.import false [th] ctxt 
   7.515 +    val ((_, [fixed_th]), ctxt') = Variable.import false [th] ctxt
   7.516      fun split_conjs i nprems th =
   7.517        if i > nprems then th
   7.518        else
   7.519 -        case try Drule.RSN (@{thm conjI}, (i, th)) of
   7.520 -          SOME th' => split_conjs i (nprems+1) th'
   7.521 -        | NONE => split_conjs (i+1) nprems th
   7.522 +        (case try Drule.RSN (@{thm conjI}, (i, th)) of
   7.523 +          SOME th' => split_conjs i (nprems + 1) th'
   7.524 +        | NONE => split_conjs (i + 1) nprems th)
   7.525    in
   7.526 -    singleton (Variable.export ctxt' ctxt) (split_conjs 1 (Thm.nprems_of fixed_th) fixed_th)
   7.527 +    singleton (Variable.export ctxt' ctxt)
   7.528 +      (split_conjs 1 (Thm.nprems_of fixed_th) fixed_th)
   7.529    end
   7.530  
   7.531  fun dest_conjunct_prem th =
   7.532 -  case HOLogic.dest_Trueprop (prop_of th) of
   7.533 +  (case HOLogic.dest_Trueprop (prop_of th) of
   7.534      (Const (@{const_name HOL.conj}, _) $ _ $ _) =>
   7.535        dest_conjunct_prem (th RS @{thm conjunct1})
   7.536          @ dest_conjunct_prem (th RS @{thm conjunct2})
   7.537 -    | _ => [th]
   7.538 +   | _ => [th])
   7.539  
   7.540  fun expand_tuples thy intro =
   7.541    let
   7.542 @@ -869,6 +896,7 @@
   7.543      intro'''''
   7.544    end
   7.545  
   7.546 +
   7.547  (** making case distributivity rules **)
   7.548  (*** this should be part of the datatype package ***)
   7.549  
   7.550 @@ -940,12 +968,14 @@
   7.551      Raw_Simplifier.rewrite_term thy [th RS @{thm eq_reflection}] [] t
   7.552    end
   7.553  
   7.554 +
   7.555  (*** conversions ***)
   7.556  
   7.557  fun imp_prems_conv cv ct =
   7.558 -  case Thm.term_of ct of
   7.559 +  (case Thm.term_of ct of
   7.560      Const ("==>", _) $ _ $ _ => Conv.combination_conv (Conv.arg_conv cv) (imp_prems_conv cv) ct
   7.561 -  | _ => Conv.all_conv ct
   7.562 +  | _ => Conv.all_conv ct)
   7.563 +
   7.564  
   7.565  (** eta contract higher-order arguments **)
   7.566  
   7.567 @@ -956,6 +986,7 @@
   7.568      map_term thy (map_concl f o map_atoms f) intro
   7.569    end
   7.570  
   7.571 +
   7.572  (** remove equalities **)
   7.573  
   7.574  fun remove_equalities thy intro =
   7.575 @@ -966,26 +997,27 @@
   7.576          fun remove_eq (prems, concl) =
   7.577            let
   7.578              fun removable_eq prem =
   7.579 -              case try (HOLogic.dest_eq o HOLogic.dest_Trueprop) prem of
   7.580 -                SOME (lhs, rhs) => (case lhs of
   7.581 -                  Var _ => true
   7.582 +              (case try (HOLogic.dest_eq o HOLogic.dest_Trueprop) prem of
   7.583 +                SOME (lhs, rhs) =>
   7.584 +                  (case lhs of
   7.585 +                    Var _ => true
   7.586                    | _ => (case rhs of Var _ => true | _ => false))
   7.587 -              | NONE => false
   7.588 +              | NONE => false)
   7.589            in
   7.590 -            case find_first removable_eq prems of
   7.591 +            (case find_first removable_eq prems of
   7.592                NONE => (prems, concl)
   7.593              | SOME eq =>
   7.594 -              let
   7.595 -                val (lhs, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop eq)
   7.596 -                val prems' = remove (op =) eq prems
   7.597 -                val subst = (case lhs of
   7.598 -                  (v as Var _) =>
   7.599 -                    (fn t => if t = v then rhs else t)
   7.600 -                | _ => (case rhs of
   7.601 -                   (v as Var _) => (fn t => if t = v then lhs else t)))
   7.602 -              in
   7.603 -                remove_eq (map (map_aterms subst) prems', map_aterms subst concl)
   7.604 -              end
   7.605 +                let
   7.606 +                  val (lhs, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop eq)
   7.607 +                  val prems' = remove (op =) eq prems
   7.608 +                  val subst =
   7.609 +                    (case lhs of
   7.610 +                      (v as Var _) =>
   7.611 +                        (fn t => if t = v then rhs else t)
   7.612 +                    | _ => (case rhs of (v as Var _) => (fn t => if t = v then lhs else t)))
   7.613 +                in
   7.614 +                  remove_eq (map (map_aterms subst) prems', map_aterms subst concl)
   7.615 +                end)
   7.616            end
   7.617        in
   7.618          Logic.list_implies (remove_eq (prems, concl))
   7.619 @@ -994,6 +1026,7 @@
   7.620      map_term thy remove_eqs intro
   7.621    end
   7.622  
   7.623 +
   7.624  (* Some last processing *)
   7.625  
   7.626  fun remove_pointless_clauses intro =
   7.627 @@ -1001,6 +1034,7 @@
   7.628      []
   7.629    else [intro]
   7.630  
   7.631 +
   7.632  (* some peephole optimisations *)
   7.633  
   7.634  fun peephole_optimisation thy intro =
   7.635 @@ -1009,7 +1043,8 @@
   7.636      val process =
   7.637        rewrite_rule ctxt (Predicate_Compile_Simps.get ctxt)
   7.638      fun process_False intro_t =
   7.639 -      if member (op =) (Logic.strip_imp_prems intro_t) @{prop "False"} then NONE else SOME intro_t
   7.640 +      if member (op =) (Logic.strip_imp_prems intro_t) @{prop "False"}
   7.641 +      then NONE else SOME intro_t
   7.642      fun process_True intro_t =
   7.643        map_filter_premises (fn p => if p = @{prop True} then NONE else SOME p) intro_t
   7.644    in
   7.645 @@ -1021,60 +1056,65 @@
   7.646  (* importing introduction rules *)
   7.647  
   7.648  fun import_intros inp_pred [] ctxt =
   7.649 -  let
   7.650 -    val ([outp_pred], ctxt') = Variable.import_terms true [inp_pred] ctxt
   7.651 -    val T = fastype_of outp_pred
   7.652 -    val paramTs = ho_argsT_of_typ (binder_types T)
   7.653 -    val (param_names, _) = Variable.variant_fixes
   7.654 -      (map (fn i => "p" ^ (string_of_int i)) (1 upto (length paramTs))) ctxt'
   7.655 -    val params = map2 (curry Free) param_names paramTs
   7.656 -  in
   7.657 -    (((outp_pred, params), []), ctxt')
   7.658 -  end
   7.659 +      let
   7.660 +        val ([outp_pred], ctxt') = Variable.import_terms true [inp_pred] ctxt
   7.661 +        val T = fastype_of outp_pred
   7.662 +        val paramTs = ho_argsT_of_typ (binder_types T)
   7.663 +        val (param_names, _) = Variable.variant_fixes
   7.664 +          (map (fn i => "p" ^ (string_of_int i)) (1 upto (length paramTs))) ctxt'
   7.665 +        val params = map2 (curry Free) param_names paramTs
   7.666 +      in
   7.667 +        (((outp_pred, params), []), ctxt')
   7.668 +      end
   7.669    | import_intros inp_pred (th :: ths) ctxt =
   7.670 -    let
   7.671 -      val ((_, [th']), ctxt') = Variable.import true [th] ctxt
   7.672 -      val thy = Proof_Context.theory_of ctxt'
   7.673 -      val (pred, args) = strip_intro_concl th'
   7.674 -      val T = fastype_of pred
   7.675 -      val ho_args = ho_args_of_typ T args
   7.676 -      fun subst_of (pred', pred) =
   7.677 -        let
   7.678 -          val subst = Sign.typ_match thy (fastype_of pred', fastype_of pred) Vartab.empty
   7.679 -            handle Type.TYPE_MATCH => error ("Type mismatch of predicate " ^ fst (dest_Const pred)
   7.680 -            ^ " (trying to match " ^ Syntax.string_of_typ ctxt (fastype_of pred')
   7.681 -            ^ " and " ^ Syntax.string_of_typ ctxt (fastype_of pred) ^ ")"
   7.682 -            ^ " in " ^ Display.string_of_thm ctxt th)
   7.683 -        in map (fn (indexname, (s, T)) => ((indexname, s), T)) (Vartab.dest subst) end
   7.684 -      fun instantiate_typ th =
   7.685 -        let
   7.686 -          val (pred', _) = strip_intro_concl th
   7.687 -          val _ = if not (fst (dest_Const pred) = fst (dest_Const pred')) then
   7.688 -            raise Fail "Trying to instantiate another predicate" else ()
   7.689 -        in Thm.certify_instantiate (subst_of (pred', pred), []) th end;
   7.690 -      fun instantiate_ho_args th =
   7.691 -        let
   7.692 -          val (_, args') = (strip_comb o HOLogic.dest_Trueprop o Logic.strip_imp_concl o prop_of) th
   7.693 -          val ho_args' = map dest_Var (ho_args_of_typ T args')
   7.694 -        in Thm.certify_instantiate ([], ho_args' ~~ ho_args) th end
   7.695 -      val outp_pred =
   7.696 -        Term_Subst.instantiate (subst_of (inp_pred, pred), []) inp_pred
   7.697 -      val ((_, ths'), ctxt1) =
   7.698 -        Variable.import false (map (instantiate_typ #> instantiate_ho_args) ths) ctxt'
   7.699 -    in
   7.700 -      (((outp_pred, ho_args), th' :: ths'), ctxt1)
   7.701 -    end
   7.702 -  
   7.703 +      let
   7.704 +        val ((_, [th']), ctxt') = Variable.import true [th] ctxt
   7.705 +        val thy = Proof_Context.theory_of ctxt'
   7.706 +        val (pred, args) = strip_intro_concl th'
   7.707 +        val T = fastype_of pred
   7.708 +        val ho_args = ho_args_of_typ T args
   7.709 +        fun subst_of (pred', pred) =
   7.710 +          let
   7.711 +            val subst = Sign.typ_match thy (fastype_of pred', fastype_of pred) Vartab.empty
   7.712 +              handle Type.TYPE_MATCH =>
   7.713 +                error ("Type mismatch of predicate " ^ fst (dest_Const pred) ^
   7.714 +                  " (trying to match " ^ Syntax.string_of_typ ctxt (fastype_of pred') ^
   7.715 +                  " and " ^ Syntax.string_of_typ ctxt (fastype_of pred) ^ ")" ^
   7.716 +                  " in " ^ Display.string_of_thm ctxt th)
   7.717 +          in map (fn (indexname, (s, T)) => ((indexname, s), T)) (Vartab.dest subst) end
   7.718 +        fun instantiate_typ th =
   7.719 +          let
   7.720 +            val (pred', _) = strip_intro_concl th
   7.721 +            val _ =
   7.722 +              if not (fst (dest_Const pred) = fst (dest_Const pred')) then
   7.723 +                raise Fail "Trying to instantiate another predicate"
   7.724 +              else ()
   7.725 +          in Thm.certify_instantiate (subst_of (pred', pred), []) th end
   7.726 +        fun instantiate_ho_args th =
   7.727 +          let
   7.728 +            val (_, args') =
   7.729 +              (strip_comb o HOLogic.dest_Trueprop o Logic.strip_imp_concl o prop_of) th
   7.730 +            val ho_args' = map dest_Var (ho_args_of_typ T args')
   7.731 +          in Thm.certify_instantiate ([], ho_args' ~~ ho_args) th end
   7.732 +        val outp_pred =
   7.733 +          Term_Subst.instantiate (subst_of (inp_pred, pred), []) inp_pred
   7.734 +        val ((_, ths'), ctxt1) =
   7.735 +          Variable.import false (map (instantiate_typ #> instantiate_ho_args) ths) ctxt'
   7.736 +      in
   7.737 +        (((outp_pred, ho_args), th' :: ths'), ctxt1)
   7.738 +      end
   7.739 +
   7.740 +
   7.741  (* generation of case rules from user-given introduction rules *)
   7.742  
   7.743  fun mk_args2 (Type (@{type_name Product_Type.prod}, [T1, T2])) st =
   7.744 -    let
   7.745 -      val (t1, st') = mk_args2 T1 st
   7.746 -      val (t2, st'') = mk_args2 T2 st'
   7.747 -    in
   7.748 -      (HOLogic.mk_prod (t1, t2), st'')
   7.749 -    end
   7.750 -  (*| mk_args2 (T as Type ("fun", _)) (params, ctxt) = 
   7.751 +      let
   7.752 +        val (t1, st') = mk_args2 T1 st
   7.753 +        val (t2, st'') = mk_args2 T2 st'
   7.754 +      in
   7.755 +        (HOLogic.mk_prod (t1, t2), st'')
   7.756 +      end
   7.757 +  (*| mk_args2 (T as Type ("fun", _)) (params, ctxt) =
   7.758      let
   7.759        val (S, U) = strip_type T
   7.760      in
   7.761 @@ -1088,11 +1128,11 @@
   7.762          end
   7.763      end*)
   7.764    | mk_args2 T (params, ctxt) =
   7.765 -    let
   7.766 -      val ([x], ctxt') = Variable.variant_fixes ["x"] ctxt
   7.767 -    in
   7.768 -      (Free (x, T), (params, ctxt'))
   7.769 -    end
   7.770 +      let
   7.771 +        val ([x], ctxt') = Variable.variant_fixes ["x"] ctxt
   7.772 +      in
   7.773 +        (Free (x, T), (params, ctxt'))
   7.774 +      end
   7.775  
   7.776  fun mk_casesrule ctxt pred introrules =
   7.777    let
   7.778 @@ -1117,28 +1157,29 @@
   7.779      val assm = HOLogic.mk_Trueprop (list_comb (pred, argvs))
   7.780      val cases = map mk_case intros
   7.781    in Logic.list_implies (assm :: cases, prop) end;
   7.782 -  
   7.783 +
   7.784  
   7.785  (* unifying constants to have the same type variables *)
   7.786  
   7.787  fun unify_consts thy cs intr_ts =
   7.788 -  (let
   7.789 +  let
   7.790       val add_term_consts_2 = fold_aterms (fn Const c => insert (op =) c | _ => I);
   7.791       fun varify (t, (i, ts)) =
   7.792         let val t' = map_types (Logic.incr_tvar (i + 1)) (#2 (Type.varify_global [] t))
   7.793 -       in (maxidx_of_term t', t'::ts) end;
   7.794 -     val (i, cs') = List.foldr varify (~1, []) cs;
   7.795 -     val (i', intr_ts') = List.foldr varify (i, []) intr_ts;
   7.796 -     val rec_consts = fold add_term_consts_2 cs' [];
   7.797 -     val intr_consts = fold add_term_consts_2 intr_ts' [];
   7.798 +       in (maxidx_of_term t', t' :: ts) end
   7.799 +     val (i, cs') = List.foldr varify (~1, []) cs
   7.800 +     val (i', intr_ts') = List.foldr varify (i, []) intr_ts
   7.801 +     val rec_consts = fold add_term_consts_2 cs' []
   7.802 +     val intr_consts = fold add_term_consts_2 intr_ts' []
   7.803       fun unify (cname, cT) =
   7.804         let val consts = map snd (filter (fn c => fst c = cname) intr_consts)
   7.805 -       in fold (Sign.typ_unify thy) ((replicate (length consts) cT) ~~ consts) end;
   7.806 -     val (env, _) = fold unify rec_consts (Vartab.empty, i');
   7.807 +       in fold (Sign.typ_unify thy) ((replicate (length consts) cT) ~~ consts) end
   7.808 +     val (env, _) = fold unify rec_consts (Vartab.empty, i')
   7.809       val subst = map_types (Envir.norm_type env)
   7.810     in (map subst cs', map subst intr_ts')
   7.811 -   end) handle Type.TUNIFY =>
   7.812 -     (warning "Occurrences of recursive constant have non-unifiable types"; (cs, intr_ts));
   7.813 +   end handle Type.TUNIFY =>
   7.814 +     (warning "Occurrences of recursive constant have non-unifiable types"; (cs, intr_ts))
   7.815 +
   7.816  
   7.817  (* preprocessing rules *)
   7.818  
   7.819 @@ -1151,6 +1192,7 @@
   7.820  
   7.821  fun preprocess_intro thy = expand_tuples thy #> preprocess_equality thy
   7.822  
   7.823 +
   7.824  (* defining a quickcheck predicate *)
   7.825  
   7.826  fun strip_imp_prems (Const(@{const_name HOL.implies}, _) $ A $ B) = A :: strip_imp_prems B
   7.827 @@ -1159,7 +1201,7 @@
   7.828  fun strip_imp_concl (Const(@{const_name HOL.implies}, _) $ _ $ B) = strip_imp_concl B
   7.829    | strip_imp_concl A = A;
   7.830  
   7.831 -fun strip_horn A = (strip_imp_prems A, strip_imp_concl A);
   7.832 +fun strip_horn A = (strip_imp_prems A, strip_imp_concl A)
   7.833  
   7.834  fun define_quickcheck_predicate t thy =
   7.835    let
   7.836 @@ -1172,9 +1214,10 @@
   7.837      val constT = map snd vs' ---> @{typ bool}
   7.838      val thy1 = Sign.add_consts_i [(Binding.name constname, constT, NoSyn)] thy
   7.839      val const = Const (full_constname, constT)
   7.840 -    val t = Logic.list_implies
   7.841 -      (map HOLogic.mk_Trueprop (prems @ [HOLogic.mk_not concl]),
   7.842 -       HOLogic.mk_Trueprop (list_comb (const, map Free vs')))
   7.843 +    val t =
   7.844 +      Logic.list_implies
   7.845 +        (map HOLogic.mk_Trueprop (prems @ [HOLogic.mk_not concl]),
   7.846 +          HOLogic.mk_Trueprop (list_comb (const, map Free vs')))
   7.847      val intro =
   7.848        Goal.prove (Proof_Context.init_global thy1) (map fst vs') [] t
   7.849          (fn _ => ALLGOALS Skip_Proof.cheat_tac)
   7.850 @@ -1182,4 +1225,4 @@
   7.851      ((((full_constname, constT), vs'), intro), thy1)
   7.852    end
   7.853  
   7.854 -end;
   7.855 +end
     8.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_compilations.ML	Wed Feb 12 10:59:25 2014 +0100
     8.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_compilations.ML	Wed Feb 12 14:32:45 2014 +0100
     8.3 @@ -4,30 +4,30 @@
     8.4  Structures for different compilations of the predicate compiler.
     8.5  *)
     8.6  
     8.7 -structure Predicate_Comp_Funs =
     8.8 +structure Predicate_Comp_Funs =  (* FIXME proper signature *)
     8.9  struct
    8.10  
    8.11  fun mk_monadT T = Type (@{type_name Predicate.pred}, [T])
    8.12  
    8.13  fun dest_monadT (Type (@{type_name Predicate.pred}, [T])) = T
    8.14 -  | dest_monadT T = raise TYPE ("dest_monadT", [T], []);
    8.15 +  | dest_monadT T = raise TYPE ("dest_monadT", [T], [])
    8.16  
    8.17 -fun mk_empty T = Const (@{const_name Orderings.bot}, mk_monadT T);
    8.18 +fun mk_empty T = Const (@{const_name Orderings.bot}, mk_monadT T)
    8.19  
    8.20  fun mk_single t =
    8.21    let val T = fastype_of t
    8.22 -  in Const(@{const_name Predicate.single}, T --> mk_monadT T) $ t end;
    8.23 +  in Const(@{const_name Predicate.single}, T --> mk_monadT T) $ t end
    8.24  
    8.25  fun mk_bind (x, f) =
    8.26    let val T as Type ("fun", [_, U]) = fastype_of f
    8.27    in
    8.28      Const (@{const_name Predicate.bind}, fastype_of x --> T --> U) $ x $ f
    8.29 -  end;
    8.30 +  end
    8.31  
    8.32 -val mk_plus = HOLogic.mk_binop @{const_name sup};
    8.33 +val mk_plus = HOLogic.mk_binop @{const_name sup}
    8.34  
    8.35  fun mk_if cond = Const (@{const_name Predicate.if_pred},
    8.36 -  HOLogic.boolT --> mk_monadT HOLogic.unitT) $ cond;
    8.37 +  HOLogic.boolT --> mk_monadT HOLogic.unitT) $ cond
    8.38  
    8.39  fun mk_iterate_upto T (f, from, to) =
    8.40    list_comb (Const (@{const_name Predicate.iterate_upto},
    8.41 @@ -50,44 +50,48 @@
    8.42      val T = dest_monadT (fastype_of f)
    8.43    in
    8.44      Const (@{const_name Predicate.eval}, mk_monadT T --> T --> HOLogic.boolT) $ f $ x
    8.45 -  end;
    8.46 +  end
    8.47  
    8.48  fun dest_Eval (Const (@{const_name Predicate.eval}, _) $ f $ x) = (f, x)
    8.49  
    8.50  fun mk_map T1 T2 tf tp = Const (@{const_name Predicate.map},
    8.51 -  (T1 --> T2) --> mk_monadT T1 --> mk_monadT T2) $ tf $ tp;
    8.52 +  (T1 --> T2) --> mk_monadT T1 --> mk_monadT T2) $ tf $ tp
    8.53  
    8.54 -val compfuns = Predicate_Compile_Aux.CompilationFuns
    8.55 +val compfuns =
    8.56 +  Predicate_Compile_Aux.CompilationFuns
    8.57      {mk_monadT = mk_monadT, dest_monadT = dest_monadT, mk_empty = mk_empty,
    8.58      mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
    8.59 -    mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map};
    8.60 +    mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
    8.61  
    8.62 -end;
    8.63 +end
    8.64  
    8.65 -structure CPS_Comp_Funs =
    8.66 +
    8.67 +structure CPS_Comp_Funs =  (* FIXME proper signature *)
    8.68  struct
    8.69  
    8.70 -fun mk_monadT T = (T --> @{typ "Code_Evaluation.term list option"}) --> @{typ "Code_Evaluation.term list option"}
    8.71 +fun mk_monadT T =
    8.72 +  (T --> @{typ "Code_Evaluation.term list option"}) --> @{typ "Code_Evaluation.term list option"}
    8.73  
    8.74 -fun dest_monadT (Type ("fun", [Type ("fun", [T, @{typ "term list option"}]), @{typ "term list option"}])) = T
    8.75 +fun dest_monadT
    8.76 +      (Type ("fun", [Type ("fun", [T, @{typ "term list option"}]), @{typ "term list option"}])) = T
    8.77    | dest_monadT T = raise TYPE ("dest_monadT", [T], []);
    8.78  
    8.79 -fun mk_empty T = Const (@{const_name Quickcheck_Exhaustive.cps_empty}, mk_monadT T);
    8.80 +fun mk_empty T = Const (@{const_name Quickcheck_Exhaustive.cps_empty}, mk_monadT T)
    8.81  
    8.82  fun mk_single t =
    8.83    let val T = fastype_of t
    8.84 -  in Const(@{const_name Quickcheck_Exhaustive.cps_single}, T --> mk_monadT T) $ t end;
    8.85 +  in Const(@{const_name Quickcheck_Exhaustive.cps_single}, T --> mk_monadT T) $ t end
    8.86  
    8.87  fun mk_bind (x, f) =
    8.88    let val T as Type ("fun", [_, U]) = fastype_of f
    8.89    in
    8.90      Const (@{const_name Quickcheck_Exhaustive.cps_bind}, fastype_of x --> T --> U) $ x $ f
    8.91 -  end;
    8.92 +  end
    8.93  
    8.94 -val mk_plus = HOLogic.mk_binop @{const_name Quickcheck_Exhaustive.cps_plus};
    8.95 +val mk_plus = HOLogic.mk_binop @{const_name Quickcheck_Exhaustive.cps_plus}
    8.96  
    8.97  fun mk_if cond = Const (@{const_name Quickcheck_Exhaustive.cps_if},
    8.98 -  HOLogic.boolT --> mk_monadT HOLogic.unitT) $ cond;
    8.99 +  HOLogic.boolT --> mk_monadT HOLogic.unitT) $ cond
   8.100  
   8.101  fun mk_iterate_upto _ _ = error "not implemented yet"
   8.102  
   8.103 @@ -104,14 +108,16 @@
   8.104  
   8.105  fun mk_map _ _ _ _ = error "not implemented"
   8.106  
   8.107 -val compfuns = Predicate_Compile_Aux.CompilationFuns
   8.108 +val compfuns =
   8.109 +  Predicate_Compile_Aux.CompilationFuns
   8.110      {mk_monadT = mk_monadT, dest_monadT = dest_monadT, mk_empty = mk_empty,
   8.111      mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   8.112      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map};
   8.113  
   8.114 -end;
   8.115 +end
   8.116  
   8.117 -structure Pos_Bounded_CPS_Comp_Funs =
   8.118 +
   8.119 +structure Pos_Bounded_CPS_Comp_Funs =  (* FIXME proper signature *)
   8.120  struct
   8.121  
   8.122  val resultT = @{typ "(bool * Code_Evaluation.term list) option"}
   8.123 @@ -119,13 +125,13 @@
   8.124  
   8.125  fun dest_monadT (Type ("fun", [Type ("fun", [T, @{typ "(bool * term list) option"}]),
   8.126    @{typ "natural => (bool * term list) option"}])) = T
   8.127 -  | dest_monadT T = raise TYPE ("dest_monadT", [T], []);
   8.128 +  | dest_monadT T = raise TYPE ("dest_monadT", [T], [])
   8.129  
   8.130 -fun mk_empty T = Const (@{const_name Quickcheck_Exhaustive.pos_bound_cps_empty}, mk_monadT T);
   8.131 +fun mk_empty T = Const (@{const_name Quickcheck_Exhaustive.pos_bound_cps_empty}, mk_monadT T)
   8.132  
   8.133  fun mk_single t =
   8.134    let val T = fastype_of t
   8.135 -  in Const(@{const_name Quickcheck_Exhaustive.pos_bound_cps_single}, T --> mk_monadT T) $ t end;
   8.136 +  in Const(@{const_name Quickcheck_Exhaustive.pos_bound_cps_single}, T --> mk_monadT T) $ t end
   8.137  
   8.138  fun mk_bind (x, f) =
   8.139    let val T as Type ("fun", [_, U]) = fastype_of f
   8.140 @@ -133,10 +139,11 @@
   8.141      Const (@{const_name Quickcheck_Exhaustive.pos_bound_cps_bind}, fastype_of x --> T --> U) $ x $ f
   8.142    end;
   8.143  
   8.144 -val mk_plus = HOLogic.mk_binop @{const_name Quickcheck_Exhaustive.pos_bound_cps_plus};
   8.145 +val mk_plus = HOLogic.mk_binop @{const_name Quickcheck_Exhaustive.pos_bound_cps_plus}
   8.146  
   8.147 -fun mk_if cond = Const (@{const_name Quickcheck_Exhaustive.pos_bound_cps_if},
   8.148 -  HOLogic.boolT --> mk_monadT HOLogic.unitT) $ cond;
   8.149 +fun mk_if cond =
   8.150 +  Const (@{const_name Quickcheck_Exhaustive.pos_bound_cps_if},
   8.151 +    HOLogic.boolT --> mk_monadT HOLogic.unitT) $ cond
   8.152  
   8.153  fun mk_iterate_upto _ _ = error "not implemented yet"
   8.154  
   8.155 @@ -156,14 +163,16 @@
   8.156  
   8.157  fun mk_map _ _ _ _ = error "not implemented"
   8.158  
   8.159 -val compfuns = Predicate_Compile_Aux.CompilationFuns
   8.160 +val compfuns =
   8.161 +  Predicate_Compile_Aux.CompilationFuns
   8.162      {mk_monadT = mk_monadT, dest_monadT = dest_monadT, mk_empty = mk_empty,
   8.163      mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   8.164      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map};
   8.165  
   8.166 -end;
   8.167 +end
   8.168  
   8.169 -structure Neg_Bounded_CPS_Comp_Funs =
   8.170 +
   8.171 +structure Neg_Bounded_CPS_Comp_Funs =  (* FIXME proper signature *)
   8.172  struct
   8.173  
   8.174  fun mk_monadT T =
   8.175 @@ -171,16 +180,17 @@
   8.176      --> @{typ "Code_Evaluation.term list Quickcheck_Exhaustive.three_valued"})
   8.177      --> @{typ "natural => Code_Evaluation.term list Quickcheck_Exhaustive.three_valued"}
   8.178  
   8.179 -fun dest_monadT (Type ("fun", [Type ("fun", [Type (@{type_name "Quickcheck_Exhaustive.unknown"}, [T]),
   8.180 -    @{typ "term list Quickcheck_Exhaustive.three_valued"}]),
   8.181 -    @{typ "natural => term list Quickcheck_Exhaustive.three_valued"}])) = T
   8.182 +fun dest_monadT
   8.183 +    (Type ("fun", [Type ("fun", [Type (@{type_name "Quickcheck_Exhaustive.unknown"}, [T]),
   8.184 +      @{typ "term list Quickcheck_Exhaustive.three_valued"}]),
   8.185 +      @{typ "natural => term list Quickcheck_Exhaustive.three_valued"}])) = T
   8.186    | dest_monadT T = raise TYPE ("dest_monadT", [T], []);
   8.187  
   8.188 -fun mk_empty T = Const (@{const_name Quickcheck_Exhaustive.neg_bound_cps_empty}, mk_monadT T);
   8.189 +fun mk_empty T = Const (@{const_name Quickcheck_Exhaustive.neg_bound_cps_empty}, mk_monadT T)
   8.190  
   8.191  fun mk_single t =
   8.192    let val T = fastype_of t
   8.193 -  in Const(@{const_name Quickcheck_Exhaustive.neg_bound_cps_single}, T --> mk_monadT T) $ t end;
   8.194 +  in Const(@{const_name Quickcheck_Exhaustive.neg_bound_cps_single}, T --> mk_monadT T) $ t end
   8.195  
   8.196  fun mk_bind (x, f) =
   8.197    let val T as Type ("fun", [_, U]) = fastype_of f
   8.198 @@ -188,10 +198,10 @@
   8.199      Const (@{const_name Quickcheck_Exhaustive.neg_bound_cps_bind}, fastype_of x --> T --> U) $ x $ f
   8.200    end;
   8.201  
   8.202 -val mk_plus = HOLogic.mk_binop @{const_name Quickcheck_Exhaustive.neg_bound_cps_plus};
   8.203 +val mk_plus = HOLogic.mk_binop @{const_name Quickcheck_Exhaustive.neg_bound_cps_plus}
   8.204  
   8.205  fun mk_if cond = Const (@{const_name Quickcheck_Exhaustive.neg_bound_cps_if},
   8.206 -  HOLogic.boolT --> mk_monadT HOLogic.unitT) $ cond;
   8.207 +  HOLogic.boolT --> mk_monadT HOLogic.unitT) $ cond
   8.208  
   8.209  fun mk_iterate_upto _ _ = error "not implemented"
   8.210  
   8.211 @@ -210,7 +220,8 @@
   8.212  
   8.213  fun mk_map _ _ _ _  = error "not implemented"
   8.214  
   8.215 -val compfuns = Predicate_Compile_Aux.CompilationFuns
   8.216 +val compfuns =
   8.217 +  Predicate_Compile_Aux.CompilationFuns
   8.218      {mk_monadT = mk_monadT, dest_monadT = dest_monadT, mk_empty = mk_empty,
   8.219      mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   8.220      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map};
   8.221 @@ -218,7 +229,7 @@
   8.222  end;
   8.223  
   8.224  
   8.225 -structure RandomPredCompFuns =
   8.226 +structure RandomPredCompFuns =  (* FIXME proper signature *)
   8.227  struct
   8.228  
   8.229  fun mk_randompredT T =
   8.230 @@ -226,7 +237,7 @@
   8.231  
   8.232  fun dest_randompredT (Type ("fun", [@{typ Random.seed}, Type (@{type_name Product_Type.prod},
   8.233    [Type (@{type_name Predicate.pred}, [T]), @{typ Random.seed}])])) = T
   8.234 -  | dest_randompredT T = raise TYPE ("dest_randompredT", [T], []);
   8.235 +  | dest_randompredT T = raise TYPE ("dest_randompredT", [T], [])
   8.236  
   8.237  fun mk_empty T = Const(@{const_name Random_Pred.empty}, mk_randompredT T)
   8.238  
   8.239 @@ -235,7 +246,7 @@
   8.240      val T = fastype_of t
   8.241    in
   8.242      Const (@{const_name Random_Pred.single}, T --> mk_randompredT T) $ t
   8.243 -  end;
   8.244 +  end
   8.245  
   8.246  fun mk_bind (x, f) =
   8.247    let
   8.248 @@ -262,14 +273,16 @@
   8.249  fun mk_map T1 T2 tf tp = Const (@{const_name Random_Pred.map},
   8.250    (T1 --> T2) --> mk_randompredT T1 --> mk_randompredT T2) $ tf $ tp
   8.251  
   8.252 -val compfuns = Predicate_Compile_Aux.CompilationFuns
   8.253 +val compfuns =
   8.254 +  Predicate_Compile_Aux.CompilationFuns
   8.255      {mk_monadT = mk_randompredT, dest_monadT = dest_randompredT,
   8.256      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   8.257      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map};
   8.258  
   8.259 -end;
   8.260 +end
   8.261  
   8.262 -structure DSequence_CompFuns =
   8.263 +
   8.264 +structure DSequence_CompFuns =  (* FIXME proper signature *)
   8.265  struct
   8.266  
   8.267  fun mk_dseqT T = Type ("fun", [@{typ natural}, Type ("fun", [@{typ bool},
   8.268 @@ -304,48 +317,51 @@
   8.269  fun mk_map T1 T2 tf tp = Const (@{const_name Limited_Sequence.map},
   8.270    (T1 --> T2) --> mk_dseqT T1 --> mk_dseqT T2) $ tf $ tp
   8.271  
   8.272 -val compfuns = Predicate_Compile_Aux.CompilationFuns
   8.273 +val compfuns =
   8.274 +  Predicate_Compile_Aux.CompilationFuns
   8.275      {mk_monadT = mk_dseqT, dest_monadT = dest_dseqT,
   8.276      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   8.277      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   8.278  
   8.279  end;
   8.280  
   8.281 -structure New_Pos_DSequence_CompFuns =
   8.282 +
   8.283 +structure New_Pos_DSequence_CompFuns =  (* FIXME proper signature *)
   8.284  struct
   8.285  
   8.286  fun mk_pos_dseqT T =
   8.287 -    @{typ natural} --> Type (@{type_name Lazy_Sequence.lazy_sequence}, [T])
   8.288 +  @{typ natural} --> Type (@{type_name Lazy_Sequence.lazy_sequence}, [T])
   8.289  
   8.290 -fun dest_pos_dseqT (Type ("fun", [@{typ natural},
   8.291 -    Type (@{type_name Lazy_Sequence.lazy_sequence}, [T])])) = T
   8.292 -  | dest_pos_dseqT T = raise TYPE ("dest_pos_dseqT", [T], []);
   8.293 +fun dest_pos_dseqT
   8.294 +      (Type ("fun", [@{typ natural}, Type (@{type_name Lazy_Sequence.lazy_sequence}, [T])])) = T
   8.295 +  | dest_pos_dseqT T = raise TYPE ("dest_pos_dseqT", [T], [])
   8.296  
   8.297 -fun mk_empty T = Const (@{const_name Limited_Sequence.pos_empty}, mk_pos_dseqT T);
   8.298 +fun mk_empty T = Const (@{const_name Limited_Sequence.pos_empty}, mk_pos_dseqT T)
   8.299  
   8.300  fun mk_single t =
   8.301    let
   8.302      val T = fastype_of t
   8.303 -  in Const(@{const_name Limited_Sequence.pos_single}, T --> mk_pos_dseqT T) $ t end;
   8.304 +  in Const(@{const_name Limited_Sequence.pos_single}, T --> mk_pos_dseqT T) $ t end
   8.305  
   8.306  fun mk_bind (x, f) =
   8.307    let
   8.308      val T as Type ("fun", [_, U]) = fastype_of f
   8.309    in
   8.310      Const (@{const_name Limited_Sequence.pos_bind}, fastype_of x --> T --> U) $ x $ f
   8.311 -  end;
   8.312 +  end
   8.313    
   8.314  fun mk_decr_bind (x, f) =
   8.315    let
   8.316      val T as Type ("fun", [_, U]) = fastype_of f
   8.317    in
   8.318      Const (@{const_name Limited_Sequence.pos_decr_bind}, fastype_of x --> T --> U) $ x $ f
   8.319 -  end;
   8.320 +  end
   8.321 +
   8.322 +val mk_plus = HOLogic.mk_binop @{const_name Limited_Sequence.pos_union}
   8.323  
   8.324 -val mk_plus = HOLogic.mk_binop @{const_name Limited_Sequence.pos_union};
   8.325 -
   8.326 -fun mk_if cond = Const (@{const_name Limited_Sequence.pos_if_seq},
   8.327 -  HOLogic.boolT --> mk_pos_dseqT HOLogic.unitT) $ cond;
   8.328 +fun mk_if cond =
   8.329 +  Const (@{const_name Limited_Sequence.pos_if_seq},
   8.330 +    HOLogic.boolT --> mk_pos_dseqT HOLogic.unitT) $ cond
   8.331  
   8.332  fun mk_iterate_upto _ _ = raise Fail "No iterate_upto compilation"
   8.333  
   8.334 @@ -357,56 +373,63 @@
   8.335          [Type (@{type_name Option.option}, [@{typ unit}])])
   8.336    in Const (@{const_name Limited_Sequence.pos_not_seq}, nT --> pT) $ t end
   8.337  
   8.338 -fun mk_map T1 T2 tf tp = Const (@{const_name Limited_Sequence.pos_map},
   8.339 -  (T1 --> T2) --> mk_pos_dseqT T1 --> mk_pos_dseqT T2) $ tf $ tp
   8.340 +fun mk_map T1 T2 tf tp =
   8.341 +  Const (@{const_name Limited_Sequence.pos_map},
   8.342 +    (T1 --> T2) --> mk_pos_dseqT T1 --> mk_pos_dseqT T2) $ tf $ tp
   8.343  
   8.344 -val depth_limited_compfuns = Predicate_Compile_Aux.CompilationFuns
   8.345 +val depth_limited_compfuns =
   8.346 +  Predicate_Compile_Aux.CompilationFuns
   8.347      {mk_monadT = mk_pos_dseqT, dest_monadT = dest_pos_dseqT,
   8.348      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_decr_bind, mk_plus = mk_plus, mk_if = mk_if,
   8.349      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   8.350  
   8.351 -val depth_unlimited_compfuns = Predicate_Compile_Aux.CompilationFuns
   8.352 +val depth_unlimited_compfuns =
   8.353 +  Predicate_Compile_Aux.CompilationFuns
   8.354      {mk_monadT = mk_pos_dseqT, dest_monadT = dest_pos_dseqT,
   8.355      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   8.356      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   8.357  
   8.358 -end;
   8.359 +end
   8.360  
   8.361 -structure New_Neg_DSequence_CompFuns =
   8.362 +
   8.363 +structure New_Neg_DSequence_CompFuns =  (* FIXME proper signature *)
   8.364  struct
   8.365  
   8.366  fun mk_neg_dseqT T = @{typ natural} -->
   8.367    Type (@{type_name Lazy_Sequence.lazy_sequence}, [Type (@{type_name Option.option}, [T])])
   8.368  
   8.369 -fun dest_neg_dseqT (Type ("fun", [@{typ natural},
   8.370 -    Type (@{type_name Lazy_Sequence.lazy_sequence}, [Type (@{type_name Option.option}, [T])])])) = T
   8.371 -  | dest_neg_dseqT T = raise TYPE ("dest_neg_dseqT", [T], []);
   8.372 +fun dest_neg_dseqT
   8.373 +    (Type ("fun", [@{typ natural},
   8.374 +      Type (@{type_name Lazy_Sequence.lazy_sequence}, [Type (@{type_name Option.option}, [T])])])) =
   8.375 +      T
   8.376 +  | dest_neg_dseqT T = raise TYPE ("dest_neg_dseqT", [T], [])
   8.377  
   8.378 -fun mk_empty T = Const (@{const_name Limited_Sequence.neg_empty}, mk_neg_dseqT T);
   8.379 +fun mk_empty T = Const (@{const_name Limited_Sequence.neg_empty}, mk_neg_dseqT T)
   8.380  
   8.381  fun mk_single t =
   8.382    let
   8.383      val T = fastype_of t
   8.384 -  in Const(@{const_name Limited_Sequence.neg_single}, T --> mk_neg_dseqT T) $ t end;
   8.385 +  in Const(@{const_name Limited_Sequence.neg_single}, T --> mk_neg_dseqT T) $ t end
   8.386  
   8.387  fun mk_bind (x, f) =
   8.388    let
   8.389      val T as Type ("fun", [_, U]) = fastype_of f
   8.390    in
   8.391      Const (@{const_name Limited_Sequence.neg_bind}, fastype_of x --> T --> U) $ x $ f
   8.392 -  end;
   8.393 +  end
   8.394    
   8.395  fun mk_decr_bind (x, f) =
   8.396    let
   8.397      val T as Type ("fun", [_, U]) = fastype_of f
   8.398    in
   8.399      Const (@{const_name Limited_Sequence.neg_decr_bind}, fastype_of x --> T --> U) $ x $ f
   8.400 -  end;
   8.401 +  end
   8.402 +
   8.403 +val mk_plus = HOLogic.mk_binop @{const_name Limited_Sequence.neg_union}
   8.404  
   8.405 -val mk_plus = HOLogic.mk_binop @{const_name Limited_Sequence.neg_union};
   8.406 -
   8.407 -fun mk_if cond = Const (@{const_name Limited_Sequence.neg_if_seq},
   8.408 -  HOLogic.boolT --> mk_neg_dseqT HOLogic.unitT) $ cond;
   8.409 +fun mk_if cond =
   8.410 +  Const (@{const_name Limited_Sequence.neg_if_seq},
   8.411 +    HOLogic.boolT --> mk_neg_dseqT HOLogic.unitT) $ cond
   8.412  
   8.413  fun mk_iterate_upto _ _ = raise Fail "No iterate_upto compilation"
   8.414  
   8.415 @@ -418,53 +441,58 @@
   8.416          [@{typ unit}])
   8.417    in Const (@{const_name Limited_Sequence.neg_not_seq}, pT --> nT) $ t end
   8.418  
   8.419 -fun mk_map T1 T2 tf tp = Const (@{const_name Limited_Sequence.neg_map},
   8.420 -  (T1 --> T2) --> mk_neg_dseqT T1 --> mk_neg_dseqT T2) $ tf $ tp
   8.421 +fun mk_map T1 T2 tf tp =
   8.422 +  Const (@{const_name Limited_Sequence.neg_map},
   8.423 +    (T1 --> T2) --> mk_neg_dseqT T1 --> mk_neg_dseqT T2) $ tf $ tp
   8.424  
   8.425 -val depth_limited_compfuns = Predicate_Compile_Aux.CompilationFuns
   8.426 +val depth_limited_compfuns =
   8.427 +  Predicate_Compile_Aux.CompilationFuns
   8.428      {mk_monadT = mk_neg_dseqT, dest_monadT = dest_neg_dseqT,
   8.429      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_decr_bind, mk_plus = mk_plus, mk_if = mk_if,
   8.430      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   8.431  
   8.432 -val depth_unlimited_compfuns = Predicate_Compile_Aux.CompilationFuns
   8.433 +val depth_unlimited_compfuns =
   8.434 +  Predicate_Compile_Aux.CompilationFuns
   8.435      {mk_monadT = mk_neg_dseqT, dest_monadT = dest_neg_dseqT,
   8.436      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   8.437      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   8.438  
   8.439 -end;
   8.440 +end
   8.441  
   8.442 -structure New_Pos_Random_Sequence_CompFuns =
   8.443 +
   8.444 +structure New_Pos_Random_Sequence_CompFuns =  (* FIXME proper signature *)
   8.445  struct
   8.446  
   8.447  fun mk_pos_random_dseqT T =
   8.448    @{typ natural} --> @{typ natural} --> @{typ Random.seed} -->
   8.449      @{typ natural} --> Type (@{type_name Lazy_Sequence.lazy_sequence}, [T])
   8.450  
   8.451 -fun dest_pos_random_dseqT (Type ("fun", [@{typ natural}, Type ("fun", [@{typ natural},
   8.452 -    Type ("fun", [@{typ Random.seed}, Type ("fun", [@{typ natural},
   8.453 -    Type (@{type_name Lazy_Sequence.lazy_sequence}, [T])])])])])) = T
   8.454 -  | dest_pos_random_dseqT T = raise TYPE ("dest_random_dseqT", [T], []);
   8.455 +fun dest_pos_random_dseqT
   8.456 +    (Type ("fun", [@{typ natural}, Type ("fun", [@{typ natural},
   8.457 +      Type ("fun", [@{typ Random.seed}, Type ("fun", [@{typ natural},
   8.458 +      Type (@{type_name Lazy_Sequence.lazy_sequence}, [T])])])])])) = T
   8.459 +  | dest_pos_random_dseqT T = raise TYPE ("dest_random_dseqT", [T], [])
   8.460  
   8.461 -fun mk_empty T = Const (@{const_name Random_Sequence.pos_empty}, mk_pos_random_dseqT T);
   8.462 +fun mk_empty T = Const (@{const_name Random_Sequence.pos_empty}, mk_pos_random_dseqT T)
   8.463  
   8.464  fun mk_single t =
   8.465    let
   8.466      val T = fastype_of t
   8.467 -  in Const(@{const_name Random_Sequence.pos_single}, T --> mk_pos_random_dseqT T) $ t end;
   8.468 +  in Const(@{const_name Random_Sequence.pos_single}, T --> mk_pos_random_dseqT T) $ t end
   8.469  
   8.470  fun mk_bind (x, f) =
   8.471    let
   8.472      val T as Type ("fun", [_, U]) = fastype_of f
   8.473    in
   8.474      Const (@{const_name Random_Sequence.pos_bind}, fastype_of x --> T --> U) $ x $ f
   8.475 -  end;
   8.476 +  end
   8.477  
   8.478  fun mk_decr_bind (x, f) =
   8.479    let
   8.480      val T as Type ("fun", [_, U]) = fastype_of f
   8.481    in
   8.482      Const (@{const_name Random_Sequence.pos_decr_bind}, fastype_of x --> T --> U) $ x $ f
   8.483 -  end;
   8.484 +  end
   8.485  
   8.486  val mk_plus = HOLogic.mk_binop @{const_name Random_Sequence.pos_union};
   8.487  
   8.488 @@ -486,59 +514,66 @@
   8.489  
   8.490    in Const (@{const_name Random_Sequence.pos_not_random_dseq}, nT --> pT) $ t end
   8.491  
   8.492 -fun mk_map T1 T2 tf tp = Const (@{const_name Random_Sequence.pos_map},
   8.493 -  (T1 --> T2) --> mk_pos_random_dseqT T1 --> mk_pos_random_dseqT T2) $ tf $ tp
   8.494 +fun mk_map T1 T2 tf tp =
   8.495 +  Const (@{const_name Random_Sequence.pos_map},
   8.496 +    (T1 --> T2) --> mk_pos_random_dseqT T1 --> mk_pos_random_dseqT T2) $ tf $ tp
   8.497  
   8.498 -val depth_limited_compfuns = Predicate_Compile_Aux.CompilationFuns
   8.499 +val depth_limited_compfuns =
   8.500 +  Predicate_Compile_Aux.CompilationFuns
   8.501      {mk_monadT = mk_pos_random_dseqT, dest_monadT = dest_pos_random_dseqT,
   8.502      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_decr_bind, mk_plus = mk_plus, mk_if = mk_if,
   8.503      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   8.504  
   8.505 -val depth_unlimited_compfuns = Predicate_Compile_Aux.CompilationFuns
   8.506 +val depth_unlimited_compfuns =
   8.507 +  Predicate_Compile_Aux.CompilationFuns
   8.508      {mk_monadT = mk_pos_random_dseqT, dest_monadT = dest_pos_random_dseqT,
   8.509      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   8.510      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   8.511 +
   8.512  end;
   8.513  
   8.514 -structure New_Neg_Random_Sequence_CompFuns =
   8.515 +
   8.516 +structure New_Neg_Random_Sequence_CompFuns =  (* FIXME proper signature *)
   8.517  struct
   8.518  
   8.519  fun mk_neg_random_dseqT T =
   8.520 -   @{typ natural} --> @{typ natural} --> @{typ Random.seed} -->
   8.521 +  @{typ natural} --> @{typ natural} --> @{typ Random.seed} -->
   8.522      @{typ natural} --> 
   8.523      Type (@{type_name Lazy_Sequence.lazy_sequence}, [Type (@{type_name Option.option}, [T])])
   8.524  
   8.525 -fun dest_neg_random_dseqT (Type ("fun", [@{typ natural}, Type ("fun", [@{typ natural},
   8.526 -    Type ("fun", [@{typ Random.seed}, Type ("fun", [@{typ natural},
   8.527 -      Type (@{type_name Lazy_Sequence.lazy_sequence},
   8.528 -        [Type (@{type_name Option.option}, [T])])])])])])) = T
   8.529 -  | dest_neg_random_dseqT T = raise TYPE ("dest_random_dseqT", [T], []);
   8.530 +fun dest_neg_random_dseqT
   8.531 +    (Type ("fun", [@{typ natural}, Type ("fun", [@{typ natural},
   8.532 +      Type ("fun", [@{typ Random.seed}, Type ("fun", [@{typ natural},
   8.533 +        Type (@{type_name Lazy_Sequence.lazy_sequence},
   8.534 +          [Type (@{type_name Option.option}, [T])])])])])])) = T
   8.535 +  | dest_neg_random_dseqT T = raise TYPE ("dest_random_dseqT", [T], [])
   8.536  
   8.537 -fun mk_empty T = Const (@{const_name Random_Sequence.neg_empty}, mk_neg_random_dseqT T);
   8.538 +fun mk_empty T = Const (@{const_name Random_Sequence.neg_empty}, mk_neg_random_dseqT T)
   8.539  
   8.540  fun mk_single t =
   8.541    let
   8.542      val T = fastype_of t
   8.543 -  in Const(@{const_name Random_Sequence.neg_single}, T --> mk_neg_random_dseqT T) $ t end;
   8.544 +  in Const(@{const_name Random_Sequence.neg_single}, T --> mk_neg_random_dseqT T) $ t end
   8.545  
   8.546  fun mk_bind (x, f) =
   8.547    let
   8.548      val T as Type ("fun", [_, U]) = fastype_of f
   8.549    in
   8.550      Const (@{const_name Random_Sequence.neg_bind}, fastype_of x --> T --> U) $ x $ f
   8.551 -  end;
   8.552 +  end
   8.553  
   8.554  fun mk_decr_bind (x, f) =
   8.555    let
   8.556      val T as Type ("fun", [_, U]) = fastype_of f
   8.557    in
   8.558      Const (@{const_name Random_Sequence.neg_decr_bind}, fastype_of x --> T --> U) $ x $ f
   8.559 -  end;
   8.560 +  end
   8.561 +
   8.562 +val mk_plus = HOLogic.mk_binop @{const_name Random_Sequence.neg_union}
   8.563  
   8.564 -val mk_plus = HOLogic.mk_binop @{const_name Random_Sequence.neg_union};
   8.565 -
   8.566 -fun mk_if cond = Const (@{const_name Random_Sequence.neg_if_random_dseq},
   8.567 -  HOLogic.boolT --> mk_neg_random_dseqT HOLogic.unitT) $ cond;
   8.568 +fun mk_if cond =
   8.569 +  Const (@{const_name Random_Sequence.neg_if_random_dseq},
   8.570 +    HOLogic.boolT --> mk_neg_random_dseqT HOLogic.unitT) $ cond
   8.571  
   8.572  fun mk_iterate_upto T (f, from, to) =
   8.573    list_comb (Const (@{const_name Random_Sequence.neg_iterate_upto},
   8.574 @@ -553,51 +588,58 @@
   8.575      @{typ natural} --> Type (@{type_name Lazy_Sequence.lazy_sequence}, [@{typ unit}])
   8.576    in Const (@{const_name Random_Sequence.neg_not_random_dseq}, pT --> nT) $ t end
   8.577  
   8.578 -fun mk_map T1 T2 tf tp = Const (@{const_name Random_Sequence.neg_map},
   8.579 -  (T1 --> T2) --> mk_neg_random_dseqT T1 --> mk_neg_random_dseqT T2) $ tf $ tp
   8.580 +fun mk_map T1 T2 tf tp =
   8.581 +  Const (@{const_name Random_Sequence.neg_map},
   8.582 +    (T1 --> T2) --> mk_neg_random_dseqT T1 --> mk_neg_random_dseqT T2) $ tf $ tp
   8.583  
   8.584 -val depth_limited_compfuns = Predicate_Compile_Aux.CompilationFuns
   8.585 +val depth_limited_compfuns =
   8.586 +  Predicate_Compile_Aux.CompilationFuns
   8.587      {mk_monadT = mk_neg_random_dseqT, dest_monadT = dest_neg_random_dseqT,
   8.588      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_decr_bind, mk_plus = mk_plus, mk_if = mk_if,
   8.589      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   8.590  
   8.591 -val depth_unlimited_compfuns = Predicate_Compile_Aux.CompilationFuns
   8.592 +val depth_unlimited_compfuns =
   8.593 +  Predicate_Compile_Aux.CompilationFuns
   8.594      {mk_monadT = mk_neg_random_dseqT, dest_monadT = dest_neg_random_dseqT,
   8.595      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   8.596      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   8.597  
   8.598 -end;
   8.599 +end
   8.600  
   8.601 -structure Random_Sequence_CompFuns =
   8.602 +
   8.603 +structure Random_Sequence_CompFuns =  (* FIXME proper signature *)
   8.604  struct
   8.605  
   8.606  fun mk_random_dseqT T =
   8.607    @{typ natural} --> @{typ natural} --> @{typ Random.seed} -->
   8.608      HOLogic.mk_prodT (DSequence_CompFuns.mk_dseqT T, @{typ Random.seed})
   8.609  
   8.610 -fun dest_random_dseqT (Type ("fun", [@{typ natural}, Type ("fun", [@{typ natural},
   8.611 -  Type ("fun", [@{typ Random.seed},
   8.612 -  Type (@{type_name Product_Type.prod}, [T, @{typ Random.seed}])])])])) = DSequence_CompFuns.dest_dseqT T
   8.613 -  | dest_random_dseqT T = raise TYPE ("dest_random_dseqT", [T], []);
   8.614 +fun dest_random_dseqT
   8.615 +    (Type ("fun", [@{typ natural}, Type ("fun", [@{typ natural},
   8.616 +      Type ("fun", [@{typ Random.seed},
   8.617 +      Type (@{type_name Product_Type.prod}, [T, @{typ Random.seed}])])])])) =
   8.618 +      DSequence_CompFuns.dest_dseqT T
   8.619 +  | dest_random_dseqT T = raise TYPE ("dest_random_dseqT", [T], [])
   8.620  
   8.621 -fun mk_empty T = Const (@{const_name Random_Sequence.empty}, mk_random_dseqT T);
   8.622 +fun mk_empty T = Const (@{const_name Random_Sequence.empty}, mk_random_dseqT T)
   8.623  
   8.624  fun mk_single t =
   8.625    let
   8.626      val T = fastype_of t
   8.627 -  in Const(@{const_name Random_Sequence.single}, T --> mk_random_dseqT T) $ t end;
   8.628 +  in Const(@{const_name Random_Sequence.single}, T --> mk_random_dseqT T) $ t end
   8.629  
   8.630  fun mk_bind (x, f) =
   8.631    let
   8.632      val T as Type ("fun", [_, U]) = fastype_of f
   8.633    in
   8.634      Const (@{const_name Random_Sequence.bind}, fastype_of x --> T --> U) $ x $ f
   8.635 -  end;
   8.636 +  end
   8.637 +
   8.638 +val mk_plus = HOLogic.mk_binop @{const_name Random_Sequence.union}
   8.639  
   8.640 -val mk_plus = HOLogic.mk_binop @{const_name Random_Sequence.union};
   8.641 -
   8.642 -fun mk_if cond = Const (@{const_name Random_Sequence.if_random_dseq},
   8.643 -  HOLogic.boolT --> mk_random_dseqT HOLogic.unitT) $ cond;
   8.644 +fun mk_if cond =
   8.645 +  Const (@{const_name Random_Sequence.if_random_dseq},
   8.646 +    HOLogic.boolT --> mk_random_dseqT HOLogic.unitT) $ cond
   8.647  
   8.648  fun mk_iterate_upto _ _ = raise Fail "No iterate_upto compilation"
   8.649  
   8.650 @@ -609,10 +651,11 @@
   8.651  fun mk_map T1 T2 tf tp = Const (@{const_name Random_Sequence.map},
   8.652    (T1 --> T2) --> mk_random_dseqT T1 --> mk_random_dseqT T2) $ tf $ tp
   8.653  
   8.654 -val compfuns = Predicate_Compile_Aux.CompilationFuns
   8.655 +val compfuns =
   8.656 +  Predicate_Compile_Aux.CompilationFuns
   8.657      {mk_monadT = mk_random_dseqT, dest_monadT = dest_random_dseqT,
   8.658      mk_empty = mk_empty, mk_single = mk_single, mk_bind = mk_bind, mk_plus = mk_plus, mk_if = mk_if,
   8.659      mk_iterate_upto = mk_iterate_upto, mk_not = mk_not, mk_map = mk_map}
   8.660  
   8.661 -end;
   8.662 +end
   8.663  
     9.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML	Wed Feb 12 10:59:25 2014 +0100
     9.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML	Wed Feb 12 14:32:45 2014 +0100
     9.3 @@ -11,15 +11,15 @@
     9.4    type options = Predicate_Compile_Aux.options
     9.5    type compilation = Predicate_Compile_Aux.compilation
     9.6    type compilation_funs = Predicate_Compile_Aux.compilation_funs
     9.7 -  
     9.8 +
     9.9    val setup : theory -> theory
    9.10    val code_pred : options -> string -> Proof.context -> Proof.state
    9.11    val code_pred_cmd : options -> string -> Proof.context -> Proof.state
    9.12 -  val values_cmd : string list -> mode option list option
    9.13 -    -> ((string option * bool) * (compilation * int list)) -> int -> string -> Toplevel.state -> unit
    9.14 +  val values_cmd : string list -> mode option list option ->
    9.15 +    ((string option * bool) * (compilation * int list)) -> int -> string -> Toplevel.state -> unit
    9.16  
    9.17    val values_timeout : real Config.T
    9.18 -  
    9.19 +
    9.20    val print_stored_rules : Proof.context -> unit
    9.21    val print_all_modes : compilation -> Proof.context -> unit
    9.22  
    9.23 @@ -27,19 +27,23 @@
    9.24    val put_pred_random_result : (unit -> seed -> term Predicate.pred * seed) ->
    9.25      Proof.context -> Proof.context
    9.26    val put_dseq_result : (unit -> term Limited_Sequence.dseq) -> Proof.context -> Proof.context
    9.27 -  val put_dseq_random_result : (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> term Limited_Sequence.dseq * seed) ->
    9.28 +  val put_dseq_random_result :
    9.29 +    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed ->
    9.30 +      term Limited_Sequence.dseq * seed) ->
    9.31      Proof.context -> Proof.context
    9.32    val put_new_dseq_result : (unit -> Code_Numeral.natural -> term Lazy_Sequence.lazy_sequence) ->
    9.33      Proof.context -> Proof.context
    9.34    val put_lseq_random_result :
    9.35 -    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural -> term Lazy_Sequence.lazy_sequence) ->
    9.36 +    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural ->
    9.37 +      term Lazy_Sequence.lazy_sequence) ->
    9.38      Proof.context -> Proof.context
    9.39    val put_lseq_random_stats_result :
    9.40 -    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural -> (term * Code_Numeral.natural) Lazy_Sequence.lazy_sequence) ->
    9.41 +    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural ->
    9.42 +      (term * Code_Numeral.natural) Lazy_Sequence.lazy_sequence) ->
    9.43      Proof.context -> Proof.context
    9.44  
    9.45    val code_pred_intro_attrib : attribute
    9.46 -  (* used by Quickcheck_Generator *) 
    9.47 +  (* used by Quickcheck_Generator *)
    9.48    (* temporary for testing of the compilation *)
    9.49    val add_equations : options -> string list -> theory -> theory
    9.50    val add_depth_limited_random_equations : options -> string list -> theory -> theory
    9.51 @@ -54,7 +58,7 @@
    9.52    type mode_analysis_options =
    9.53     {use_generators : bool,
    9.54      reorder_premises : bool,
    9.55 -    infer_pos_and_neg_modes : bool}  
    9.56 +    infer_pos_and_neg_modes : bool}
    9.57    datatype mode_derivation = Mode_App of mode_derivation * mode_derivation | Context of mode
    9.58      | Mode_Pair of mode_derivation * mode_derivation | Term of mode
    9.59    val head_mode_of : mode_derivation -> mode
    9.60 @@ -90,12 +94,14 @@
    9.61    Const(@{const_name Code_Evaluation.tracing},
    9.62      @{typ String.literal} --> (fastype_of t) --> (fastype_of t)) $ (HOLogic.mk_literal s) $ t
    9.63  
    9.64 +
    9.65  (* representation of inferred clauses with modes *)
    9.66  
    9.67  type moded_clause = term list * (indprem * mode_derivation) list
    9.68  
    9.69  type 'a pred_mode_table = (string * ((bool * mode) * 'a) list) list
    9.70  
    9.71 +
    9.72  (* diagnostic display functions *)
    9.73  
    9.74  fun print_modes options modes =
    9.75 @@ -152,50 +158,53 @@
    9.76  (* validity checks *)
    9.77  
    9.78  fun check_expected_modes options _ modes =
    9.79 -  case expected_modes options of
    9.80 -    SOME (s, ms) => (case AList.lookup (op =) modes s of
    9.81 -      SOME modes =>
    9.82 -        let
    9.83 -          val modes' = map snd modes
    9.84 -        in
    9.85 -          if not (eq_set eq_mode (ms, modes')) then
    9.86 -            error ("expected modes were not inferred:\n"
    9.87 -            ^ "  inferred modes for " ^ s ^ ": " ^ commas (map string_of_mode modes')  ^ "\n"
    9.88 -            ^ "  expected modes for " ^ s ^ ": " ^ commas (map string_of_mode ms))
    9.89 -          else ()
    9.90 -        end
    9.91 -      | NONE => ())
    9.92 -  | NONE => ()
    9.93 +  (case expected_modes options of
    9.94 +    SOME (s, ms) =>
    9.95 +      (case AList.lookup (op =) modes s of
    9.96 +        SOME modes =>
    9.97 +          let
    9.98 +            val modes' = map snd modes
    9.99 +          in
   9.100 +            if not (eq_set eq_mode (ms, modes')) then
   9.101 +              error ("expected modes were not inferred:\n"
   9.102 +              ^ "  inferred modes for " ^ s ^ ": " ^ commas (map string_of_mode modes')  ^ "\n"
   9.103 +              ^ "  expected modes for " ^ s ^ ": " ^ commas (map string_of_mode ms))
   9.104 +            else ()
   9.105 +          end
   9.106 +        | NONE => ())
   9.107 +  | NONE => ())
   9.108  
   9.109  fun check_proposed_modes options preds modes errors =
   9.110 -  map (fn (s, _) => case proposed_modes options s of
   9.111 -    SOME ms => (case AList.lookup (op =) modes s of
   9.112 -      SOME inferred_ms =>
   9.113 -        let
   9.114 -          val preds_without_modes = map fst (filter (null o snd) modes)
   9.115 -          val modes' = map snd inferred_ms
   9.116 -        in
   9.117 -          if not (eq_set eq_mode (ms, modes')) then
   9.118 -            error ("expected modes were not inferred:\n"
   9.119 -            ^ "  inferred modes for " ^ s ^ ": " ^ commas (map string_of_mode modes')  ^ "\n"
   9.120 -            ^ "  expected modes for " ^ s ^ ": " ^ commas (map string_of_mode ms) ^ "\n"
   9.121 -            ^ (if show_invalid_clauses options then
   9.122 -            ("For the following clauses, the following modes could not be inferred: " ^ "\n"
   9.123 -            ^ cat_lines errors) else "") ^
   9.124 -            (if not (null preds_without_modes) then
   9.125 -              "\n" ^ "No mode inferred for the predicates " ^ commas preds_without_modes
   9.126 -            else ""))
   9.127 -          else ()
   9.128 -        end
   9.129 -      | NONE => ())
   9.130 -  | NONE => ()) preds
   9.131 +  map (fn (s, _) =>
   9.132 +    case proposed_modes options s of
   9.133 +      SOME ms =>
   9.134 +        (case AList.lookup (op =) modes s of
   9.135 +          SOME inferred_ms =>
   9.136 +            let
   9.137 +              val preds_without_modes = map fst (filter (null o snd) modes)
   9.138 +              val modes' = map snd inferred_ms
   9.139 +            in
   9.140 +              if not (eq_set eq_mode (ms, modes')) then
   9.141 +                error ("expected modes were not inferred:\n"
   9.142 +                ^ "  inferred modes for " ^ s ^ ": " ^ commas (map string_of_mode modes')  ^ "\n"
   9.143 +                ^ "  expected modes for " ^ s ^ ": " ^ commas (map string_of_mode ms) ^ "\n"
   9.144 +                ^ (if show_invalid_clauses options then
   9.145 +                ("For the following clauses, the following modes could not be inferred: " ^ "\n"
   9.146 +                ^ cat_lines errors) else "") ^
   9.147 +                (if not (null preds_without_modes) then
   9.148 +                  "\n" ^ "No mode inferred for the predicates " ^ commas preds_without_modes
   9.149 +                else ""))
   9.150 +              else ()
   9.151 +            end
   9.152 +        | NONE => ())
   9.153 +    | NONE => ()) preds
   9.154  
   9.155  fun check_matches_type ctxt predname T ms =
   9.156    let
   9.157      fun check (Fun (m1, m2)) (Type("fun", [T1,T2])) = check m1 T1 andalso check m2 T2
   9.158        | check m (Type("fun", _)) = (m = Input orelse m = Output)
   9.159        | check (Pair (m1, m2)) (Type (@{type_name Product_Type.prod}, [T1, T2])) =
   9.160 -          check m1 T1 andalso check m2 T2 
   9.161 +          check m1 T1 andalso check m2 T2
   9.162        | check Input _ = true
   9.163        | check Output _ = true
   9.164        | check Bool @{typ bool} = true
   9.165 @@ -203,30 +212,32 @@
   9.166      fun check_consistent_modes ms =
   9.167        if forall (fn Fun _ => true | _ => false) ms then
   9.168          pairself check_consistent_modes (split_list (map (fn Fun (m1, m2) => (m1, m2)) ms))
   9.169 -        |> (fn (res1, res2) => res1 andalso res2) 
   9.170 +        |> (fn (res1, res2) => res1 andalso res2)
   9.171        else if forall (fn Input => true | Output => true | Pair _ => true | _ => false) ms then
   9.172          true
   9.173        else if forall (fn Bool => true | _ => false) ms then
   9.174          true
   9.175        else
   9.176          false
   9.177 -    val _ = map
   9.178 -      (fn mode =>
   9.179 +    val _ =
   9.180 +      map (fn mode =>
   9.181          if length (strip_fun_mode mode) = length (binder_types T)
   9.182            andalso (forall (uncurry check) (strip_fun_mode mode ~~ binder_types T)) then ()
   9.183 -        else error (string_of_mode mode ^ " is not a valid mode for " ^ Syntax.string_of_typ ctxt T
   9.184 -        ^ " at predicate " ^ predname)) ms
   9.185 +        else
   9.186 +          error (string_of_mode mode ^ " is not a valid mode for " ^
   9.187 +            Syntax.string_of_typ ctxt T ^ " at predicate " ^ predname)) ms
   9.188      val _ =
   9.189 -     if check_consistent_modes ms then ()
   9.190 -     else error (commas (map string_of_mode ms) ^
   9.191 -       " are inconsistent modes for predicate " ^ predname)
   9.192 +      if check_consistent_modes ms then ()
   9.193 +      else
   9.194 +        error (commas (map string_of_mode ms) ^ " are inconsistent modes for predicate " ^ predname)
   9.195    in
   9.196      ms
   9.197    end
   9.198  
   9.199 +
   9.200  (* compilation modifiers *)
   9.201  
   9.202 -structure Comp_Mod =
   9.203 +structure Comp_Mod =  (* FIXME proper signature *)
   9.204  struct
   9.205  
   9.206  datatype comp_modifiers = Comp_Modifiers of
   9.207 @@ -263,29 +274,29 @@
   9.208      additional_arguments = additional_arguments, wrap_compilation = wrap_compilation,
   9.209      transform_additional_arguments = transform_additional_arguments})
   9.210  
   9.211 -end;
   9.212 +end
   9.213  
   9.214  fun unlimited_compfuns_of true New_Pos_Random_DSeq =
   9.215 -    New_Pos_Random_Sequence_CompFuns.depth_unlimited_compfuns
   9.216 +      New_Pos_Random_Sequence_CompFuns.depth_unlimited_compfuns
   9.217    | unlimited_compfuns_of false New_Pos_Random_DSeq =
   9.218 -    New_Neg_Random_Sequence_CompFuns.depth_unlimited_compfuns
   9.219 +      New_Neg_Random_Sequence_CompFuns.depth_unlimited_compfuns
   9.220    | unlimited_compfuns_of true Pos_Generator_DSeq =
   9.221 -    New_Pos_DSequence_CompFuns.depth_unlimited_compfuns
   9.222 +      New_Pos_DSequence_CompFuns.depth_unlimited_compfuns
   9.223    | unlimited_compfuns_of false Pos_Generator_DSeq =
   9.224 -    New_Neg_DSequence_CompFuns.depth_unlimited_compfuns
   9.225 +      New_Neg_DSequence_CompFuns.depth_unlimited_compfuns
   9.226    | unlimited_compfuns_of _ c =
   9.227 -    raise Fail ("No unlimited compfuns for compilation " ^ string_of_compilation c)
   9.228 +      raise Fail ("No unlimited compfuns for compilation " ^ string_of_compilation c)
   9.229  
   9.230  fun limited_compfuns_of true Predicate_Compile_Aux.New_Pos_Random_DSeq =
   9.231 -    New_Pos_Random_Sequence_CompFuns.depth_limited_compfuns
   9.232 +      New_Pos_Random_Sequence_CompFuns.depth_limited_compfuns
   9.233    | limited_compfuns_of false Predicate_Compile_Aux.New_Pos_Random_DSeq =
   9.234 -    New_Neg_Random_Sequence_CompFuns.depth_limited_compfuns
   9.235 +      New_Neg_Random_Sequence_CompFuns.depth_limited_compfuns
   9.236    | limited_compfuns_of true Pos_Generator_DSeq =
   9.237 -    New_Pos_DSequence_CompFuns.depth_limited_compfuns
   9.238 +      New_Pos_DSequence_CompFuns.depth_limited_compfuns
   9.239    | limited_compfuns_of false Pos_Generator_DSeq =
   9.240 -    New_Neg_DSequence_CompFuns.depth_limited_compfuns
   9.241 +      New_Neg_DSequence_CompFuns.depth_limited_compfuns
   9.242    | limited_compfuns_of _ c =
   9.243 -    raise Fail ("No limited compfuns for compilation " ^ string_of_compilation c)
   9.244 +      raise Fail ("No limited compfuns for compilation " ^ string_of_compilation c)
   9.245  
   9.246  val depth_limited_comp_modifiers = Comp_Mod.Comp_Modifiers
   9.247    {
   9.248 @@ -328,7 +339,7 @@
   9.249    compfuns = Predicate_Comp_Funs.compfuns,
   9.250    mk_random = (fn T => fn additional_arguments =>
   9.251    list_comb (Const(@{const_name Random_Pred.iter},
   9.252 -  [@{typ natural}, @{typ natural}, @{typ Random.seed}] ---> 
   9.253 +  [@{typ natural}, @{typ natural}, @{typ Random.seed}] --->
   9.254      Predicate_Comp_Funs.mk_monadT T), additional_arguments)),
   9.255    modify_funT = (fn T =>
   9.256      let
   9.257 @@ -354,7 +365,7 @@
   9.258    compfuns = Predicate_Comp_Funs.compfuns,
   9.259    mk_random = (fn T => fn additional_arguments =>
   9.260    list_comb (Const(@{const_name Random_Pred.iter},
   9.261 -  [@{typ natural}, @{typ natural}, @{typ Random.seed}] ---> 
   9.262 +  [@{typ natural}, @{typ natural}, @{typ Random.seed}] --->
   9.263      Predicate_Comp_Funs.mk_monadT T), tl additional_arguments)),
   9.264    modify_funT = (fn T =>
   9.265      let
   9.266 @@ -505,7 +516,7 @@
   9.267     : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
   9.268    transform_additional_arguments = K I : (indprem -> term list -> term list)
   9.269    }
   9.270 -  
   9.271 +
   9.272  val neg_generator_dseq_comp_modifiers = Comp_Mod.Comp_Modifiers
   9.273    {
   9.274    compilation = Neg_Generator_DSeq,
   9.275 @@ -534,7 +545,7 @@
   9.276    wrap_compilation = K (K (K (K (K I))))
   9.277     : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
   9.278    transform_additional_arguments = K I : (indprem -> term list -> term list)
   9.279 -  }  
   9.280 +  }
   9.281  
   9.282  val neg_generator_cps_comp_modifiers = Comp_Mod.Comp_Modifiers
   9.283    {
   9.284 @@ -548,30 +559,32 @@
   9.285     : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
   9.286    transform_additional_arguments = K I : (indprem -> term list -> term list)
   9.287    }
   9.288 -  
   9.289 +
   9.290  fun negative_comp_modifiers_of comp_modifiers =
   9.291 -    (case Comp_Mod.compilation comp_modifiers of
   9.292 -      Pos_Random_DSeq => neg_random_dseq_comp_modifiers
   9.293 -    | Neg_Random_DSeq => pos_random_dseq_comp_modifiers
   9.294 -    | New_Pos_Random_DSeq => new_neg_random_dseq_comp_modifiers
   9.295 -    | New_Neg_Random_DSeq => new_pos_random_dseq_comp_modifiers 
   9.296 -    | Pos_Generator_DSeq => neg_generator_dseq_comp_modifiers
   9.297 -    | Neg_Generator_DSeq => pos_generator_dseq_comp_modifiers
   9.298 -    | Pos_Generator_CPS => neg_generator_cps_comp_modifiers
   9.299 -    | Neg_Generator_CPS => pos_generator_cps_comp_modifiers
   9.300 -    | _ => comp_modifiers)
   9.301 +  (case Comp_Mod.compilation comp_modifiers of
   9.302 +    Pos_Random_DSeq => neg_random_dseq_comp_modifiers
   9.303 +  | Neg_Random_DSeq => pos_random_dseq_comp_modifiers
   9.304 +  | New_Pos_Random_DSeq => new_neg_random_dseq_comp_modifiers
   9.305 +  | New_Neg_Random_DSeq => new_pos_random_dseq_comp_modifiers
   9.306 +  | Pos_Generator_DSeq => neg_generator_dseq_comp_modifiers
   9.307 +  | Neg_Generator_DSeq => pos_generator_dseq_comp_modifiers
   9.308 +  | Pos_Generator_CPS => neg_generator_cps_comp_modifiers
   9.309 +  | Neg_Generator_CPS => pos_generator_cps_comp_modifiers
   9.310 +  | _ => comp_modifiers)
   9.311 +
   9.312  
   9.313  (* term construction *)
   9.314  
   9.315 -fun mk_v (names, vs) s T = (case AList.lookup (op =) vs s of
   9.316 -      NONE => (Free (s, T), (names, (s, [])::vs))
   9.317 -    | SOME xs =>
   9.318 -        let
   9.319 -          val s' = singleton (Name.variant_list names) s;
   9.320 -          val v = Free (s', T)
   9.321 -        in
   9.322 -          (v, (s'::names, AList.update (op =) (s, v::xs) vs))
   9.323 -        end);
   9.324 +fun mk_v (names, vs) s T =
   9.325 +  (case AList.lookup (op =) vs s of
   9.326 +    NONE => (Free (s, T), (names, (s, [])::vs))
   9.327 +  | SOME xs =>
   9.328 +      let
   9.329 +        val s' = singleton (Name.variant_list names) s;
   9.330 +        val v = Free (s', T)
   9.331 +      in
   9.332 +        (v, (s'::names, AList.update (op =) (s, v::xs) vs))
   9.333 +      end);
   9.334  
   9.335  fun distinct_v (Free (s, T)) nvs = mk_v nvs s T
   9.336    | distinct_v (t $ u) nvs =
   9.337 @@ -587,7 +600,7 @@
   9.338    let
   9.339      fun mk_bounds (Type (@{type_name Product_Type.prod}, [T1, T2])) i =
   9.340            let
   9.341 -            val (bs2, i') = mk_bounds T2 i 
   9.342 +            val (bs2, i') = mk_bounds T2 i
   9.343              val (bs1, i'') = mk_bounds T1 i'
   9.344            in
   9.345              (HOLogic.pair_const T1 T2 $ bs1 $ bs2, i'' + 1)
   9.346 @@ -608,17 +621,17 @@
   9.347      fold_rev mk_split_abs (binder_types T) inner_term
   9.348    end
   9.349  
   9.350 -fun compile_arg compilation_modifiers _ _ param_modes arg = 
   9.351 +fun compile_arg compilation_modifiers _ _ param_modes arg =
   9.352    let
   9.353      fun map_params (t as Free (f, T)) =
   9.354 -      (case (AList.lookup (op =) param_modes f) of
   9.355 -          SOME mode =>
   9.356 -            let
   9.357 -              val T' = Comp_Mod.funT_of compilation_modifiers mode T
   9.358 -            in
   9.359 -              mk_Eval_of (Free (f, T'), T) mode
   9.360 -            end
   9.361 -        | NONE => t)
   9.362 +          (case (AList.lookup (op =) param_modes f) of
   9.363 +              SOME mode =>
   9.364 +                let
   9.365 +                  val T' = Comp_Mod.funT_of compilation_modifiers mode T
   9.366 +                in
   9.367 +                  mk_Eval_of (Free (f, T'), T) mode
   9.368 +                end
   9.369 +          | NONE => t)
   9.370        | map_params t = t
   9.371    in
   9.372      map_aterms map_params arg
   9.373 @@ -654,39 +667,40 @@
   9.374      val compfuns = Comp_Mod.compfuns compilation_modifiers
   9.375      fun expr_of (t, deriv) =
   9.376        (case (t, deriv) of
   9.377 -        (t, Term Input) => SOME (compile_arg compilation_modifiers additional_arguments ctxt param_modes t)
   9.378 +        (t, Term Input) =>
   9.379 +          SOME (compile_arg compilation_modifiers additional_arguments ctxt param_modes t)
   9.380        | (_, Term Output) => NONE
   9.381        | (Const (name, T), Context mode) =>
   9.382 -        (case alternative_compilation_of ctxt name mode of
   9.383 -          SOME alt_comp => SOME (alt_comp compfuns T)
   9.384 -        | NONE =>
   9.385 -          SOME (Const (function_name_of (Comp_Mod.compilation compilation_modifiers)
   9.386 -            ctxt name mode,
   9.387 -            Comp_Mod.funT_of compilation_modifiers mode T)))
   9.388 +          (case alternative_compilation_of ctxt name mode of
   9.389 +            SOME alt_comp => SOME (alt_comp compfuns T)
   9.390 +          | NONE =>
   9.391 +            SOME (Const (function_name_of (Comp_Mod.compilation compilation_modifiers)
   9.392 +              ctxt name mode,
   9.393 +              Comp_Mod.funT_of compilation_modifiers mode T)))
   9.394        | (Free (s, T), Context m) =>
   9.395 -        (case (AList.lookup (op =) param_modes s) of
   9.396 -          SOME _ => SOME (Free (s, Comp_Mod.funT_of compilation_modifiers m T))
   9.397 -        | NONE =>
   9.398 -        let
   9.399 -          val bs = map (pair "x") (binder_types (fastype_of t))
   9.400 -          val bounds = map Bound (rev (0 upto (length bs) - 1))
   9.401 -        in SOME (fold_rev Term.abs bs (mk_if compfuns (list_comb (t, bounds)))) end)
   9.402 +          (case (AList.lookup (op =) param_modes s) of
   9.403 +            SOME _ => SOME (Free (s, Comp_Mod.funT_of compilation_modifiers m T))
   9.404 +          | NONE =>
   9.405 +              let
   9.406 +                val bs = map (pair "x") (binder_types (fastype_of t))
   9.407 +                val bounds = map Bound (rev (0 upto (length bs) - 1))
   9.408 +              in SOME (fold_rev Term.abs bs (mk_if compfuns (list_comb (t, bounds)))) end)
   9.409        | (t, Context _) =>
   9.410 -        let
   9.411 -          val bs = map (pair "x") (binder_types (fastype_of t))
   9.412 -          val bounds = map Bound (rev (0 upto (length bs) - 1))
   9.413 -        in SOME (fold_rev Term.abs bs (mk_if compfuns (list_comb (t, bounds)))) end
   9.414 +          let
   9.415 +            val bs = map (pair "x") (binder_types (fastype_of t))
   9.416 +            val bounds = map Bound (rev (0 upto (length bs) - 1))
   9.417 +          in SOME (fold_rev Term.abs bs (mk_if compfuns (list_comb (t, bounds)))) end
   9.418        | (Const (@{const_name Pair}, _) $ t1 $ t2, Mode_Pair (d1, d2)) =>
   9.419 -        (case (expr_of (t1, d1), expr_of (t2, d2)) of
   9.420 -          (NONE, NONE) => NONE
   9.421 -        | (NONE, SOME t) => SOME t
   9.422 -        | (SOME t, NONE) => SOME t
   9.423 -        | (SOME t1, SOME t2) => SOME (HOLogic.mk_prod (t1, t2)))
   9.424 +          (case (expr_of (t1, d1), expr_of (t2, d2)) of
   9.425 +            (NONE, NONE) => NONE
   9.426 +          | (NONE, SOME t) => SOME t
   9.427 +          | (SOME t, NONE) => SOME t
   9.428 +          | (SOME t1, SOME t2) => SOME (HOLogic.mk_prod (t1, t2)))
   9.429        | (t1 $ t2, Mode_App (deriv1, deriv2)) =>
   9.430 -        (case (expr_of (t1, deriv1), expr_of (t2, deriv2)) of
   9.431 -          (SOME t, NONE) => SOME t
   9.432 -         | (SOME t, SOME u) => SOME (t $ u)
   9.433 -         | _ => error "something went wrong here!"))
   9.434 +          (case (expr_of (t1, deriv1), expr_of (t2, deriv2)) of
   9.435 +            (SOME t, NONE) => SOME t
   9.436 +           | (SOME t, SOME u) => SOME (t $ u)
   9.437 +           | _ => error "something went wrong here!"))
   9.438    in
   9.439      list_comb (the (expr_of (t, deriv)), additional_arguments)
   9.440    end
   9.441 @@ -721,51 +735,56 @@
   9.442              val mode = head_mode_of deriv
   9.443              val additional_arguments' =
   9.444                Comp_Mod.transform_additional_arguments compilation_modifiers p additional_arguments
   9.445 -            val (compiled_clause, rest) = case p of
   9.446 -               Prem t =>
   9.447 -                 let
   9.448 -                   val u =
   9.449 -                     compile_expr compilation_modifiers ctxt (t, deriv) param_modes additional_arguments'
   9.450 -                   val (_, out_ts''') = split_mode mode (snd (strip_comb t))
   9.451 -                   val rest = compile_prems out_ts''' vs' names'' ps
   9.452 -                 in
   9.453 -                   (u, rest)
   9.454 -                 end
   9.455 -             | Negprem t =>
   9.456 -                 let
   9.457 -                   val neg_compilation_modifiers =
   9.458 -                     negative_comp_modifiers_of compilation_modifiers
   9.459 -                   val u = mk_not compfuns
   9.460 -                     (compile_expr neg_compilation_modifiers ctxt (t, deriv) param_modes additional_arguments')
   9.461 -                   val (_, out_ts''') = split_mode mode (snd (strip_comb t))
   9.462 -                   val rest = compile_prems out_ts''' vs' names'' ps
   9.463 -                 in
   9.464 -                   (u, rest)
   9.465 -                 end
   9.466 -             | Sidecond t =>
   9.467 -                 let
   9.468 -                   val t = compile_arg compilation_modifiers additional_arguments
   9.469 -                     ctxt param_modes t
   9.470 -                   val rest = compile_prems [] vs' names'' ps;
   9.471 -                 in
   9.472 -                   (mk_if compfuns t, rest)
   9.473 -                 end
   9.474 -             | Generator (v, T) =>
   9.475 -                 let
   9.476 -                   val u = Comp_Mod.mk_random compilation_modifiers T additional_arguments
   9.477 -                   val rest = compile_prems [Free (v, T)]  vs' names'' ps;
   9.478 -                 in
   9.479 -                   (u, rest)
   9.480 -                 end
   9.481 +            val (compiled_clause, rest) =
   9.482 +              (case p of
   9.483 +                Prem t =>
   9.484 +                  let
   9.485 +                    val u =
   9.486 +                      compile_expr compilation_modifiers ctxt (t, deriv)
   9.487 +                       param_modes additional_arguments'
   9.488 +                    val (_, out_ts''') = split_mode mode (snd (strip_comb t))
   9.489 +                    val rest = compile_prems out_ts''' vs' names'' ps
   9.490 +                  in
   9.491 +                    (u, rest)
   9.492 +                  end
   9.493 +              | Negprem t =>
   9.494 +                  let
   9.495 +                    val neg_compilation_modifiers =
   9.496 +                      negative_comp_modifiers_of compilation_modifiers
   9.497 +                    val u =
   9.498 +                     mk_not compfuns
   9.499 +                       (compile_expr neg_compilation_modifiers ctxt (t, deriv)
   9.500 +                         param_modes additional_arguments')
   9.501 +                    val (_, out_ts''') = split_mode mode (snd (strip_comb t))
   9.502 +                    val rest = compile_prems out_ts''' vs' names'' ps
   9.503 +                  in
   9.504 +                    (u, rest)
   9.505 +                  end
   9.506 +              | Sidecond t =>
   9.507 +                  let
   9.508 +                    val t = compile_arg compilation_modifiers additional_arguments
   9.509 +                      ctxt param_modes t
   9.510 +                    val rest = compile_prems [] vs' names'' ps;
   9.511 +                  in
   9.512 +                    (mk_if compfuns t, rest)
   9.513 +                  end
   9.514 +              | Generator (v, T) =>
   9.515 +                  let
   9.516 +                    val u = Comp_Mod.mk_random compilation_modifiers T additional_arguments
   9.517 +                    val rest = compile_prems [Free (v, T)]  vs' names'' ps;
   9.518 +                  in
   9.519 +                    (u, rest)
   9.520 +                  end)
   9.521            in
   9.522              compile_match constr_vs' eqs out_ts''
   9.523                (mk_bind compfuns (compiled_clause, rest))
   9.524            end
   9.525 -    val prem_t = compile_prems in_ts' (map fst param_modes) all_vs' moded_ps;
   9.526 +    val prem_t = compile_prems in_ts' (map fst param_modes) all_vs' moded_ps
   9.527    in
   9.528      mk_bind compfuns (mk_single compfuns inp, prem_t)
   9.529    end
   9.530  
   9.531 +
   9.532  (* switch detection *)
   9.533  
   9.534  (** argument position of an inductive predicates and the executable functions **)
   9.535 @@ -776,23 +795,25 @@
   9.536    | input_positions_pair Output = []
   9.537    | input_positions_pair (Fun _) = []
   9.538    | input_positions_pair (Pair (m1, m2)) =
   9.539 -    map (cons 1) (input_positions_pair m1) @ map (cons 2) (input_positions_pair m2)
   9.540 +      map (cons 1) (input_positions_pair m1) @ map (cons 2) (input_positions_pair m2)
   9.541  
   9.542 -fun input_positions_of_mode mode = flat (map_index
   9.543 -   (fn (i, Input) => [(i, [])]
   9.544 -   | (_, Output) => []
   9.545 -   | (_, Fun _) => []
   9.546 -   | (i, m as Pair _) => map (pair i) (input_positions_pair m))
   9.547 -     (Predicate_Compile_Aux.strip_fun_mode mode))
   9.548 +fun input_positions_of_mode mode =
   9.549 +  flat
   9.550 +    (map_index
   9.551 +      (fn (i, Input) => [(i, [])]
   9.552 +        | (_, Output) => []
   9.553 +        | (_, Fun _) => []
   9.554 +        | (i, m as Pair _) => map (pair i) (input_positions_pair m))
   9.555 +      (Predicate_Compile_Aux.strip_fun_mode mode))
   9.556  
   9.557  fun argument_position_pair _ [] = []
   9.558    | argument_position_pair (Pair (Fun _, m2)) (2 :: is) = argument_position_pair m2 is
   9.559    | argument_position_pair (Pair (m1, m2)) (i :: is) =
   9.560 -    (if eq_mode (m1, Output) andalso i = 2 then
   9.561 -      argument_position_pair m2 is
   9.562 -    else if eq_mode (m2, Output) andalso i = 1 then
   9.563 -      argument_position_pair m1 is
   9.564 -    else (i :: argument_position_pair (if i = 1 then m1 else m2) is))
   9.565 +      (if eq_mode (m1, Output) andalso i = 2 then
   9.566 +        argument_position_pair m2 is
   9.567 +      else if eq_mode (m2, Output) andalso i = 1 then
   9.568 +        argument_position_pair m1 is
   9.569 +      else (i :: argument_position_pair (if i = 1 then m1 else m2) is))
   9.570  
   9.571  fun argument_position_of mode (i, is) =
   9.572    (i - (length (filter (fn Output => true | Fun _ => true | _ => false)
   9.573 @@ -804,6 +825,7 @@
   9.574    | nth_pair (2 :: is) (Const (@{const_name Pair}, _) $ _ $ t2) = nth_pair is t2
   9.575    | nth_pair _ _ = raise Fail "unexpected input for nth_tuple"
   9.576  
   9.577 +
   9.578  (** switch detection analysis **)
   9.579  
   9.580  fun find_switch_test ctxt (i, is) (ts, _) =
   9.581 @@ -811,26 +833,27 @@
   9.582      val t = nth_pair is (nth ts i)
   9.583      val T = fastype_of t
   9.584    in
   9.585 -    case T of
   9.586 +    (case T of
   9.587        TFree _ => NONE
   9.588      | Type (Tcon, _) =>
   9.589 -      (case Ctr_Sugar.ctr_sugar_of ctxt Tcon of
   9.590 -        NONE => NONE
   9.591 -      | SOME {ctrs, ...} =>
   9.592 -        (case strip_comb t of
   9.593 -          (Var _, []) => NONE
   9.594 -        | (Free _, []) => NONE
   9.595 -        | (Const (c, T), _) =>
   9.596 -          if AList.defined (op =) (map_filter (try dest_Const) ctrs) c then SOME (c, T) else NONE))
   9.597 +        (case Ctr_Sugar.ctr_sugar_of ctxt Tcon of
   9.598 +          NONE => NONE
   9.599 +        | SOME {ctrs, ...} =>
   9.600 +            (case strip_comb t of
   9.601 +              (Var _, []) => NONE
   9.602 +            | (Free _, []) => NONE
   9.603 +            | (Const (c, T), _) =>
   9.604 +                if AList.defined (op =) (map_filter (try dest_Const) ctrs) c
   9.605 +                then SOME (c, T) else NONE)))
   9.606    end
   9.607  
   9.608  fun partition_clause ctxt pos moded_clauses =
   9.609    let
   9.610      fun insert_list eq (key, value) = AList.map_default eq (key, []) (cons value)
   9.611      fun find_switch_test' moded_clause (cases, left) =
   9.612 -      case find_switch_test ctxt pos moded_clause of
   9.613 +      (case find_switch_test ctxt pos moded_clause of
   9.614          SOME (c, T) => (insert_list (op =) ((c, T), moded_clause) cases, left)
   9.615 -      | NONE => (cases, moded_clause :: left)
   9.616 +      | NONE => (cases, moded_clause :: left))
   9.617    in
   9.618      fold find_switch_test' moded_clauses ([], [])
   9.619    end
   9.620 @@ -846,34 +869,36 @@
   9.621          val partition = partition_clause ctxt input_position moded_clauses
   9.622          val switch = if (length (fst partition) > 1) then SOME (input_position, partition) else NONE
   9.623        in
   9.624 -        case ord (switch, best_switch) of LESS => best_switch
   9.625 -          | EQUAL => best_switch | GREATER => switch
   9.626 +        (case ord (switch, best_switch) of
   9.627 +          LESS => best_switch
   9.628 +        | EQUAL => best_switch
   9.629 +        | GREATER => switch)
   9.630        end
   9.631      fun detect_switches moded_clauses =
   9.632 -      case fold (select_best_switch moded_clauses) (input_positions_of_mode mode) NONE of
   9.633 +      (case fold (select_best_switch moded_clauses) (input_positions_of_mode mode) NONE of
   9.634          SOME (best_pos, (switched_on, left_clauses)) =>
   9.635            Node ((best_pos, map (apsnd detect_switches) switched_on),
   9.636              detect_switches left_clauses)
   9.637 -      | NONE => Atom moded_clauses
   9.638 +      | NONE => Atom moded_clauses)
   9.639    in
   9.640      detect_switches moded_clauses
   9.641    end
   9.642  
   9.643 +
   9.644  (** compilation of detected switches **)
   9.645  
   9.646  fun destruct_constructor_pattern (pat, obj) =
   9.647    (case strip_comb pat of
   9.648 -    (Free _, []) => cons (pat, obj)
   9.649 +      (Free _, []) => cons (pat, obj)
   9.650    | (Const (c, T), pat_args) =>
   9.651 -    (case strip_comb obj of
   9.652 -      (Const (c', T'), obj_args) =>
   9.653 -        (if c = c' andalso T = T' then
   9.654 -          fold destruct_constructor_pattern (pat_args ~~ obj_args)
   9.655 -        else raise Fail "pattern and object mismatch")
   9.656 -    | _ => raise Fail "unexpected object")
   9.657 +      (case strip_comb obj of
   9.658 +        (Const (c', T'), obj_args) =>
   9.659 +          (if c = c' andalso T = T' then
   9.660 +            fold destruct_constructor_pattern (pat_args ~~ obj_args)
   9.661 +          else raise Fail "pattern and object mismatch")
   9.662 +      | _ => raise Fail "unexpected object")
   9.663    | _ => raise Fail "unexpected pattern")
   9.664  
   9.665 -
   9.666  fun compile_switch compilation_modifiers ctxt all_vs param_modes additional_arguments mode
   9.667    in_ts' outTs switch_tree =
   9.668    let
   9.669 @@ -921,48 +946,55 @@
   9.670            ((map compile_single_case switched_clauses) @
   9.671              [(xt, mk_empty compfuns (HOLogic.mk_tupleT outTs))])
   9.672        in
   9.673 -        case compile_switch_tree all_vs ctxt_eqs left_clauses of
   9.674 +        (case compile_switch_tree all_vs ctxt_eqs left_clauses of
   9.675            NONE => SOME switch
   9.676 -        | SOME left_comp => SOME (mk_plus compfuns (switch, left_comp))
   9.677 +        | SOME left_comp => SOME (mk_plus compfuns (switch, left_comp)))
   9.678        end
   9.679    in
   9.680      compile_switch_tree all_vs [] switch_tree
   9.681    end
   9.682  
   9.683 +
   9.684  (* compilation of predicates *)
   9.685  
   9.686  fun compile_pred options compilation_modifiers ctxt all_vs param_vs s T (pol, mode) moded_cls =
   9.687    let
   9.688 -    val is_terminating = false (* FIXME: requires an termination analysis *)  
   9.689 +    val is_terminating = false (* FIXME: requires an termination analysis *)
   9.690      val compilation_modifiers =
   9.691        (if pol then compilation_modifiers else
   9.692          negative_comp_modifiers_of compilation_modifiers)
   9.693        |> (if is_depth_limited_compilation (Comp_Mod.compilation compilation_modifiers) then
   9.694             (if is_terminating then
   9.695 -             (Comp_Mod.set_compfuns (unlimited_compfuns_of pol (Comp_Mod.compilation compilation_modifiers)))
   9.696 -           else
   9.697 -             (Comp_Mod.set_compfuns (limited_compfuns_of pol (Comp_Mod.compilation compilation_modifiers))))
   9.698 -         else I)
   9.699 -    val additional_arguments = Comp_Mod.additional_arguments compilation_modifiers
   9.700 -      (all_vs @ param_vs)
   9.701 +              (Comp_Mod.set_compfuns
   9.702 +                (unlimited_compfuns_of pol (Comp_Mod.compilation compilation_modifiers)))
   9.703 +            else
   9.704 +              (Comp_Mod.set_compfuns
   9.705 +                (limited_compfuns_of pol (Comp_Mod.compilation compilation_modifiers))))
   9.706 +          else I)
   9.707 +    val additional_arguments =
   9.708 +      Comp_Mod.additional_arguments compilation_modifiers (all_vs @ param_vs)
   9.709      val compfuns = Comp_Mod.compfuns compilation_modifiers
   9.710      fun is_param_type (T as Type ("fun",[_ , T'])) =
   9.711 -      is_some (try (dest_monadT compfuns) T) orelse is_param_type T'
   9.712 +          is_some (try (dest_monadT compfuns) T) orelse is_param_type T'
   9.713        | is_param_type T = is_some (try (dest_monadT compfuns) T)
   9.714 -    val (inpTs, outTs) = split_map_modeT (fn m => fn T => (SOME (funT_of compfuns m T), NONE)) mode
   9.715 -      (binder_types T)
   9.716 +    val (inpTs, outTs) =
   9.717 +      split_map_modeT (fn m => fn T => (SOME (funT_of compfuns m T), NONE)) mode
   9.718 +        (binder_types T)
   9.719      val funT = Comp_Mod.funT_of compilation_modifiers mode T
   9.720 -    val (in_ts, _) = fold_map (fold_map_aterms_prodT (curry HOLogic.mk_prod)
   9.721 -      (fn T => fn (param_vs, names) =>
   9.722 -        if is_param_type T then
   9.723 -          (Free (hd param_vs, T), (tl param_vs, names))
   9.724 -        else
   9.725 -          let
   9.726 -            val new = singleton (Name.variant_list names) "x"
   9.727 -          in (Free (new, T), (param_vs, new :: names)) end)) inpTs
   9.728 +    val (in_ts, _) =
   9.729 +      fold_map (fold_map_aterms_prodT (curry HOLogic.mk_prod)
   9.730 +        (fn T => fn (param_vs, names) =>
   9.731 +          if is_param_type T then
   9.732 +            (Free (hd param_vs, T), (tl param_vs, names))
   9.733 +          else
   9.734 +            let
   9.735 +              val new = singleton (Name.variant_list names) "x"
   9.736 +            in (Free (new, T), (param_vs, new :: names)) end)) inpTs
   9.737          (param_vs, (all_vs @ param_vs))
   9.738 -    val in_ts' = map_filter (map_filter_prod
   9.739 -      (fn t as Free (x, _) => if member (op =) param_vs x then NONE else SOME t | t => SOME t)) in_ts
   9.740 +    val in_ts' =
   9.741 +      map_filter (map_filter_prod
   9.742 +        (fn t as Free (x, _) =>
   9.743 +          if member (op =) param_vs x then NONE else SOME t | t => SOME t)) in_ts
   9.744      val param_modes = param_vs ~~ ho_arg_modes_of mode
   9.745      val compilation =
   9.746        if detect_switches options then
   9.747 @@ -972,9 +1004,9 @@
   9.748        else
   9.749          let
   9.750            val cl_ts =
   9.751 -            map (fn (ts, moded_prems) => 
   9.752 +            map (fn (ts, moded_prems) =>
   9.753                compile_clause compilation_modifiers ctxt all_vs param_modes additional_arguments
   9.754 -                (HOLogic.mk_tuple in_ts') (split_mode mode ts) moded_prems) moded_cls;
   9.755 +                (HOLogic.mk_tuple in_ts') (split_mode mode ts) moded_prems) moded_cls
   9.756          in
   9.757            Comp_Mod.wrap_compilation compilation_modifiers compfuns s T mode additional_arguments
   9.758              (if null cl_ts then
   9.759 @@ -983,12 +1015,12 @@
   9.760                foldr1 (mk_plus compfuns) cl_ts)
   9.761          end
   9.762      val fun_const =
   9.763 -      Const (function_name_of (Comp_Mod.compilation compilation_modifiers)
   9.764 -      ctxt s mode, funT)
   9.765 +      Const (function_name_of (Comp_Mod.compilation compilation_modifiers) ctxt s mode, funT)
   9.766    in
   9.767      HOLogic.mk_Trueprop
   9.768        (HOLogic.mk_eq (list_comb (fun_const, in_ts @ additional_arguments), compilation))
   9.769 -  end;
   9.770 +  end
   9.771 +
   9.772  
   9.773  (* Definition of executable functions and their intro and elim rules *)
   9.774  
   9.775 @@ -997,36 +1029,36 @@
   9.776    | strip_split_abs t = t
   9.777  
   9.778  fun mk_args is_eval (m as Pair (m1, m2), T as Type (@{type_name Product_Type.prod}, [T1, T2])) names =
   9.779 -    if eq_mode (m, Input) orelse eq_mode (m, Output) then
   9.780 +      if eq_mode (m, Input) orelse eq_mode (m, Output) then
   9.781 +        let
   9.782 +          val x = singleton (Name.variant_list names) "x"
   9.783 +        in
   9.784 +          (Free (x, T), x :: names)
   9.785 +        end
   9.786 +      else
   9.787 +        let
   9.788 +          val (t1, names') = mk_args is_eval (m1, T1) names
   9.789 +          val (t2, names'') = mk_args is_eval (m2, T2) names'
   9.790 +        in
   9.791 +          (HOLogic.mk_prod (t1, t2), names'')
   9.792 +        end
   9.793 +  | mk_args is_eval ((m as Fun _), T) names =
   9.794 +      let
   9.795 +        val funT = funT_of Predicate_Comp_Funs.compfuns m T
   9.796 +        val x = singleton (Name.variant_list names) "x"
   9.797 +        val (args, _) = fold_map (mk_args is_eval) (strip_fun_mode m ~~ binder_types T) (x :: names)
   9.798 +        val (inargs, outargs) = split_map_mode (fn _ => fn t => (SOME t, NONE)) m args
   9.799 +        val t = fold_rev HOLogic.tupled_lambda args (Predicate_Comp_Funs.mk_Eval
   9.800 +          (list_comb (Free (x, funT), inargs), HOLogic.mk_tuple outargs))
   9.801 +      in
   9.802 +        (if is_eval then t else Free (x, funT), x :: names)
   9.803 +      end
   9.804 +  | mk_args _ (_, T) names =
   9.805        let
   9.806          val x = singleton (Name.variant_list names) "x"
   9.807        in
   9.808          (Free (x, T), x :: names)
   9.809        end
   9.810 -    else
   9.811 -      let
   9.812 -        val (t1, names') = mk_args is_eval (m1, T1) names
   9.813 -        val (t2, names'') = mk_args is_eval (m2, T2) names'
   9.814 -      in
   9.815 -        (HOLogic.mk_prod (t1, t2), names'')
   9.816 -      end
   9.817 -  | mk_args is_eval ((m as Fun _), T) names =
   9.818 -    let
   9.819 -      val funT = funT_of Predicate_Comp_Funs.compfuns m T
   9.820 -      val x = singleton (Name.variant_list names) "x"
   9.821 -      val (args, _) = fold_map (mk_args is_eval) (strip_fun_mode m ~~ binder_types T) (x :: names)
   9.822 -      val (inargs, outargs) = split_map_mode (fn _ => fn t => (SOME t, NONE)) m args
   9.823 -      val t = fold_rev HOLogic.tupled_lambda args (Predicate_Comp_Funs.mk_Eval
   9.824 -        (list_comb (Free (x, funT), inargs), HOLogic.mk_tuple outargs))
   9.825 -    in
   9.826 -      (if is_eval then t else Free (x, funT), x :: names)
   9.827 -    end
   9.828 -  | mk_args is_eval (_, T) names =
   9.829 -    let
   9.830 -      val x = singleton (Name.variant_list names) "x"
   9.831 -    in
   9.832 -      (Free (x, T), x :: names)
   9.833 -    end
   9.834  
   9.835  fun create_intro_elim_rule ctxt mode defthm mode_id funT pred =
   9.836    let
   9.837 @@ -1053,8 +1085,9 @@
   9.838      val funpropI = HOLogic.mk_Trueprop (Predicate_Comp_Funs.mk_Eval (list_comb (funtrm, inargs),
   9.839                       HOLogic.mk_tuple outargs))
   9.840      val introtrm = Logic.list_implies (predpropI :: param_eqs, funpropI)
   9.841 -    val simprules = [defthm, @{thm eval_pred},
   9.842 -      @{thm "split_beta"}, @{thm "fst_conv"}, @{thm "snd_conv"}, @{thm pair_collapse}]
   9.843 +    val simprules =
   9.844 +      [defthm, @{thm eval_pred},
   9.845 +        @{thm "split_beta"}, @{thm "fst_conv"}, @{thm "snd_conv"}, @{thm pair_collapse}]
   9.846      val unfolddef_tac =
   9.847        Simplifier.asm_full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps simprules) 1
   9.848      val introthm = Goal.prove ctxt
   9.849 @@ -1083,14 +1116,13 @@
   9.850      ((introthm, elimthm), opt_neg_introthm)
   9.851    end
   9.852  
   9.853 -fun create_constname_of_mode options thy prefix name _ mode = 
   9.854 +fun create_constname_of_mode options thy prefix name _ mode =
   9.855    let
   9.856 -    val system_proposal = prefix ^ (Long_Name.base_name name)
   9.857 -      ^ "_" ^ ascii_string_of_mode mode
   9.858 +    val system_proposal = prefix ^ (Long_Name.base_name name) ^ "_" ^ ascii_string_of_mode mode
   9.859      val name = the_default system_proposal (proposed_names options name mode)
   9.860    in
   9.861      Sign.full_bname thy name
   9.862 -  end;
   9.863 +  end
   9.864  
   9.865  fun create_definitions options preds (name, modes) thy =
   9.866    let
   9.867 @@ -1182,13 +1214,14 @@
   9.868  fun dest_prem ctxt params t =
   9.869    (case strip_comb t of
   9.870      (v as Free _, _) => if member (op =) params v then Prem t else Sidecond t
   9.871 -  | (c as Const (@{const_name Not}, _), [t]) => (case dest_prem ctxt params t of
   9.872 -      Prem t => Negprem t
   9.873 -    | Negprem _ => error ("Double negation not allowed in premise: " ^
   9.874 -        Syntax.string_of_term ctxt (c $ t)) 
   9.875 -    | Sidecond t => Sidecond (c $ t))
   9.876 +  | (c as Const (@{const_name Not}, _), [t]) =>
   9.877 +      (case dest_prem ctxt params t of
   9.878 +        Prem t => Negprem t
   9.879 +      | Negprem _ => error ("Double negation not allowed in premise: " ^
   9.880 +          Syntax.string_of_term ctxt (c $ t))
   9.881 +      | Sidecond t => Sidecond (c $ t))
   9.882    | (Const (s, _), _) =>
   9.883 -    if is_registered ctxt s then Prem t else Sidecond t
   9.884 +      if is_registered ctxt s then Prem t else Sidecond t
   9.885    | _ => Sidecond t)
   9.886  
   9.887  fun prepare_intrs options ctxt prednames intros =
   9.888 @@ -1205,13 +1238,14 @@
   9.889          all_smodes_of_typ T
   9.890        else
   9.891          all_modes_of_typ T
   9.892 -    val all_modes = 
   9.893 +    val all_modes =
   9.894        map (fn (s, T) =>
   9.895 -        (s, case proposed_modes options s of
   9.896 +        (s,
   9.897 +          (case proposed_modes options s of
   9.898              SOME ms => check_matches_type ctxt s T ms
   9.899 -          | NONE => generate_modes s T)) preds
   9.900 +          | NONE => generate_modes s T))) preds
   9.901      val params =
   9.902 -      case intrs of
   9.903 +      (case intrs of
   9.904          [] =>
   9.905            let
   9.906              val T = snd (hd preds)
   9.907 @@ -1224,25 +1258,28 @@
   9.908              map2 (curry Free) param_names paramTs
   9.909            end
   9.910        | (intr :: _) =>
   9.911 -        let
   9.912 -          val (p, args) = strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl intr))
   9.913 -          val one_mode = hd (the (AList.lookup (op =) all_modes (fst (dest_Const p))))
   9.914 -        in
   9.915 -          ho_args_of one_mode args
   9.916 -        end
   9.917 +          let
   9.918 +            val (p, args) = strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl intr))
   9.919 +            val one_mode = hd (the (AList.lookup (op =) all_modes (fst (dest_Const p))))
   9.920 +          in
   9.921 +            ho_args_of one_mode args
   9.922 +          end)
   9.923      val param_vs = map (fst o dest_Free) params
   9.924      fun add_clause intr clauses =
   9.925        let
   9.926 -        val (Const (name, _), ts) = strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl intr))
   9.927 -        val prems = map (dest_prem ctxt params o HOLogic.dest_Trueprop) (Logic.strip_imp_prems intr)
   9.928 +        val (Const (name, _), ts) =
   9.929 +          strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl intr))
   9.930 +        val prems =
   9.931 +          map (dest_prem ctxt params o HOLogic.dest_Trueprop) (Logic.strip_imp_prems intr)
   9.932        in
   9.933 -        AList.update op = (name, these (AList.lookup op = clauses name) @
   9.934 -          [(ts, prems)]) clauses
   9.935 +        AList.update op =
   9.936 +          (name, these (AList.lookup op = clauses name) @ [(ts, prems)])
   9.937 +          clauses
   9.938        end;
   9.939      val clauses = fold add_clause intrs []
   9.940    in
   9.941      (preds, all_vs, param_vs, all_modes, clauses)
   9.942 -  end;
   9.943 +  end
   9.944  
   9.945  (* sanity check of introduction rules *)
   9.946  (* TODO: rethink check with new modes *)
   9.947 @@ -1259,7 +1296,7 @@
   9.948          else
   9.949            error ("Format of introduction rule is invalid: tuples must be expanded:"
   9.950            ^ (Syntax.string_of_term_global thy arg) ^ " in " ^
   9.951 -          (Display.string_of_thm_global thy intro)) 
   9.952 +          (Display.string_of_thm_global thy intro))
   9.953        | _ => true
   9.954      val prems = Logic.strip_imp_prems (prop_of intro)
   9.955      fun check_prem (Prem t) = forall check_arg args
   9.956 @@ -1289,6 +1326,7 @@
   9.957    in forall check prednames end
   9.958  *)
   9.959  
   9.960 +
   9.961  (* create code equation *)
   9.962  
   9.963  fun add_code_equations ctxt preds result_thmss =
   9.964 @@ -1322,6 +1360,7 @@
   9.965      map2 add_code_equation preds result_thmss
   9.966    end
   9.967  
   9.968 +
   9.969  (** main function of predicate compiler **)
   9.970  
   9.971  datatype steps = Steps of
   9.972 @@ -1341,11 +1380,12 @@
   9.973      fun dest_steps (Steps s) = s
   9.974      val compilation = Comp_Mod.compilation (#comp_modifiers (dest_steps steps))
   9.975      val ctxt = Proof_Context.init_global thy
   9.976 -    val _ = print_step options
   9.977 -      ("Starting predicate compiler (compilation: " ^ string_of_compilation compilation
   9.978 -        ^ ") for predicates " ^ commas prednames ^ "...")
   9.979 -      (*val _ = check_intros_elim_match thy prednames*)
   9.980 -      (*val _ = map (check_format_of_intro_rule thy) (maps (intros_of thy) prednames)*)
   9.981 +    val _ =
   9.982 +      print_step options
   9.983 +        ("Starting predicate compiler (compilation: " ^ string_of_compilation compilation ^
   9.984 +          ") for predicates " ^ commas prednames ^ "...")
   9.985 +    (*val _ = check_intros_elim_match thy prednames*)
   9.986 +    (*val _ = map (check_format_of_intro_rule thy) (maps (intros_of thy) prednames)*)
   9.987      val _ =
   9.988        if show_intermediate_results options then
   9.989          tracing (commas (map (Display.string_of_thm ctxt) (maps (intros_of ctxt) prednames)))
   9.990 @@ -1392,7 +1432,7 @@
   9.991    in
   9.992      thy'''
   9.993    end
   9.994 -  
   9.995 +
   9.996  fun gen_add_equations steps options names thy =
   9.997    let
   9.998      fun dest_steps (Steps s) = s
   9.999 @@ -1499,14 +1539,17 @@
  9.1000    (Steps {
  9.1001    define_functions =
  9.1002      fn options => fn preds => fn (s, modes) =>
  9.1003 -    let
  9.1004 -      val pos_modes = map_filter (fn (true, m) => SOME m | _ => NONE) modes
  9.1005 -      val neg_modes = map_filter (fn (false, m) => SOME m | _ => NONE) modes
  9.1006 -    in define_functions new_pos_random_dseq_comp_modifiers New_Pos_Random_Sequence_CompFuns.depth_limited_compfuns
  9.1007 -      options preds (s, pos_modes)
  9.1008 -      #> define_functions new_neg_random_dseq_comp_modifiers New_Neg_Random_Sequence_CompFuns.depth_limited_compfuns
  9.1009 -      options preds (s, neg_modes)
  9.1010 -    end,
  9.1011 +      let
  9.1012 +        val pos_modes = map_filter (fn (true, m) => SOME m | _ => NONE) modes
  9.1013 +        val neg_modes = map_filter (fn (false, m) => SOME m | _ => NONE) modes
  9.1014 +      in
  9.1015 +        define_functions new_pos_random_dseq_comp_modifiers
  9.1016 +          New_Pos_Random_Sequence_CompFuns.depth_limited_compfuns
  9.1017 +          options preds (s, pos_modes) #>
  9.1018 +        define_functions new_neg_random_dseq_comp_modifiers
  9.1019 +          New_Neg_Random_Sequence_CompFuns.depth_limited_compfuns
  9.1020 +          options preds (s, neg_modes)
  9.1021 +      end,
  9.1022    prove = prove_by_skip,
  9.1023    add_code_equations = K (K I),
  9.1024    comp_modifiers = new_pos_random_dseq_comp_modifiers,
  9.1025 @@ -1516,16 +1559,16 @@
  9.1026  val add_generator_dseq_equations = gen_add_equations
  9.1027    (Steps {
  9.1028    define_functions =
  9.1029 -  fn options => fn preds => fn (s, modes) =>
  9.1030 -    let
  9.1031 -      val pos_modes = map_filter (fn (true, m) => SOME m | _ => NONE) modes
  9.1032 -      val neg_modes = map_filter (fn (false, m) => SOME m | _ => NONE) modes
  9.1033 -    in 
  9.1034 -      define_functions pos_generator_dseq_comp_modifiers New_Pos_DSequence_CompFuns.depth_limited_compfuns
  9.1035 -        options preds (s, pos_modes)
  9.1036 -      #> define_functions neg_generator_dseq_comp_modifiers New_Neg_DSequence_CompFuns.depth_limited_compfuns
  9.1037 -        options preds (s, neg_modes)
  9.1038 -    end,
  9.1039 +    fn options => fn preds => fn (s, modes) =>
  9.1040 +      let
  9.1041 +        val pos_modes = map_filter (fn (true, m) => SOME m | _ => NONE) modes
  9.1042 +        val neg_modes = map_filter (fn (false, m) => SOME m | _ => NONE) modes
  9.1043 +      in
  9.1044 +        define_functions pos_generator_dseq_comp_modifiers
  9.1045 +          New_Pos_DSequence_CompFuns.depth_limited_compfuns options preds (s, pos_modes) #>
  9.1046 +        define_functions neg_generator_dseq_comp_modifiers
  9.1047 +          New_Neg_DSequence_CompFuns.depth_limited_compfuns options preds (s, neg_modes)
  9.1048 +      end,
  9.1049    prove = prove_by_skip,
  9.1050    add_code_equations = K (K I),
  9.1051    comp_modifiers = pos_generator_dseq_comp_modifiers,
  9.1052 @@ -1535,23 +1578,23 @@
  9.1053  val add_generator_cps_equations = gen_add_equations
  9.1054    (Steps {
  9.1055    define_functions =
  9.1056 -  fn options => fn preds => fn (s, modes) =>
  9.1057 -    let
  9.1058 -      val pos_modes = map_filter (fn (true, m) => SOME m | _ => NONE) modes
  9.1059 -      val neg_modes = map_filter (fn (false, m) => SOME m | _ => NONE) modes
  9.1060 -    in 
  9.1061 -      define_functions pos_generator_cps_comp_modifiers Pos_Bounded_CPS_Comp_Funs.compfuns
  9.1062 -        options preds (s, pos_modes)
  9.1063 -      #> define_functions neg_generator_cps_comp_modifiers Neg_Bounded_CPS_Comp_Funs.compfuns
  9.1064 -        options preds (s, neg_modes)
  9.1065 -    end,
  9.1066 +    fn options => fn preds => fn (s, modes) =>
  9.1067 +      let
  9.1068 +        val pos_modes = map_filter (fn (true, m) => SOME m | _ => NONE) modes
  9.1069 +        val neg_modes = map_filter (fn (false, m) => SOME m | _ => NONE) modes
  9.1070 +      in
  9.1071 +        define_functions pos_generator_cps_comp_modifiers Pos_Bounded_CPS_Comp_Funs.compfuns
  9.1072 +          options preds (s, pos_modes)
  9.1073 +        #> define_functions neg_generator_cps_comp_modifiers Neg_Bounded_CPS_Comp_Funs.compfuns
  9.1074 +          options preds (s, neg_modes)
  9.1075 +      end,
  9.1076    prove = prove_by_skip,
  9.1077    add_code_equations = K (K I),
  9.1078    comp_modifiers = pos_generator_cps_comp_modifiers,
  9.1079    use_generators = true,
  9.1080    qname = "generator_cps_equation"})
  9.1081 -  
  9.1082 -  
  9.1083 +
  9.1084 +
  9.1085  (** user interface **)
  9.1086  
  9.1087  (* code_pred_intro attribute *)
  9.1088 @@ -1569,9 +1612,11 @@
  9.1089  
  9.1090  val default_values_timeout = if ML_System.is_smlnj then 1200.0 else 40.0
  9.1091  
  9.1092 -val values_timeout = Attrib.setup_config_real @{binding values_timeout} (K default_values_timeout)
  9.1093 +val values_timeout =
  9.1094 +  Attrib.setup_config_real @{binding values_timeout} (K default_values_timeout)
  9.1095  
  9.1096 -val setup = PredData.put (Graph.empty) #>
  9.1097 +val setup =
  9.1098 +  PredData.put (Graph.empty) #>
  9.1099    Attrib.setup @{binding code_pred_intro} (Scan.lift (Scan.option Args.name) >> attrib' add_intro)
  9.1100      "adding alternative introduction rules for code generation of inductive predicates"
  9.1101  
  9.1102 @@ -1593,7 +1638,7 @@
  9.1103          val T = Sign.the_const_type thy' const
  9.1104          val pred = Const (const, T)
  9.1105          val intros = intros_of ctxt' const
  9.1106 -      in mk_casesrule lthy' pred intros end  
  9.1107 +      in mk_casesrule lthy' pred intros end
  9.1108      val cases_rules = map mk_cases preds
  9.1109      val cases =
  9.1110        map2 (fn pred_name => fn case_rule => Rule_Cases.Case {fixes = [],
  9.1111 @@ -1634,6 +1679,7 @@
  9.1112  val code_pred = generic_code_pred (K I);
  9.1113  val code_pred_cmd = generic_code_pred Code.read_const
  9.1114  
  9.1115 +
  9.1116  (* transformation for code generation *)
  9.1117  
  9.1118  (* FIXME just one data slot (record) per program unit *)
  9.1119 @@ -1696,13 +1742,16 @@
  9.1120  
  9.1121  fun dest_special_compr t =
  9.1122    let
  9.1123 -    val (inner_t, T_compr) = case t of (Const (@{const_name Collect}, _) $ Abs (_, T, t)) => (t, T)
  9.1124 -      | _ => raise TERM ("dest_special_compr", [t])
  9.1125 +    val (inner_t, T_compr) =
  9.1126 +      (case t of
  9.1127 +        (Const (@{const_name Collect}, _) $ Abs (_, T, t)) => (t, T)
  9.1128 +      | _ => raise TERM ("dest_special_compr", [t]))
  9.1129      val (Ts, conj) = apfst (map snd) (Predicate_Compile_Aux.strip_ex inner_t)
  9.1130      val [eq, body] = HOLogic.dest_conj conj
  9.1131 -    val rhs = case HOLogic.dest_eq eq of
  9.1132 +    val rhs =
  9.1133 +      (case HOLogic.dest_eq eq of
  9.1134          (Bound i, rhs) => if i = length Ts then rhs else raise TERM ("dest_special_compr", [t])
  9.1135 -      | _ => raise TERM ("dest_special_compr", [t])
  9.1136 +      | _ => raise TERM ("dest_special_compr", [t]))
  9.1137      val output_names = Name.variant_list (fold Term.add_free_names [rhs, body] [])
  9.1138        (map (fn i => "x" ^ string_of_int i) (1 upto length Ts))
  9.1139      val output_frees = map2 (curry Free) output_names (rev Ts)
  9.1140 @@ -1713,9 +1762,11 @@
  9.1141    end
  9.1142  
  9.1143  fun dest_general_compr ctxt t_compr =
  9.1144 -  let      
  9.1145 -    val inner_t = case t_compr of (Const (@{const_name Collect}, _) $ t) => t
  9.1146 -      | _ => error ("Not a set comprehension: " ^ Syntax.string_of_term ctxt t_compr);    
  9.1147 +  let
  9.1148 +    val inner_t =
  9.1149 +      (case t_compr of
  9.1150 +        (Const (@{const_name Collect}, _) $ t) => t
  9.1151 +      | _ => error ("Not a set comprehension: " ^ Syntax.string_of_term ctxt t_compr))
  9.1152      val (body, Ts, fp) = HOLogic.strip_psplits inner_t;
  9.1153      val output_names = Name.variant_list (Term.add_free_names body [])
  9.1154        (map (fn i => "x" ^ string_of_int i) (1 upto length Ts))
  9.1155 @@ -1734,24 +1785,28 @@
  9.1156      val compfuns = Comp_Mod.compfuns comp_modifiers
  9.1157      val all_modes_of = all_modes_of compilation
  9.1158      val (((body, output), T_compr), output_names) =
  9.1159 -      case try dest_special_compr t_compr of SOME r => r | NONE => dest_general_compr ctxt t_compr
  9.1160 +      (case try dest_special_compr t_compr of
  9.1161 +        SOME r => r
  9.1162 +      | NONE => dest_general_compr ctxt t_compr)
  9.1163      val (Const (name, _), all_args) =
  9.1164 -      case strip_comb body of
  9.1165 +      (case strip_comb body of
  9.1166          (Const (name, T), all_args) => (Const (name, T), all_args)
  9.1167 -      | (head, _) => error ("Not a constant: " ^ Syntax.string_of_term ctxt head)
  9.1168 +      | (head, _) => error ("Not a constant: " ^ Syntax.string_of_term ctxt head))
  9.1169    in
  9.1170      if defined_functions compilation ctxt name then
  9.1171        let
  9.1172 -        fun extract_mode (Const (@{const_name Pair}, _) $ t1 $ t2) = Pair (extract_mode t1, extract_mode t2)
  9.1173 -          | extract_mode (Free (x, _)) = if member (op =) output_names x then Output else Input
  9.1174 +        fun extract_mode (Const (@{const_name Pair}, _) $ t1 $ t2) =
  9.1175 +              Pair (extract_mode t1, extract_mode t2)
  9.1176 +          | extract_mode (Free (x, _)) =
  9.1177 +              if member (op =) output_names x then Output else Input
  9.1178            | extract_mode _ = Input
  9.1179          val user_mode = fold_rev (curry Fun) (map extract_mode all_args) Bool
  9.1180          fun valid modes1 modes2 =
  9.1181 -          case int_ord (length modes1, length modes2) of
  9.1182 +          (case int_ord (length modes1, length modes2) of
  9.1183              GREATER => error "Not enough mode annotations"
  9.1184            | LESS => error "Too many mode annotations"
  9.1185 -          | EQUAL => forall (fn (_, NONE) => true | (m, SOME m2) => eq_mode (m, m2))
  9.1186 -            (modes1 ~~ modes2)
  9.1187 +          | EQUAL =>
  9.1188 +              forall (fn (_, NONE) => true | (m, SOME m2) => eq_mode (m, m2)) (modes1 ~~ modes2))
  9.1189          fun mode_instance_of (m1, m2) =
  9.1190            let
  9.1191              fun instance_of (Fun _, Input) = true
  9.1192 @@ -1779,12 +1834,14 @@
  9.1193                the_default true (Option.map (valid modes) param_user_modes)
  9.1194              end)
  9.1195            |> map fst
  9.1196 -        val deriv = case derivs of
  9.1197 -            [] => error ("No mode possible for comprehension "
  9.1198 -                    ^ Syntax.string_of_term ctxt t_compr)
  9.1199 +        val deriv =
  9.1200 +          (case derivs of
  9.1201 +            [] =>
  9.1202 +              error ("No mode possible for comprehension " ^ Syntax.string_of_term ctxt t_compr)
  9.1203            | [d] => d
  9.1204 -          | d :: _ :: _ => (warning ("Multiple modes possible for comprehension "
  9.1205 -                    ^ Syntax.string_of_term ctxt t_compr); d);
  9.1206 +          | d :: _ :: _ =>
  9.1207 +              (warning ("Multiple modes possible for comprehension " ^
  9.1208 +                Syntax.string_of_term ctxt t_compr); d))
  9.1209          val (_, outargs) = split_mode (head_mode_of deriv) all_args
  9.1210          val t_pred = compile_expr comp_modifiers ctxt
  9.1211            (body, deriv) [] additional_arguments;
  9.1212 @@ -1806,32 +1863,35 @@
  9.1213        in count' 0 xs end
  9.1214      fun accumulate xs = (map (fn x => (x, count xs x)) o sort int_ord o distinct (op =)) xs;
  9.1215      val comp_modifiers =
  9.1216 -      case compilation of
  9.1217 -          Pred => predicate_comp_modifiers
  9.1218 -        | Random => random_comp_modifiers
  9.1219 -        | Depth_Limited => depth_limited_comp_modifiers
  9.1220 -        | Depth_Limited_Random => depth_limited_random_comp_modifiers
  9.1221 -        (*| Annotated => annotated_comp_modifiers*)
  9.1222 -        | DSeq => dseq_comp_modifiers
  9.1223 -        | Pos_Random_DSeq => pos_random_dseq_comp_modifiers
  9.1224 -        | New_Pos_Random_DSeq => new_pos_random_dseq_comp_modifiers
  9.1225 -        | Pos_Generator_DSeq => pos_generator_dseq_comp_modifiers
  9.1226 +      (case compilation of
  9.1227 +        Pred => predicate_comp_modifiers
  9.1228 +      | Random => random_comp_modifiers
  9.1229 +      | Depth_Limited => depth_limited_comp_modifiers
  9.1230 +      | Depth_Limited_Random => depth_limited_random_comp_modifiers
  9.1231 +      (*| Annotated => annotated_comp_modifiers*)
  9.1232 +      | DSeq => dseq_comp_modifiers
  9.1233 +      | Pos_Random_DSeq => pos_random_dseq_comp_modifiers
  9.1234 +      | New_Pos_Random_DSeq => new_pos_random_dseq_comp_modifiers
  9.1235 +      | Pos_Generator_DSeq => pos_generator_dseq_comp_modifiers)
  9.1236      val compfuns = Comp_Mod.compfuns comp_modifiers
  9.1237      val additional_arguments =
  9.1238 -      case compilation of
  9.1239 +      (case compilation of
  9.1240          Pred => []
  9.1241 -      | Random => map (HOLogic.mk_number @{typ "natural"}) arguments @
  9.1242 -        [@{term "(1, 1) :: natural * natural"}]
  9.1243 +      | Random =>
  9.1244 +          map (HOLogic.mk_number @{typ "natural"}) arguments @
  9.1245 +            [@{term "(1, 1) :: natural * natural"}]
  9.1246        | Annotated => []
  9.1247        | Depth_Limited => [HOLogic.mk_number @{typ "natural"} (hd arguments)]
  9.1248 -      | Depth_Limited_Random => map (HOLogic.mk_number @{typ "natural"}) arguments @
  9.1249 -        [@{term "(1, 1) :: natural * natural"}]
  9.1250 +      | Depth_Limited_Random =>
  9.1251 +          map (HOLogic.mk_number @{typ "natural"}) arguments @
  9.1252 +            [@{term "(1, 1) :: natural * natural"}]
  9.1253        | DSeq => []
  9.1254        | Pos_Random_DSeq => []
  9.1255        | New_Pos_Random_DSeq => []
  9.1256 -      | Pos_Generator_DSeq => []
  9.1257 -    val t = analyze_compr ctxt (comp_modifiers, additional_arguments) param_user_modes options t_compr;
  9.1258 -    val T = dest_monadT compfuns (fastype_of t);
  9.1259 +      | Pos_Generator_DSeq => [])
  9.1260 +    val t =
  9.1261 +      analyze_compr ctxt (comp_modifiers, additional_arguments) param_user_modes options t_compr
  9.1262 +    val T = dest_monadT compfuns (fastype_of t)
  9.1263      val t' =
  9.1264        if stats andalso compilation = New_Pos_Random_DSeq then
  9.1265          mk_map compfuns T (HOLogic.mk_prodT (HOLogic.termT, @{typ natural}))
  9.1266 @@ -1891,7 +1951,7 @@
  9.1267                (TimeLimit.timeLimit time_limit (fn () => fst (Lazy_Sequence.yieldn k
  9.1268                  (Code_Runtime.dynamic_value_strict
  9.1269                    (Lseq_Random_Result.get, put_lseq_random_result, "Predicate_Compile_Core.put_lseq_random_result")
  9.1270 -                  thy NONE 
  9.1271 +                  thy NONE
  9.1272                    (fn proc => fn g => fn nrandom => fn size => fn s => fn depth => g nrandom size s depth
  9.1273                      |> Lazy_Sequence.map proc)
  9.1274                      t' [] nrandom size seed depth))) ())
  9.1275 @@ -1909,20 +1969,21 @@
  9.1276      val setT = HOLogic.mk_setT T
  9.1277      val elems = HOLogic.mk_set T ts
  9.1278      val ([dots], ctxt') =
  9.1279 -      Proof_Context.add_fixes [(@{binding dots}, SOME setT, Mixfix ("...", [], 1000))] ctxt 
  9.1280 +      Proof_Context.add_fixes [(@{binding dots}, SOME setT, Mixfix ("...", [], 1000))] ctxt
  9.1281      (* check expected values *)
  9.1282      val union = Const (@{const_abbrev Set.union}, setT --> setT --> setT)
  9.1283      val () =
  9.1284 -      case raw_expected of
  9.1285 +      (case raw_expected of
  9.1286          NONE => ()
  9.1287        | SOME s =>
  9.1288          if eq_set (op =) (HOLogic.dest_set (Syntax.read_term ctxt s), ts) then ()
  9.1289          else
  9.1290            error ("expected and computed values do not match:\n" ^
  9.1291              "expected values: " ^ Syntax.string_of_term ctxt (Syntax.read_term ctxt s) ^ "\n" ^
  9.1292 -            "computed values: " ^ Syntax.string_of_term ctxt elems ^ "\n")
  9.1293 +            "computed values: " ^ Syntax.string_of_term ctxt elems ^ "\n"))
  9.1294    in
  9.1295 -    ((if k = ~1 orelse length ts < k then elems else union $ elems $ Free (dots, setT), statistics), ctxt')
  9.1296 +    ((if k = ~1 orelse length ts < k then elems else union $ elems $ Free (dots, setT), statistics),
  9.1297 +      ctxt')
  9.1298    end;
  9.1299  
  9.1300  fun values_cmd print_modes param_user_modes options k raw_t state =
  9.1301 @@ -1933,9 +1994,9 @@
  9.1302      val ty' = Term.type_of t'
  9.1303      val ctxt'' = Variable.auto_fixes t' ctxt'
  9.1304      val pretty_stat =
  9.1305 -      case stats of
  9.1306 -          NONE => []
  9.1307 -        | SOME xs =>
  9.1308 +      (case stats of
  9.1309 +        NONE => []
  9.1310 +      | SOME xs =>
  9.1311            let
  9.1312              val total = fold (curry (op +)) (map snd xs) 0
  9.1313              fun pretty_entry (s, n) =
  9.1314 @@ -1944,13 +2005,14 @@
  9.1315                 Pretty.str (string_of_int n), Pretty.fbrk]
  9.1316            in
  9.1317              [Pretty.fbrk, Pretty.str "Statistics:", Pretty.fbrk,
  9.1318 -             Pretty.str "total:", Pretty.brk 1, Pretty.str (string_of_int total), Pretty.fbrk]
  9.1319 -             @ maps pretty_entry xs
  9.1320 -          end
  9.1321 -    val p = Print_Mode.with_modes print_modes (fn () =>
  9.1322 +             Pretty.str "total:", Pretty.brk 1, Pretty.str (string_of_int total), Pretty.fbrk] @
  9.1323 +              maps pretty_entry xs
  9.1324 +          end)
  9.1325 +  in
  9.1326 +    Print_Mode.with_modes print_modes (fn () =>
  9.1327        Pretty.block ([Pretty.quote (Syntax.pretty_term ctxt'' t'), Pretty.fbrk,
  9.1328          Pretty.str "::", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt'' ty')]
  9.1329 -        @ pretty_stat)) ();
  9.1330 -  in Pretty.writeln p end;
  9.1331 +        @ pretty_stat)) ()
  9.1332 +  end |> Pretty.writeln
  9.1333  
  9.1334 -end;
  9.1335 +end
    10.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML	Wed Feb 12 10:59:25 2014 +0100
    10.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML	Wed Feb 12 14:32:45 2014 +0100
    10.3 @@ -11,11 +11,11 @@
    10.4    val keep_function : theory -> string -> bool
    10.5    val processed_specs : theory -> string -> (string * thm list) list option
    10.6    val store_processed_specs : (string * (string * thm list) list) -> theory -> theory
    10.7 -  
    10.8 +
    10.9    val get_specification : Predicate_Compile_Aux.options -> theory -> term -> thm list
   10.10    val obtain_specification_graph :
   10.11      Predicate_Compile_Aux.options -> theory -> term -> thm list Term_Graph.T
   10.12 -    
   10.13 +
   10.14    val present_graph : thm list Term_Graph.T -> unit
   10.15    val normalize_equation : theory -> thm -> thm
   10.16  end;
   10.17 @@ -66,7 +66,7 @@
   10.18    let
   10.19      val _ $ u = Logic.strip_imp_concl t
   10.20    in fst (strip_comb u) end
   10.21 -(*  
   10.22 +(*
   10.23    in case pred of
   10.24      Const (c, T) => c
   10.25      | _ => raise TERM ("defining_const_of_introrule_term failed: Not a constant", [t])
   10.26 @@ -75,9 +75,9 @@
   10.27  val defining_term_of_introrule = defining_term_of_introrule_term o prop_of
   10.28  
   10.29  fun defining_const_of_introrule th =
   10.30 -  case defining_term_of_introrule th
   10.31 -   of Const (c, _) => c
   10.32 -    | _ => raise TERM ("defining_const_of_introrule failed: Not a constant", [prop_of th])
   10.33 +  (case defining_term_of_introrule th of
   10.34 +    Const (c, _) => c
   10.35 +  | _ => raise TERM ("defining_const_of_introrule failed: Not a constant", [prop_of th]))
   10.36  
   10.37  (*TODO*)
   10.38  fun is_introlike_term _ = true
   10.39 @@ -85,29 +85,29 @@
   10.40  val is_introlike = is_introlike_term o prop_of
   10.41  
   10.42  fun check_equation_format_term (t as (Const ("==", _) $ u $ _)) =
   10.43 -  (case strip_comb u of
   10.44 -    (Const (_, T), args) =>
   10.45 -      if (length (binder_types T) = length args) then
   10.46 -        true
   10.47 -      else
   10.48 -        raise TERM ("check_equation_format_term failed: Number of arguments mismatch", [t])
   10.49 -  | _ => raise TERM ("check_equation_format_term failed: Not a constant", [t]))
   10.50 +      (case strip_comb u of
   10.51 +        (Const (_, T), args) =>
   10.52 +          if (length (binder_types T) = length args) then
   10.53 +            true
   10.54 +          else
   10.55 +            raise TERM ("check_equation_format_term failed: Number of arguments mismatch", [t])
   10.56 +      | _ => raise TERM ("check_equation_format_term failed: Not a constant", [t]))
   10.57    | check_equation_format_term t =
   10.58 -    raise TERM ("check_equation_format_term failed: Not an equation", [t])
   10.59 +      raise TERM ("check_equation_format_term failed: Not an equation", [t])
   10.60  
   10.61  val check_equation_format = check_equation_format_term o prop_of
   10.62  
   10.63  
   10.64  fun defining_term_of_equation_term (Const ("==", _) $ u $ _) = fst (strip_comb u)
   10.65    | defining_term_of_equation_term t =
   10.66 -    raise TERM ("defining_const_of_equation_term failed: Not an equation", [t])
   10.67 +      raise TERM ("defining_const_of_equation_term failed: Not an equation", [t])
   10.68  
   10.69  val defining_term_of_equation = defining_term_of_equation_term o prop_of
   10.70  
   10.71  fun defining_const_of_equation th =
   10.72 -  case defining_term_of_equation th
   10.73 -   of Const (c, _) => c
   10.74 -    | _ => raise TERM ("defining_const_of_equation failed: Not a constant", [prop_of th])
   10.75 +  (case defining_term_of_equation th of
   10.76 +    Const (c, _) => c
   10.77 +  | _ => raise TERM ("defining_const_of_equation failed: Not a constant", [prop_of th]))
   10.78  
   10.79  
   10.80  
   10.81 @@ -115,9 +115,10 @@
   10.82  (* Normalizing equations *)
   10.83  
   10.84  fun mk_meta_equation th =
   10.85 -  case prop_of th of
   10.86 -    Const (@{const_name Trueprop}, _) $ (Const (@{const_name HOL.eq}, _) $ _ $ _) => th RS @{thm eq_reflection}
   10.87 -  | _ => th
   10.88 +  (case prop_of th of
   10.89 +    Const (@{const_name Trueprop}, _) $ (Const (@{const_name HOL.eq}, _) $ _ $ _) =>
   10.90 +      th RS @{thm eq_reflection}
   10.91 +  | _ => th)
   10.92  
   10.93  val meta_fun_cong = @{lemma "f == g ==> f x == g x" by simp}
   10.94  
   10.95 @@ -131,13 +132,13 @@
   10.96    let
   10.97      val res = Name.invent_names ctxt s xs
   10.98    in (res, fold Name.declare (map fst res) ctxt) end
   10.99 -  
  10.100 +
  10.101  fun split_all_pairs thy th =
  10.102    let
  10.103      val ctxt = Proof_Context.init_global thy  (* FIXME proper context!? *)
  10.104      val ((_, [th']), _) = Variable.import true [th] ctxt
  10.105      val t = prop_of th'
  10.106 -    val frees = Term.add_frees t [] 
  10.107 +    val frees = Term.add_frees t []
  10.108      val freenames = Term.add_free_names t []
  10.109      val nctxt = Name.make_context freenames
  10.110      fun mk_tuple_rewrites (x, T) nctxt =
  10.111 @@ -146,7 +147,7 @@
  10.112          val (xTs, nctxt') = declare_names x Ts nctxt
  10.113          val paths = HOLogic.flat_tupleT_paths T
  10.114        in ((Free (x, T), HOLogic.mk_ptuple paths T (map Free xTs)), nctxt') end
  10.115 -    val (rewr, _) = fold_map mk_tuple_rewrites frees nctxt 
  10.116 +    val (rewr, _) = fold_map mk_tuple_rewrites frees nctxt
  10.117      val t' = Pattern.rewrite_term thy rewr [] t
  10.118      val th'' =
  10.119        Goal.prove ctxt (Term.add_free_names t' []) [] t'
  10.120 @@ -162,7 +163,7 @@
  10.121      val ctxt = Proof_Context.init_global thy
  10.122      val inline_defs = Predicate_Compile_Inline_Defs.get ctxt
  10.123      val th' = (Simplifier.full_simplify (put_simpset HOL_basic_ss ctxt addsimps inline_defs)) th
  10.124 -    (*val _ = print_step options 
  10.125 +    (*val _ = print_step options
  10.126        ("Inlining " ^ (Syntax.string_of_term_global thy (prop_of th))
  10.127         ^ "with " ^ (commas (map ((Syntax.string_of_term_global thy) o prop_of) inline_defs))
  10.128         ^" to " ^ (Syntax.string_of_term_global thy (prop_of th')))*)
  10.129 @@ -206,11 +207,13 @@
  10.130          else
  10.131            NONE
  10.132      fun filter_defs ths = map_filter filtering (map (normalize thy o Thm.transfer thy) ths)
  10.133 -    val spec = case filter_defs (Predicate_Compile_Alternative_Defs.get ctxt) of
  10.134 -      [] => (case Spec_Rules.retrieve ctxt t of
  10.135 -          [] => error ("No specification for " ^ (Syntax.string_of_term_global thy t))
  10.136 -        | ((_, (_, ths)) :: _) => filter_defs ths)
  10.137 -    | ths => rev ths
  10.138 +    val spec =
  10.139 +      (case filter_defs (Predicate_Compile_Alternative_Defs.get ctxt) of
  10.140 +        [] =>
  10.141 +          (case Spec_Rules.retrieve ctxt t of
  10.142 +            [] => error ("No specification for " ^ Syntax.string_of_term_global thy t)
  10.143 +          | ((_, (_, ths)) :: _) => filter_defs ths)
  10.144 +      | ths => rev ths)
  10.145      val _ =
  10.146        if show_intermediate_results options then
  10.147          tracing ("Specification for " ^ (Syntax.string_of_term_global thy t) ^ ":\n" ^
  10.148 @@ -221,38 +224,38 @@
  10.149    end
  10.150  
  10.151  val logic_operator_names =
  10.152 -  [@{const_name "=="}, 
  10.153 +  [@{const_name "=="},
  10.154     @{const_name "==>"},
  10.155     @{const_name Trueprop},
  10.156     @{const_name Not},
  10.157     @{const_name HOL.eq},
  10.158     @{const_name HOL.implies},
  10.159     @{const_name All},
  10.160 -   @{const_name Ex}, 
  10.161 +   @{const_name Ex},
  10.162     @{const_name HOL.conj},
  10.163     @{const_name HOL.disj}]
  10.164  
  10.165 -fun special_cases (c, _) = member (op =) [
  10.166 -  @{const_name Product_Type.Unity},
  10.167 -  @{const_name False},
  10.168 -  @{const_name Suc}, @{const_name Nat.zero_nat_inst.zero_nat},
  10.169 -  @{const_name Nat.one_nat_inst.one_nat},
  10.170 -  @{const_name Orderings.less}, @{const_name Orderings.less_eq},
  10.171 -  @{const_name Groups.zero},
  10.172 -  @{const_name Groups.one},  @{const_name Groups.plus},
  10.173 -  @{const_name Nat.ord_nat_inst.less_eq_nat},
  10.174 -  @{const_name Nat.ord_nat_inst.less_nat},
  10.175 -(* FIXME
  10.176 -  @{const_name number_nat_inst.number_of_nat},
  10.177 -*)
  10.178 -  @{const_name Num.Bit0},
  10.179 -  @{const_name Num.Bit1},
  10.180 -  @{const_name Num.One},
  10.181 -  @{const_name Int.zero_int_inst.zero_int},
  10.182 -  @{const_name List.filter},
  10.183 -  @{const_name HOL.If},
  10.184 -  @{const_name Groups.minus}
  10.185 -  ] c
  10.186 +fun special_cases (c, _) =
  10.187 +  member (op =)
  10.188 +   [@{const_name Product_Type.Unity},
  10.189 +    @{const_name False},
  10.190 +    @{const_name Suc}, @{const_name Nat.zero_nat_inst.zero_nat},
  10.191 +    @{const_name Nat.one_nat_inst.one_nat},
  10.192 +    @{const_name Orderings.less}, @{const_name Orderings.less_eq},
  10.193 +    @{const_name Groups.zero},
  10.194 +    @{const_name Groups.one},  @{const_name Groups.plus},
  10.195 +    @{const_name Nat.ord_nat_inst.less_eq_nat},
  10.196 +    @{const_name Nat.ord_nat_inst.less_nat},
  10.197 +  (* FIXME
  10.198 +    @{const_name number_nat_inst.number_of_nat},
  10.199 +  *)
  10.200 +    @{const_name Num.Bit0},
  10.201 +    @{const_name Num.Bit1},
  10.202 +    @{const_name Num.One},
  10.203 +    @{const_name Int.zero_int_inst.zero_int},
  10.204 +    @{const_name List.filter},
  10.205 +    @{const_name HOL.If},
  10.206 +    @{const_name Groups.minus}] c
  10.207  
  10.208  
  10.209  fun obtain_specification_graph options thy t =
  10.210 @@ -309,13 +312,12 @@
  10.211        |> map (the o Termtab.lookup mapping)
  10.212        |> distinct (eq_list eq_cname);
  10.213      val conn = [] |> fold (fn consts => cons (consts, succs consts)) constss;
  10.214 -    
  10.215 +
  10.216      fun namify consts = map string_of_const consts
  10.217        |> commas;
  10.218      val prgr = map (fn (consts, constss) =>
  10.219 -      { name = namify consts, ID = namify consts, dir = "", unfold = true,
  10.220 -        path = "", parents = map namify constss, content = [] }) conn;
  10.221 -  in Graph_Display.display_graph prgr end;
  10.222 +      {name = namify consts, ID = namify consts, dir = "", unfold = true,
  10.223 +       path = "", parents = map namify constss, content = [] }) conn
  10.224 +  in Graph_Display.display_graph prgr end
  10.225  
  10.226 -
  10.227 -end;
  10.228 +end
    11.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_fun.ML	Wed Feb 12 10:59:25 2014 +0100
    11.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_fun.ML	Wed Feb 12 14:32:45 2014 +0100
    11.3 @@ -32,16 +32,16 @@
    11.4      SOME (Envir.subst_term (Pattern.match thy (f, t) (Vartab.empty, Vartab.empty)) p)
    11.5      handle Pattern.MATCH => NONE) (Item_Net.retrieve net t)
    11.6    in
    11.7 -    case poss_preds of
    11.8 +    (case poss_preds of
    11.9        [p] => SOME p
   11.10 -    | _ => NONE
   11.11 +    | _ => NONE)
   11.12    end
   11.13  
   11.14  fun pred_of_function thy name =
   11.15 -  case Item_Net.retrieve (Fun_Pred.get thy) (Const (name, dummyT)) of
   11.16 +  (case Item_Net.retrieve (Fun_Pred.get thy) (Const (name, dummyT)) of
   11.17      [] => NONE
   11.18    | [(_, p)] => SOME (fst (dest_Const p))
   11.19 -  | _ => error ("Multiple matches possible for lookup of constant " ^ name)
   11.20 +  | _ => error ("Multiple matches possible for lookup of constant " ^ name))
   11.21  
   11.22  fun defined_const thy name = is_some (pred_of_function thy name)
   11.23  
   11.24 @@ -49,18 +49,18 @@
   11.25    Fun_Pred.map (Item_Net.update (f, p))
   11.26  
   11.27  fun transform_ho_typ (T as Type ("fun", _)) =
   11.28 -  let
   11.29 -    val (Ts, T') = strip_type T
   11.30 -  in if T' = HOLogic.boolT then T else (Ts @ [T']) ---> HOLogic.boolT end
   11.31 -| transform_ho_typ t = t
   11.32 +      let
   11.33 +        val (Ts, T') = strip_type T
   11.34 +      in if T' = HOLogic.boolT then T else (Ts @ [T']) ---> HOLogic.boolT end
   11.35 +  | transform_ho_typ t = t
   11.36  
   11.37 -fun transform_ho_arg arg = 
   11.38 -  case (fastype_of arg) of
   11.39 +fun transform_ho_arg arg =
   11.40 +  (case (fastype_of arg) of
   11.41      (T as Type ("fun", _)) =>
   11.42        (case arg of
   11.43          Free (name, _) => Free (name, transform_ho_typ T)
   11.44        | _ => raise Fail "A non-variable term at a higher-order position")
   11.45 -  | _ => arg
   11.46 +  | _ => arg)
   11.47  
   11.48  fun pred_type T =
   11.49    let
   11.50 @@ -88,43 +88,43 @@
   11.51      end;
   11.52  
   11.53  fun keep_functions thy t =
   11.54 -  case try dest_Const (fst (strip_comb t)) of
   11.55 +  (case try dest_Const (fst (strip_comb t)) of
   11.56      SOME (c, _) => Predicate_Compile_Data.keep_function thy c
   11.57 -  | _ => false
   11.58 +  | _ => false)
   11.59  
   11.60  fun flatten thy lookup_pred t (names, prems) =
   11.61    let
   11.62      fun lift t (names, prems) =
   11.63 -      case lookup_pred (Envir.eta_contract t) of
   11.64 +      (case lookup_pred (Envir.eta_contract t) of
   11.65          SOME pred => [(pred, (names, prems))]
   11.66        | NONE =>
   11.67 -        let
   11.68 -          val (vars, body) = strip_abs t
   11.69 -          val _ = @{assert} (fastype_of body = body_type (fastype_of body))
   11.70 -          val absnames = Name.variant_list names (map fst vars)
   11.71 -          val frees = map2 (curry Free) absnames (map snd vars)
   11.72 -          val body' = subst_bounds (rev frees, body)
   11.73 -          val resname = singleton (Name.variant_list (absnames @ names)) "res"
   11.74 -          val resvar = Free (resname, fastype_of body)
   11.75 -          val t = flatten' body' ([], [])
   11.76 -            |> map (fn (res, (inner_names, inner_prems)) =>
   11.77 -              let
   11.78 -                fun mk_exists (x, T) t = HOLogic.mk_exists (x, T, t)
   11.79 -                val vTs = 
   11.80 -                  fold Term.add_frees inner_prems []
   11.81 -                  |> filter (fn (x, _) => member (op =) inner_names x)
   11.82 -                val t = 
   11.83 -                  fold mk_exists vTs
   11.84 -                  (foldr1 HOLogic.mk_conj (HOLogic.mk_eq (res, resvar) ::
   11.85 -                    map HOLogic.dest_Trueprop inner_prems))
   11.86 -              in
   11.87 -                t
   11.88 -              end)
   11.89 -              |> foldr1 HOLogic.mk_disj
   11.90 -              |> fold lambda (resvar :: rev frees)
   11.91 -        in
   11.92 -          [(t, (names, prems))]
   11.93 -        end
   11.94 +          let
   11.95 +            val (vars, body) = strip_abs t
   11.96 +            val _ = @{assert} (fastype_of body = body_type (fastype_of body))
   11.97 +            val absnames = Name.variant_list names (map fst vars)
   11.98 +            val frees = map2 (curry Free) absnames (map snd vars)
   11.99 +            val body' = subst_bounds (rev frees, body)
  11.100 +            val resname = singleton (Name.variant_list (absnames @ names)) "res"
  11.101 +            val resvar = Free (resname, fastype_of body)
  11.102 +            val t = flatten' body' ([], [])
  11.103 +              |> map (fn (res, (inner_names, inner_prems)) =>
  11.104 +                let
  11.105 +                  fun mk_exists (x, T) t = HOLogic.mk_exists (x, T, t)
  11.106 +                  val vTs =
  11.107 +                    fold Term.add_frees inner_prems []
  11.108 +                    |> filter (fn (x, _) => member (op =) inner_names x)
  11.109 +                  val t =
  11.110 +                    fold mk_exists vTs
  11.111 +                    (foldr1 HOLogic.mk_conj (HOLogic.mk_eq (res, resvar) ::
  11.112 +                      map HOLogic.dest_Trueprop inner_prems))
  11.113 +                in
  11.114 +                  t
  11.115 +                end)
  11.116 +                |> foldr1 HOLogic.mk_disj
  11.117 +                |> fold lambda (resvar :: rev frees)
  11.118 +          in
  11.119 +            [(t, (names, prems))]
  11.120 +          end)
  11.121      and flatten_or_lift (t, T) (names, prems) =
  11.122        if fastype_of t = T then
  11.123          flatten' t (names, prems)
  11.124 @@ -134,7 +134,7 @@
  11.125            lift t (names, prems)
  11.126          else
  11.127            error ("unexpected input for flatten or lift" ^ Syntax.string_of_term_global thy t ^
  11.128 -          ", " ^  Syntax.string_of_typ_global thy T)
  11.129 +            ", " ^  Syntax.string_of_typ_global thy T)
  11.130      and flatten' (t as Const _) (names, prems) = [(t, (names, prems))]
  11.131        | flatten' (t as Free _) (names, prems) = [(t, (names, prems))]
  11.132        | flatten' (t as Abs _) (names, prems) = [(t, (names, prems))]
  11.133 @@ -156,7 +156,7 @@
  11.134                    (* in general unsound! *)
  11.135                    (res, (names, (HOLogic.mk_Trueprop (HOLogic.mk_not B')) :: prems)))))
  11.136              end)
  11.137 -        | Const (@{const_name "Let"}, _) => 
  11.138 +        | Const (@{const_name "Let"}, _) =>
  11.139              (let
  11.140                val (_, [f, g]) = strip_comb t
  11.141              in
  11.142 @@ -199,9 +199,10 @@
  11.143              val args = map (Envir.eta_long []) args
  11.144              val _ = @{assert} (fastype_of t = body_type (fastype_of t))
  11.145              val f' = lookup_pred f
  11.146 -            val Ts = case f' of
  11.147 -              SOME pred => (fst (split_last (binder_types (fastype_of pred))))
  11.148 -            | NONE => binder_types (fastype_of f)
  11.149 +            val Ts =
  11.150 +              (case f' of
  11.151 +                SOME pred => (fst (split_last (binder_types (fastype_of pred))))
  11.152 +              | NONE => binder_types (fastype_of f))
  11.153            in
  11.154              folds_map flatten_or_lift (args ~~ Ts) (names, prems) |>
  11.155              (case f' of
  11.156 @@ -272,7 +273,8 @@
  11.157        fun mk_intros ((func, pred), (args, rhs)) =
  11.158          if (body_type (fastype_of func) = @{typ bool}) then
  11.159           (* TODO: preprocess predicate definition of rhs *)
  11.160 -          [Logic.list_implies ([HOLogic.mk_Trueprop rhs], HOLogic.mk_Trueprop (list_comb (pred, args)))]
  11.161 +          [Logic.list_implies
  11.162 +            ([HOLogic.mk_Trueprop rhs], HOLogic.mk_Trueprop (list_comb (pred, args)))]
  11.163          else
  11.164            let
  11.165              val names = Term.add_free_names rhs []
  11.166 @@ -316,9 +318,10 @@
  11.167        let
  11.168          (*val _ = tracing ("Rewriting premise " ^ Syntax.string_of_term_global thy prem ^ "...")*)
  11.169          val t = HOLogic.dest_Trueprop prem
  11.170 -        val (lit, mk_lit) = case try HOLogic.dest_not t of
  11.171 +        val (lit, mk_lit) =
  11.172 +          (case try HOLogic.dest_not t of
  11.173              SOME t => (t, HOLogic.mk_not)
  11.174 -          | NONE => (t, I)
  11.175 +          | NONE => (t, I))
  11.176          val (P, args) = strip_comb lit
  11.177        in
  11.178          folds_map (flatten thy lookup_pred) args (names, [])
  11.179 @@ -342,4 +345,4 @@
  11.180      map (Drule.export_without_context o Skip_Proof.make_thm thy) intro_ts'
  11.181    end
  11.182  
  11.183 -end;
  11.184 +end
    12.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_pred.ML	Wed Feb 12 10:59:25 2014 +0100
    12.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_pred.ML	Wed Feb 12 14:32:45 2014 +0100
    12.3 @@ -20,15 +20,15 @@
    12.4  open Predicate_Compile_Aux
    12.5  
    12.6  fun is_compound ((Const (@{const_name Not}, _)) $ _) =
    12.7 -    error "is_compound: Negation should not occur; preprocessing is defect"
    12.8 +      error "is_compound: Negation should not occur; preprocessing is defect"
    12.9    | is_compound ((Const (@{const_name Ex}, _)) $ _) = true
   12.10    | is_compound ((Const (@{const_name HOL.disj}, _)) $ _ $ _) = true
   12.11    | is_compound ((Const (@{const_name HOL.conj}, _)) $ _ $ _) =
   12.12 -    error "is_compound: Conjunction should not occur; preprocessing is defect"
   12.13 +      error "is_compound: Conjunction should not occur; preprocessing is defect"
   12.14    | is_compound _ = false
   12.15  
   12.16  fun try_destruct_case thy names atom =
   12.17 -  case find_split_thm thy (fst (strip_comb atom)) of
   12.18 +  (case find_split_thm thy (fst (strip_comb atom)) of
   12.19      NONE => NONE
   12.20    | SOME raw_split_thm =>
   12.21      let
   12.22 @@ -48,17 +48,17 @@
   12.23            val vars = map Free (var_names ~~ (map snd vTs))
   12.24            val (prems', pre_res) = Logic.strip_horn (subst_bounds (rev vars, assm'))
   12.25            fun partition_prem_subst prem =
   12.26 -            case HOLogic.dest_eq (HOLogic.dest_Trueprop prem) of
   12.27 +            (case HOLogic.dest_eq (HOLogic.dest_Trueprop prem) of
   12.28                (Free (x, T), r) => (NONE, SOME ((x, T), r))
   12.29 -            | _ => (SOME prem, NONE)
   12.30 +            | _ => (SOME prem, NONE))
   12.31            fun partition f xs =
   12.32              let
   12.33                fun partition' acc1 acc2 [] = (rev acc1, rev acc2)
   12.34                  | partition' acc1 acc2 (x :: xs) =
   12.35                    let
   12.36                      val (y, z) = f x
   12.37 -                    val acc1' = case y of NONE => acc1 | SOME y' => y' :: acc1
   12.38 -                    val acc2' = case z of NONE => acc2 | SOME z' => z' :: acc2
   12.39 +                    val acc1' = (case y of NONE => acc1 | SOME y' => y' :: acc1)
   12.40 +                    val acc2' = (case z of NONE => acc2 | SOME z' => z' :: acc2)
   12.41                    in partition' acc1' acc2' xs end
   12.42              in partition' [] [] xs end
   12.43            val (prems'', subst) = partition partition_prem_subst prems'
   12.44 @@ -67,18 +67,19 @@
   12.45              fold (curry HOLogic.mk_conj) (map HOLogic.dest_Trueprop prems'') inner_t
   12.46            val rhs = Envir.expand_term_frees subst pre_rhs
   12.47          in
   12.48 -          case try_destruct_case thy (var_names @ names') rhs of
   12.49 +          (case try_destruct_case thy (var_names @ names') rhs of
   12.50              NONE => [(subst, rhs)]
   12.51 -          | SOME (_, srs) => map (fn (subst', rhs') => (subst @ subst', rhs')) srs
   12.52 +          | SOME (_, srs) => map (fn (subst', rhs') => (subst @ subst', rhs')) srs)
   12.53          end
   12.54 -     in SOME (atom', maps mk_subst_rhs assms) end
   12.55 +     in SOME (atom', maps mk_subst_rhs assms) end)
   12.56       
   12.57  fun flatten constname atom (defs, thy) =
   12.58    if is_compound atom then
   12.59      let
   12.60        val atom = Envir.beta_norm (Envir.eta_long [] atom)
   12.61 -      val constname = singleton (Name.variant_list (map (Long_Name.base_name o fst) defs))
   12.62 -        ((Long_Name.base_name constname) ^ "_aux")
   12.63 +      val constname =
   12.64 +        singleton (Name.variant_list (map (Long_Name.base_name o fst) defs))
   12.65 +          ((Long_Name.base_name constname) ^ "_aux")
   12.66        val full_constname = Sign.full_bname thy constname
   12.67        val (params, args) = List.partition (is_predT o fastype_of)
   12.68          (map Free (Term.add_frees atom []))
   12.69 @@ -92,7 +93,7 @@
   12.70        (lhs, ((full_constname, [definition]) :: defs, thy'))
   12.71      end
   12.72    else
   12.73 -    case (fst (strip_comb atom)) of
   12.74 +    (case (fst (strip_comb atom)) of
   12.75        (Const (@{const_name If}, _)) =>
   12.76          let
   12.77            val if_beta = @{lemma "(if c then x else y) z = (if c then x z else y z)" by simp}
   12.78 @@ -103,28 +104,28 @@
   12.79            flatten constname atom' (defs, thy)
   12.80          end
   12.81      | _ =>
   12.82 -      case try_destruct_case thy [] atom of
   12.83 -        NONE => (atom, (defs, thy))
   12.84 -      | SOME (atom', srs) =>
   12.85 -        let      
   12.86 -          val frees = map Free (Term.add_frees atom' [])
   12.87 -          val constname = singleton (Name.variant_list (map (Long_Name.base_name o fst) defs))
   12.88 -           ((Long_Name.base_name constname) ^ "_aux")
   12.89 -          val full_constname = Sign.full_bname thy constname
   12.90 -          val constT = map fastype_of frees ---> HOLogic.boolT
   12.91 -          val lhs = list_comb (Const (full_constname, constT), frees)
   12.92 -          fun mk_def (subst, rhs) =
   12.93 -            Logic.mk_equals (fold Envir.expand_term_frees (map single subst) lhs, rhs)
   12.94 -          val new_defs = map mk_def srs
   12.95 -          val (definition, thy') = thy
   12.96 -          |> Sign.add_consts_i [(Binding.name constname, constT, NoSyn)]
   12.97 -          |> fold_map Specification.axiom  (* FIXME !?!?!?! *)
   12.98 -            (map_index (fn (i, t) =>
   12.99 -              ((Binding.name (constname ^ "_def" ^ string_of_int i), []), t)) new_defs)
  12.100 -        in
  12.101 -          (lhs, ((full_constname, map Drule.export_without_context definition) :: defs, thy'))
  12.102 -        end
  12.103 -
  12.104 +        (case try_destruct_case thy [] atom of
  12.105 +          NONE => (atom, (defs, thy))
  12.106 +        | SOME (atom', srs) =>
  12.107 +            let      
  12.108 +              val frees = map Free (Term.add_frees atom' [])
  12.109 +              val constname =
  12.110 +                singleton (Name.variant_list (map (Long_Name.base_name o fst) defs))
  12.111 +                  ((Long_Name.base_name constname) ^ "_aux")
  12.112 +              val full_constname = Sign.full_bname thy constname
  12.113 +              val constT = map fastype_of frees ---> HOLogic.boolT
  12.114 +              val lhs = list_comb (Const (full_constname, constT), frees)
  12.115 +              fun mk_def (subst, rhs) =
  12.116 +                Logic.mk_equals (fold Envir.expand_term_frees (map single subst) lhs, rhs)
  12.117 +              val new_defs = map mk_def srs
  12.118 +              val (definition, thy') = thy
  12.119 +              |> Sign.add_consts_i [(Binding.name constname, constT, NoSyn)]
  12.120 +              |> fold_map Specification.axiom  (* FIXME !?!?!?! *)
  12.121 +                (map_index (fn (i, t) =>
  12.122 +                  ((Binding.name (constname ^ "_def" ^ string_of_int i), []), t)) new_defs)
  12.123 +            in
  12.124 +              (lhs, ((full_constname, map Drule.export_without_context definition) :: defs, thy'))
  12.125 +            end))
  12.126  
  12.127  fun flatten_intros constname intros thy =
  12.128    let
  12.129 @@ -143,7 +144,7 @@
  12.130  (* TODO: same function occurs in inductive package *)
  12.131  fun select_disj 1 1 = []
  12.132    | select_disj _ 1 = [rtac @{thm disjI1}]
  12.133 -  | select_disj n i = (rtac @{thm disjI2})::(select_disj (n - 1) (i - 1));
  12.134 +  | select_disj n i = (rtac @{thm disjI2})::(select_disj (n - 1) (i - 1))
  12.135  
  12.136  fun introrulify thy ths = 
  12.137    let
  12.138 @@ -258,8 +259,9 @@
  12.139                  |> process constname t1 
  12.140                  ||>> process constname t2
  12.141                  |>> HOLogic.mk_prod
  12.142 -            | NONE => (warning ("Replacing higher order arguments " ^
  12.143 -              "is not applied in an undestructable product type"); (arg, (new_defs, thy))))
  12.144 +            | NONE =>
  12.145 +              (warning ("Replacing higher order arguments " ^
  12.146 +                "is not applied in an undestructable product type"); (arg, (new_defs, thy))))
  12.147            else if (is_predT (fastype_of arg)) then
  12.148              process constname arg (new_defs, thy)
  12.149            else
  12.150 @@ -274,7 +276,8 @@
  12.151        let
  12.152          val constname = fst (dest_Const (fst (strip_comb
  12.153            (HOLogic.dest_Trueprop (Logic.strip_imp_concl (prop_of intro))))))
  12.154 -        val (intro_ts, (new_defs, thy)) = fold_map_atoms (process constname) (prop_of intro) (new_defs, thy)
  12.155 +        val (intro_ts, (new_defs, thy)) =
  12.156 +          fold_map_atoms (process constname) (prop_of intro) (new_defs, thy)
  12.157          val th = Skip_Proof.make_thm thy intro_ts
  12.158        in
  12.159          (th, (new_defs, thy))
  12.160 @@ -290,4 +293,4 @@
  12.161      (intross', (new_defs, thy'))
  12.162    end
  12.163  
  12.164 -end;
  12.165 +end
    13.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_proof.ML	Wed Feb 12 10:59:25 2014 +0100
    13.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_proof.ML	Wed Feb 12 14:32:45 2014 +0100
    13.3 @@ -22,28 +22,34 @@
    13.4  open Core_Data;
    13.5  open Mode_Inference;
    13.6  
    13.7 +
    13.8  (* debug stuff *)
    13.9  
   13.10  fun print_tac options s = 
   13.11    if show_proof_trace options then Tactical.print_tac s else Seq.single;
   13.12  
   13.13 +
   13.14  (** auxiliary **)
   13.15  
   13.16  datatype assertion = Max_number_of_subgoals of int
   13.17 +
   13.18  fun assert_tac (Max_number_of_subgoals i) st =
   13.19    if (nprems_of st <= i) then Seq.single st
   13.20 -  else raise Fail ("assert_tac: Numbers of subgoals mismatch at goal state :"
   13.21 -    ^ "\n" ^ Pretty.string_of (Pretty.chunks
   13.22 -      (Goal_Display.pretty_goals_without_context st)));
   13.23 +  else
   13.24 +    raise Fail ("assert_tac: Numbers of subgoals mismatch at goal state :\n" ^
   13.25 +      Pretty.string_of (Pretty.chunks
   13.26 +        (Goal_Display.pretty_goals_without_context st)))
   13.27  
   13.28  
   13.29  (** special setup for simpset **)
   13.30 +
   13.31  val HOL_basic_ss' =
   13.32    simpset_of (put_simpset HOL_basic_ss @{context}
   13.33      addsimps @{thms simp_thms Pair_eq}
   13.34      setSolver (mk_solver "all_tac_solver" (fn _ => fn _ => all_tac))
   13.35      setSolver (mk_solver "True_solver" (fn _ => rtac @{thm TrueI})))
   13.36  
   13.37 +
   13.38  (* auxillary functions *)
   13.39  
   13.40  (* returns true if t is an application of a datatype constructor *)
   13.41 @@ -51,7 +57,7 @@
   13.42  fun is_constructor ctxt t =
   13.43    (case fastype_of t of
   13.44      Type (s, _) => s <> @{type_name fun} andalso can (Ctr_Sugar.dest_ctr ctxt s) t
   13.45 -  | _ => false);
   13.46 +  | _ => false)
   13.47  
   13.48  (* MAJOR FIXME:  prove_params should be simple
   13.49   - different form of introrule for parameters ? *)
   13.50 @@ -62,19 +68,20 @@
   13.51      val mode = head_mode_of deriv
   13.52      val param_derivations = param_derivations_of deriv
   13.53      val ho_args = ho_args_of mode args
   13.54 -    val f_tac = case f of
   13.55 -      Const (name, _) => simp_tac (put_simpset HOL_basic_ss ctxt addsimps
   13.56 -         [@{thm eval_pred}, predfun_definition_of ctxt name mode,
   13.57 -         @{thm split_eta}, @{thm split_beta}, @{thm fst_conv},
   13.58 -         @{thm snd_conv}, @{thm pair_collapse}, @{thm Product_Type.split_conv}]) 1
   13.59 -    | Free _ =>
   13.60 -      Subgoal.FOCUS_PREMS (fn {context = ctxt', params = params, prems, asms, concl, schematics} =>
   13.61 -        let
   13.62 -          val prems' = maps dest_conjunct_prem (take nargs prems)
   13.63 -        in
   13.64 -          rewrite_goal_tac ctxt' (map (fn th => th RS @{thm sym} RS @{thm eq_reflection}) prems') 1
   13.65 -        end) ctxt 1
   13.66 -    | Abs _ => raise Fail "prove_param: No valid parameter term"
   13.67 +    val f_tac =
   13.68 +      (case f of
   13.69 +        Const (name, _) => simp_tac (put_simpset HOL_basic_ss ctxt addsimps
   13.70 +           [@{thm eval_pred}, predfun_definition_of ctxt name mode,
   13.71 +           @{thm split_eta}, @{thm split_beta}, @{thm fst_conv},
   13.72 +           @{thm snd_conv}, @{thm pair_collapse}, @{thm Product_Type.split_conv}]) 1
   13.73 +      | Free _ =>
   13.74 +        Subgoal.FOCUS_PREMS (fn {context = ctxt', params = params, prems, asms, concl, schematics} =>
   13.75 +          let
   13.76 +            val prems' = maps dest_conjunct_prem (take nargs prems)
   13.77 +          in
   13.78 +            rewrite_goal_tac ctxt' (map (fn th => th RS @{thm sym} RS @{thm eq_reflection}) prems') 1
   13.79 +          end) ctxt 1
   13.80 +      | Abs _ => raise Fail "prove_param: No valid parameter term")
   13.81    in
   13.82      REPEAT_DETERM (rtac @{thm ext} 1)
   13.83      THEN print_tac options "prove_param"
   13.84 @@ -86,7 +93,7 @@
   13.85    end
   13.86  
   13.87  fun prove_expr options ctxt nargs (premposition : int) (t, deriv) =
   13.88 -  case strip_comb t of
   13.89 +  (case strip_comb t of
   13.90      (Const (name, _), args) =>
   13.91        let
   13.92          val mode = head_mode_of deriv
   13.93 @@ -106,25 +113,25 @@
   13.94          THEN (REPEAT_DETERM (atac 1))
   13.95        end
   13.96    | (Free _, _) =>
   13.97 -    print_tac options "proving parameter call.."
   13.98 -    THEN Subgoal.FOCUS_PREMS (fn {context = ctxt', params, prems, asms, concl, schematics} =>
   13.99 -        let
  13.100 -          val param_prem = nth prems premposition
  13.101 -          val (param, _) = strip_comb (HOLogic.dest_Trueprop (prop_of param_prem))
  13.102 -          val prems' = maps dest_conjunct_prem (take nargs prems)
  13.103 -          fun param_rewrite prem =
  13.104 -            param = snd (HOLogic.dest_eq (HOLogic.dest_Trueprop (prop_of prem)))
  13.105 -          val SOME rew_eq = find_first param_rewrite prems'
  13.106 -          val param_prem' = rewrite_rule ctxt'
  13.107 -            (map (fn th => th RS @{thm eq_reflection})
  13.108 -              [rew_eq RS @{thm sym}, @{thm split_beta}, @{thm fst_conv}, @{thm snd_conv}])
  13.109 -            param_prem
  13.110 -        in
  13.111 -          rtac param_prem' 1
  13.112 -        end) ctxt 1
  13.113 -    THEN print_tac options "after prove parameter call"
  13.114 +      print_tac options "proving parameter call.."
  13.115 +      THEN Subgoal.FOCUS_PREMS (fn {context = ctxt', params, prems, asms, concl, schematics} =>
  13.116 +          let
  13.117 +            val param_prem = nth prems premposition
  13.118 +            val (param, _) = strip_comb (HOLogic.dest_Trueprop (prop_of param_prem))
  13.119 +            val prems' = maps dest_conjunct_prem (take nargs prems)
  13.120 +            fun param_rewrite prem =
  13.121 +              param = snd (HOLogic.dest_eq (HOLogic.dest_Trueprop (prop_of prem)))
  13.122 +            val SOME rew_eq = find_first param_rewrite prems'
  13.123 +            val param_prem' = rewrite_rule ctxt'
  13.124 +              (map (fn th => th RS @{thm eq_reflection})
  13.125 +                [rew_eq RS @{thm sym}, @{thm split_beta}, @{thm fst_conv}, @{thm snd_conv}])
  13.126 +              param_prem
  13.127 +          in
  13.128 +            rtac param_prem' 1
  13.129 +          end) ctxt 1
  13.130 +      THEN print_tac options "after prove parameter call")
  13.131  
  13.132 -fun SOLVED tac st = FILTER (fn st' => nprems_of st' = nprems_of st - 1) tac st;
  13.133 +fun SOLVED tac st = FILTER (fn st' => nprems_of st' = nprems_of st - 1) tac st
  13.134  
  13.135  fun prove_match options ctxt nargs out_ts =
  13.136    let
  13.137 @@ -142,7 +149,7 @@
  13.138        (fold (union Thm.eq_thm) (map get_case_rewrite out_ts) []))
  13.139    (* replace TRY by determining if it necessary - are there equations when calling compile match? *)
  13.140    in
  13.141 -     (* make this simpset better! *)
  13.142 +    (* make this simpset better! *)
  13.143      asm_full_simp_tac (put_simpset HOL_basic_ss' ctxt addsimps simprules) 1
  13.144      THEN print_tac options "after prove_match:"
  13.145      THEN (DETERM (TRY 
  13.146 @@ -164,15 +171,17 @@
  13.147      THEN print_tac options "after if simplification"
  13.148    end;
  13.149  
  13.150 +
  13.151  (* corresponds to compile_fun -- maybe call that also compile_sidecond? *)
  13.152  
  13.153  fun prove_sidecond ctxt t =
  13.154    let
  13.155 -    fun preds_of t nameTs = case strip_comb t of 
  13.156 -      (Const (name, T), args) =>
  13.157 -        if is_registered ctxt name then (name, T) :: nameTs
  13.158 -          else fold preds_of args nameTs
  13.159 -      | _ => nameTs
  13.160 +    fun preds_of t nameTs =
  13.161 +      (case strip_comb t of
  13.162 +        (Const (name, T), args) =>
  13.163 +          if is_registered ctxt name then (name, T) :: nameTs
  13.164 +            else fold preds_of args nameTs
  13.165 +      | _ => nameTs)
  13.166      val preds = preds_of t []
  13.167      val defs = map
  13.168        (fn (pred, T) => predfun_definition_of ctxt pred
  13.169 @@ -188,88 +197,88 @@
  13.170    let
  13.171      val (in_ts, clause_out_ts) = split_mode mode ts;
  13.172      fun prove_prems out_ts [] =
  13.173 -      (prove_match options ctxt nargs out_ts)
  13.174 -      THEN print_tac options "before simplifying assumptions"
  13.175 -      THEN asm_full_simp_tac (put_simpset HOL_basic_ss' ctxt) 1
  13.176 -      THEN print_tac options "before single intro rule"
  13.177 -      THEN Subgoal.FOCUS_PREMS
  13.178 -         (fn {context = ctxt', params, prems, asms, concl, schematics} =>
  13.179 -          let
  13.180 -            val prems' = maps dest_conjunct_prem (take nargs prems)
  13.181 -          in
  13.182 -            rewrite_goal_tac ctxt' (map (fn th => th RS @{thm sym} RS @{thm eq_reflection}) prems') 1
  13.183 -          end) ctxt 1
  13.184 -      THEN (rtac (if null clause_out_ts then @{thm singleI_unit} else @{thm singleI}) 1)
  13.185 -    | prove_prems out_ts ((p, deriv) :: ps) =
  13.186 -      let
  13.187 -        val premposition = (find_index (equal p) clauses) + nargs
  13.188 -        val mode = head_mode_of deriv
  13.189 -        val rest_tac =
  13.190 -          rtac @{thm bindI} 1
  13.191 -          THEN (case p of Prem t =>
  13.192 -            let
  13.193 -              val (_, us) = strip_comb t
  13.194 -              val (_, out_ts''') = split_mode mode us
  13.195 -              val rec_tac = prove_prems out_ts''' ps
  13.196 -            in
  13.197 -              print_tac options "before clause:"
  13.198 -              (*THEN asm_simp_tac (put_simpset HOL_basic_ss ctxt) 1*)
  13.199 -              THEN print_tac options "before prove_expr:"
  13.200 -              THEN prove_expr options ctxt nargs premposition (t, deriv)
  13.201 -              THEN print_tac options "after prove_expr:"
  13.202 -              THEN rec_tac
  13.203 -            end
  13.204 -          | Negprem t =>
  13.205 +        (prove_match options ctxt nargs out_ts)
  13.206 +        THEN print_tac options "before simplifying assumptions"
  13.207 +        THEN asm_full_simp_tac (put_simpset HOL_basic_ss' ctxt) 1
  13.208 +        THEN print_tac options "before single intro rule"
  13.209 +        THEN Subgoal.FOCUS_PREMS
  13.210 +           (fn {context = ctxt', params, prems, asms, concl, schematics} =>
  13.211              let
  13.212 -              val (t, args) = strip_comb t
  13.213 -              val (_, out_ts''') = split_mode mode args
  13.214 -              val rec_tac = prove_prems out_ts''' ps
  13.215 -              val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE)
  13.216 -              val neg_intro_rule =
  13.217 -                Option.map (fn name =>
  13.218 -                  the (predfun_neg_intro_of ctxt name mode)) name
  13.219 -              val param_derivations = param_derivations_of deriv
  13.220 -              val params = ho_args_of mode args
  13.221 +              val prems' = maps dest_conjunct_prem (take nargs prems)
  13.222              in
  13.223 -              print_tac options "before prove_neg_expr:"
  13.224 -              THEN full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps
  13.225 -                [@{thm split_eta}, @{thm split_beta}, @{thm fst_conv},
  13.226 -                 @{thm snd_conv}, @{thm pair_collapse}, @{thm Product_Type.split_conv}]) 1
  13.227 -              THEN (if (is_some name) then
  13.228 -                  print_tac options "before applying not introduction rule"
  13.229 -                  THEN Subgoal.FOCUS_PREMS
  13.230 -                    (fn {context, params = params, prems, asms, concl, schematics} =>
  13.231 -                      rtac (the neg_intro_rule) 1
  13.232 -                      THEN rtac (nth prems premposition) 1) ctxt 1
  13.233 -                  THEN print_tac options "after applying not introduction rule"
  13.234 -                  THEN (EVERY (map2 (prove_param options ctxt nargs) params param_derivations))
  13.235 -                  THEN (REPEAT_DETERM (atac 1))
  13.236 -                else
  13.237 -                  rtac @{thm not_predI'} 1
  13.238 -                  (* test: *)
  13.239 -                  THEN dtac @{thm sym} 1
  13.240 -                  THEN asm_full_simp_tac
  13.241 -                    (put_simpset HOL_basic_ss ctxt addsimps [@{thm not_False_eq_True}]) 1)
  13.242 -                  THEN simp_tac
  13.243 -                    (put_simpset HOL_basic_ss ctxt addsimps [@{thm not_False_eq_True}]) 1
  13.244 -              THEN rec_tac
  13.245 -            end
  13.246 -          | Sidecond t =>
  13.247 -           rtac @{thm if_predI} 1
  13.248 -           THEN print_tac options "before sidecond:"
  13.249 -           THEN prove_sidecond ctxt t
  13.250 -           THEN print_tac options "after sidecond:"
  13.251 -           THEN prove_prems [] ps)
  13.252 -      in (prove_match options ctxt nargs out_ts)
  13.253 -          THEN rest_tac
  13.254 -      end;
  13.255 +              rewrite_goal_tac ctxt' (map (fn th => th RS @{thm sym} RS @{thm eq_reflection}) prems') 1
  13.256 +            end) ctxt 1
  13.257 +        THEN (rtac (if null clause_out_ts then @{thm singleI_unit} else @{thm singleI}) 1)
  13.258 +    | prove_prems out_ts ((p, deriv) :: ps) =
  13.259 +        let
  13.260 +          val premposition = (find_index (equal p) clauses) + nargs
  13.261 +          val mode = head_mode_of deriv
  13.262 +          val rest_tac =
  13.263 +            rtac @{thm bindI} 1
  13.264 +            THEN (case p of Prem t =>
  13.265 +              let
  13.266 +                val (_, us) = strip_comb t
  13.267 +                val (_, out_ts''') = split_mode mode us
  13.268 +                val rec_tac = prove_prems out_ts''' ps
  13.269 +              in
  13.270 +                print_tac options "before clause:"
  13.271 +                (*THEN asm_simp_tac (put_simpset HOL_basic_ss ctxt) 1*)
  13.272 +                THEN print_tac options "before prove_expr:"
  13.273 +                THEN prove_expr options ctxt nargs premposition (t, deriv)
  13.274 +                THEN print_tac options "after prove_expr:"
  13.275 +                THEN rec_tac
  13.276 +              end
  13.277 +            | Negprem t =>
  13.278 +              let
  13.279 +                val (t, args) = strip_comb t
  13.280 +                val (_, out_ts''') = split_mode mode args
  13.281 +                val rec_tac = prove_prems out_ts''' ps
  13.282 +                val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE)
  13.283 +                val neg_intro_rule =
  13.284 +                  Option.map (fn name =>
  13.285 +                    the (predfun_neg_intro_of ctxt name mode)) name
  13.286 +                val param_derivations = param_derivations_of deriv
  13.287 +                val params = ho_args_of mode args
  13.288 +              in
  13.289 +                print_tac options "before prove_neg_expr:"
  13.290 +                THEN full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps
  13.291 +                  [@{thm split_eta}, @{thm split_beta}, @{thm fst_conv},
  13.292 +                   @{thm snd_conv}, @{thm pair_collapse}, @{thm Product_Type.split_conv}]) 1
  13.293 +                THEN (if (is_some name) then
  13.294 +                    print_tac options "before applying not introduction rule"
  13.295 +                    THEN Subgoal.FOCUS_PREMS
  13.296 +                      (fn {context, params = params, prems, asms, concl, schematics} =>
  13.297 +                        rtac (the neg_intro_rule) 1
  13.298 +                        THEN rtac (nth prems premposition) 1) ctxt 1
  13.299 +                    THEN print_tac options "after applying not introduction rule"
  13.300 +                    THEN (EVERY (map2 (prove_param options ctxt nargs) params param_derivations))
  13.301 +                    THEN (REPEAT_DETERM (atac 1))
  13.302 +                  else
  13.303 +                    rtac @{thm not_predI'} 1
  13.304 +                    (* test: *)
  13.305 +                    THEN dtac @{thm sym} 1
  13.306 +                    THEN asm_full_simp_tac
  13.307 +                      (put_simpset HOL_basic_ss ctxt addsimps [@{thm not_False_eq_True}]) 1)
  13.308 +                    THEN simp_tac
  13.309 +                      (put_simpset HOL_basic_ss ctxt addsimps [@{thm not_False_eq_True}]) 1
  13.310 +                THEN rec_tac
  13.311 +              end
  13.312 +            | Sidecond t =>
  13.313 +             rtac @{thm if_predI} 1
  13.314 +             THEN print_tac options "before sidecond:"
  13.315 +             THEN prove_sidecond ctxt t
  13.316 +             THEN print_tac options "after sidecond:"
  13.317 +             THEN prove_prems [] ps)
  13.318 +        in (prove_match options ctxt nargs out_ts)
  13.319 +            THEN rest_tac
  13.320 +        end
  13.321      val prems_tac = prove_prems in_ts moded_ps
  13.322    in
  13.323      print_tac options "Proving clause..."
  13.324      THEN rtac @{thm bindI} 1
  13.325      THEN rtac @{thm singleI} 1
  13.326      THEN prems_tac
  13.327 -  end;
  13.328 +  end
  13.329  
  13.330  fun select_sup 1 1 = []
  13.331    | select_sup _ 1 = [rtac @{thm supI1}]
  13.332 @@ -291,7 +300,8 @@
  13.333               (1 upto (length moded_clauses))))
  13.334      THEN (EVERY (map2 (prove_clause options ctxt nargs mode) clauses moded_clauses))
  13.335      THEN print_tac options "proved one direction"
  13.336 -  end;
  13.337 +  end
  13.338 +
  13.339  
  13.340  (** Proof in the other direction **)
  13.341  
  13.342 @@ -335,12 +345,13 @@
  13.343      val mode = head_mode_of deriv
  13.344      val param_derivations = param_derivations_of deriv
  13.345      val ho_args = ho_args_of mode args
  13.346 -    val f_tac = case f of
  13.347 +    val f_tac =
  13.348 +      (case f of
  13.349          Const (name, _) => full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps 
  13.350             (@{thm eval_pred}::(predfun_definition_of ctxt name mode)
  13.351             :: @{thm "Product_Type.split_conv"}::[])) 1
  13.352        | Free _ => all_tac
  13.353 -      | _ => error "prove_param2: illegal parameter term"
  13.354 +      | _ => error "prove_param2: illegal parameter term")
  13.355    in
  13.356      print_tac options "before simplification in prove_args:"
  13.357      THEN f_tac
  13.358 @@ -366,23 +377,25 @@
  13.359          end
  13.360        | _ => etac @{thm bindE} 1)
  13.361  
  13.362 -fun prove_sidecond2 options ctxt t = let
  13.363 -  fun preds_of t nameTs = case strip_comb t of 
  13.364 -    (Const (name, T), args) =>
  13.365 -      if is_registered ctxt name then (name, T) :: nameTs
  13.366 -        else fold preds_of args nameTs
  13.367 -    | _ => nameTs
  13.368 -  val preds = preds_of t []
  13.369 -  val defs = map
  13.370 -    (fn (pred, T) => predfun_definition_of ctxt pred 
  13.371 -      (all_input_of T))
  13.372 -      preds
  13.373 +fun prove_sidecond2 options ctxt t =
  13.374 +  let
  13.375 +    fun preds_of t nameTs =
  13.376 +      (case strip_comb t of
  13.377 +        (Const (name, T), args) =>
  13.378 +          if is_registered ctxt name then (name, T) :: nameTs
  13.379 +            else fold preds_of args nameTs
  13.380 +      | _ => nameTs)
  13.381 +    val preds = preds_of t []
  13.382 +    val defs = map
  13.383 +      (fn (pred, T) => predfun_definition_of ctxt pred 
  13.384 +        (all_input_of T))
  13.385 +        preds
  13.386    in
  13.387 -   (* only simplify the one assumption *)
  13.388 -   full_simp_tac (put_simpset HOL_basic_ss' ctxt addsimps @{thm eval_pred} :: defs) 1 
  13.389 -   (* need better control here! *)
  13.390 -   THEN print_tac options "after sidecond2 simplification"
  13.391 -   end
  13.392 +    (* only simplify the one assumption *)
  13.393 +    full_simp_tac (put_simpset HOL_basic_ss' ctxt addsimps @{thm eval_pred} :: defs) 1 
  13.394 +    (* need better control here! *)
  13.395 +    THEN print_tac options "after sidecond2 simplification"
  13.396 +  end
  13.397    
  13.398  fun prove_clause2 options ctxt pred mode (ts, ps) i =
  13.399    let
  13.400 @@ -413,46 +426,48 @@
  13.401      | prove_prems2 out_ts ((p, deriv) :: ps) =
  13.402        let
  13.403          val mode = head_mode_of deriv
  13.404 -        val rest_tac = (case p of
  13.405 -          Prem t =>
  13.406 -          let
  13.407 -            val (_, us) = strip_comb t
  13.408 -            val (_, out_ts''') = split_mode mode us
  13.409 -            val rec_tac = prove_prems2 out_ts''' ps
  13.410 -          in
  13.411 -            (prove_expr2 options ctxt (t, deriv)) THEN rec_tac
  13.412 -          end
  13.413 -        | Negprem t =>
  13.414 -          let
  13.415 -            val (_, args) = strip_comb t
  13.416 -            val (_, out_ts''') = split_mode mode args
  13.417 -            val rec_tac = prove_prems2 out_ts''' ps
  13.418 -            val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE)
  13.419 -            val param_derivations = param_derivations_of deriv
  13.420 -            val ho_args = ho_args_of mode args
  13.421 -          in
  13.422 -            print_tac options "before neg prem 2"
  13.423 -            THEN etac @{thm bindE} 1
  13.424 -            THEN (if is_some name then
  13.425 -                full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps
  13.426 -                  [predfun_definition_of ctxt (the name) mode]) 1
  13.427 -                THEN etac @{thm not_predE} 1
  13.428 -                THEN simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm not_False_eq_True}]) 1
  13.429 -                THEN (EVERY (map2 (prove_param2 options ctxt) ho_args param_derivations))
  13.430 -              else
  13.431 -                etac @{thm not_predE'} 1)
  13.432 -            THEN rec_tac
  13.433 -          end 
  13.434 -        | Sidecond t =>
  13.435 -          etac @{thm bindE} 1
  13.436 -          THEN etac @{thm if_predE} 1
  13.437 -          THEN prove_sidecond2 options ctxt t
  13.438 -          THEN prove_prems2 [] ps)
  13.439 -      in print_tac options "before prove_match2:"
  13.440 -         THEN prove_match2 options ctxt out_ts
  13.441 -         THEN print_tac options "after prove_match2:"
  13.442 -         THEN rest_tac
  13.443 -      end;
  13.444 +        val rest_tac =
  13.445 +          (case p of
  13.446 +            Prem t =>
  13.447 +              let
  13.448 +                val (_, us) = strip_comb t
  13.449 +                val (_, out_ts''') = split_mode mode us
  13.450 +                val rec_tac = prove_prems2 out_ts''' ps
  13.451 +              in
  13.452 +                (prove_expr2 options ctxt (t, deriv)) THEN rec_tac
  13.453 +              end
  13.454 +          | Negprem t =>
  13.455 +              let
  13.456 +                val (_, args) = strip_comb t
  13.457 +                val (_, out_ts''') = split_mode mode args
  13.458 +                val rec_tac = prove_prems2 out_ts''' ps
  13.459 +                val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE)
  13.460 +                val param_derivations = param_derivations_of deriv
  13.461 +                val ho_args = ho_args_of mode args
  13.462 +              in
  13.463 +                print_tac options "before neg prem 2"
  13.464 +                THEN etac @{thm bindE} 1
  13.465 +                THEN (if is_some name then
  13.466 +                    full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps
  13.467 +                      [predfun_definition_of ctxt (the name) mode]) 1
  13.468 +                    THEN etac @{thm not_predE} 1
  13.469 +                    THEN simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm not_False_eq_True}]) 1
  13.470 +                    THEN (EVERY (map2 (prove_param2 options ctxt) ho_args param_derivations))
  13.471 +                  else
  13.472 +                    etac @{thm not_predE'} 1)
  13.473 +                THEN rec_tac
  13.474 +              end 
  13.475 +          | Sidecond t =>
  13.476 +              etac @{thm bindE} 1
  13.477 +              THEN etac @{thm if_predE} 1
  13.478 +              THEN prove_sidecond2 options ctxt t
  13.479 +              THEN prove_prems2 [] ps)
  13.480 +      in
  13.481 +        print_tac options "before prove_match2:"
  13.482 +        THEN prove_match2 options ctxt out_ts
  13.483 +        THEN print_tac options "after prove_match2:"
  13.484 +        THEN rest_tac
  13.485 +      end
  13.486      val prems_tac = prove_prems2 in_ts ps 
  13.487    in
  13.488      print_tac options "starting prove_clause2"
  13.489 @@ -476,14 +491,15 @@
  13.490       THEN (
  13.491         if null moded_clauses then etac @{thm botE} 1
  13.492         else EVERY (map2 prove_clause moded_clauses (1 upto (length moded_clauses))))
  13.493 -  end;
  13.494 +  end
  13.495 +
  13.496  
  13.497  (** proof procedure **)
  13.498  
  13.499  fun prove_pred options thy clauses preds pred (_, mode) (moded_clauses, compiled_term) =
  13.500    let
  13.501      val ctxt = Proof_Context.init_global thy   (* FIXME proper context!? *)
  13.502 -    val clauses = case AList.lookup (op =) clauses pred of SOME rs => rs | NONE => []
  13.503 +    val clauses = (case AList.lookup (op =) clauses pred of SOME rs => rs | NONE => [])
  13.504    in
  13.505      Goal.prove ctxt (Term.add_free_names compiled_term []) [] compiled_term
  13.506        (if not (skip_proof options) then
  13.507 @@ -495,6 +511,6 @@
  13.508          THEN prove_other_direction options ctxt pred mode moded_clauses
  13.509          THEN print_tac options "proved other direction")
  13.510        else (fn _ => ALLGOALS Skip_Proof.cheat_tac))
  13.511 -  end;
  13.512 +  end
  13.513  
  13.514 -end;
  13.515 \ No newline at end of file
  13.516 +end
  13.517 \ No newline at end of file
    14.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML	Wed Feb 12 10:59:25 2014 +0100
    14.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML	Wed Feb 12 14:32:45 2014 +0100
    14.3 @@ -9,24 +9,28 @@
    14.4    type seed = Random_Engine.seed
    14.5    (*val quickcheck : Proof.context -> term -> int -> term list option*)
    14.6    val put_pred_result :
    14.7 -    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> term list Predicate.pred) ->
    14.8 -      Proof.context -> Proof.context;
    14.9 +    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> Code_Numeral.natural -> seed ->
   14.10 +      term list Predicate.pred) ->
   14.11 +    Proof.context -> Proof.context
   14.12    val put_dseq_result :
   14.13 -    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> term list Limited_Sequence.dseq * seed) ->
   14.14 -      Proof.context -> Proof.context;
   14.15 +    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed ->
   14.16 +      term list Limited_Sequence.dseq * seed) ->
   14.17 +    Proof.context -> Proof.context
   14.18    val put_lseq_result :
   14.19 -    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural -> term list Lazy_Sequence.lazy_sequence) ->
   14.20 -      Proof.context -> Proof.context;
   14.21 -  val put_new_dseq_result : (unit -> Code_Numeral.natural -> term list Lazy_Sequence.lazy_sequence) ->
   14.22 +    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural ->
   14.23 +      term list Lazy_Sequence.lazy_sequence) ->
   14.24 +    Proof.context -> Proof.context
   14.25 +  val put_new_dseq_result :
   14.26 +    (unit -> Code_Numeral.natural -> term list Lazy_Sequence.lazy_sequence) ->
   14.27      Proof.context -> Proof.context
   14.28    val put_cps_result : (unit -> Code_Numeral.natural -> (bool * term list) option) ->
   14.29      Proof.context -> Proof.context
   14.30    val test_goals : (Predicate_Compile_Aux.compilation * bool) ->
   14.31 -    Proof.context -> bool * bool -> (string * typ) list -> (term * term list) list
   14.32 -      -> Quickcheck.result list
   14.33 -  val nrandom : int Unsynchronized.ref;
   14.34 -  val debug : bool Unsynchronized.ref;
   14.35 -  val no_higher_order_predicate : string list Unsynchronized.ref;
   14.36 +    Proof.context -> bool * bool -> (string * typ) list -> (term * term list) list ->
   14.37 +    Quickcheck.result list
   14.38 +  val nrandom : int Unsynchronized.ref
   14.39 +  val debug : bool Unsynchronized.ref
   14.40 +  val no_higher_order_predicate : string list Unsynchronized.ref
   14.41    val setup : theory -> theory
   14.42  end;
   14.43  
   14.44 @@ -44,48 +48,48 @@
   14.45    type T = unit -> Code_Numeral.natural -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> term list Predicate.pred
   14.46    (* FIXME avoid user error with non-user text *)
   14.47    fun init _ () = error "Pred_Result"
   14.48 -);
   14.49 -val put_pred_result = Pred_Result.put;
   14.50 +)
   14.51 +val put_pred_result = Pred_Result.put
   14.52  
   14.53  structure Dseq_Result = Proof_Data
   14.54  (
   14.55    type T = unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> term list Limited_Sequence.dseq * seed
   14.56    (* FIXME avoid user error with non-user text *)
   14.57    fun init _ () = error "Dseq_Result"
   14.58 -);
   14.59 -val put_dseq_result = Dseq_Result.put;
   14.60 +)
   14.61 +val put_dseq_result = Dseq_Result.put
   14.62  
   14.63  structure Lseq_Result = Proof_Data
   14.64  (
   14.65    type T = unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural -> term list Lazy_Sequence.lazy_sequence
   14.66    (* FIXME avoid user error with non-user text *)
   14.67    fun init _ () = error "Lseq_Result"
   14.68 -);
   14.69 -val put_lseq_result = Lseq_Result.put;
   14.70 +)
   14.71 +val put_lseq_result = Lseq_Result.put
   14.72  
   14.73  structure New_Dseq_Result = Proof_Data
   14.74  (
   14.75    type T = unit -> Code_Numeral.natural -> term list Lazy_Sequence.lazy_sequence
   14.76    (* FIXME avoid user error with non-user text *)
   14.77    fun init _ () = error "New_Dseq_Random_Result"
   14.78 -);
   14.79 -val put_new_dseq_result = New_Dseq_Result.put;
   14.80 +)
   14.81 +val put_new_dseq_result = New_Dseq_Result.put
   14.82  
   14.83  structure CPS_Result = Proof_Data
   14.84  (
   14.85    type T = unit -> Code_Numeral.natural -> (bool * term list) option
   14.86    (* FIXME avoid user error with non-user text *)
   14.87    fun init _ () = error "CPS_Result"
   14.88 -);
   14.89 -val put_cps_result = CPS_Result.put;
   14.90 +)
   14.91 +val put_cps_result = CPS_Result.put
   14.92  
   14.93  val target = "Quickcheck"
   14.94  
   14.95 -val nrandom = Unsynchronized.ref 3;
   14.96 +val nrandom = Unsynchronized.ref 3
   14.97  
   14.98 -val debug = Unsynchronized.ref false;
   14.99 +val debug = Unsynchronized.ref false
  14.100  
  14.101 -val no_higher_order_predicate = Unsynchronized.ref ([] : string list);
  14.102 +val no_higher_order_predicate = Unsynchronized.ref ([] : string list)
  14.103  
  14.104  val options = Options {
  14.105    expected_modes = NONE,
  14.106 @@ -98,7 +102,7 @@
  14.107    show_mode_inference = false,
  14.108    show_compilation = false,
  14.109    show_caught_failures = false,
  14.110 -  show_invalid_clauses = false, 
  14.111 +  show_invalid_clauses = false,
  14.112    skip_proof = false,
  14.113    compilation = Random,
  14.114    inductify = true,
  14.115 @@ -141,7 +145,7 @@
  14.116      show_intermediate_results = s_ir, show_proof_trace = s_pt, show_modes = s_m,
  14.117      show_mode_inference = s_mi, show_compilation = s_c, show_caught_failures = s_cf,
  14.118      show_invalid_clauses = s_ic, skip_proof = s_p,
  14.119 -    compilation = c, inductify = i, specialise = sp, detect_switches = ds, function_flattening = _, 
  14.120 +    compilation = c, inductify = i, specialise = sp, detect_switches = ds, function_flattening = _,
  14.121      fail_safe_function_flattening = fs_ff, no_higher_order_predicate = no_ho,
  14.122      smart_depth_limiting = sm_dl, no_topmost_reordering = re}) =
  14.123    (Options { expected_modes = e_m, proposed_modes = p_m, proposed_names = p_n, show_steps = s_s,
  14.124 @@ -157,7 +161,7 @@
  14.125      show_intermediate_results = s_ir, show_proof_trace = s_pt, show_modes = s_m,
  14.126      show_mode_inference = s_mi, show_compilation = s_c, show_caught_failures = s_cf,
  14.127      show_invalid_clauses = s_ic, skip_proof = s_p,
  14.128 -    compilation = c, inductify = i, specialise = sp, detect_switches = ds, function_flattening = f_f, 
  14.129 +    compilation = c, inductify = i, specialise = sp, detect_switches = ds, function_flattening = f_f,
  14.130      fail_safe_function_flattening = _, no_higher_order_predicate = no_ho,
  14.131      smart_depth_limiting = sm_dl, no_topmost_reordering = re}) =
  14.132    (Options { expected_modes = e_m, proposed_modes = p_m, proposed_names = p_n, show_steps = s_s,
  14.133 @@ -173,7 +177,7 @@
  14.134      show_intermediate_results = s_ir, show_proof_trace = s_pt, show_modes = s_m,
  14.135      show_mode_inference = s_mi, show_compilation = s_c, show_caught_failures = s_cf,
  14.136      show_invalid_clauses = s_ic, skip_proof = s_p,
  14.137 -    compilation = c, inductify = i, specialise = sp, detect_switches = ds, function_flattening = f_f, 
  14.138 +    compilation = c, inductify = i, specialise = sp, detect_switches = ds, function_flattening = f_f,
  14.139      fail_safe_function_flattening = fs_ff, no_higher_order_predicate = _,
  14.140      smart_depth_limiting = sm_dl, no_topmost_reordering = re}) =
  14.141    (Options { expected_modes = e_m, proposed_modes = p_m, proposed_names = p_n, show_steps = s_s,
  14.142 @@ -185,7 +189,7 @@
  14.143      smart_depth_limiting = sm_dl, no_topmost_reordering = re})
  14.144  
  14.145  
  14.146 -fun get_options () = 
  14.147 +fun get_options () =
  14.148    set_no_higher_order_predicate (!no_higher_order_predicate)
  14.149      (if !debug then debug_options else options)
  14.150  
  14.151 @@ -210,7 +214,7 @@
  14.152    Predicate_Compile_Aux.mk_single New_Pos_DSequence_CompFuns.depth_unlimited_compfuns
  14.153  val mk_gen_bind =
  14.154    Predicate_Compile_Aux.mk_bind New_Pos_DSequence_CompFuns.depth_unlimited_compfuns
  14.155 -  
  14.156 +
  14.157  
  14.158  val mk_cpsT =
  14.159    Predicate_Compile_Aux.mk_monadT Pos_Bounded_CPS_Comp_Funs.compfuns
  14.160 @@ -251,41 +255,41 @@
  14.161        if member eq_mode modes output_mode then
  14.162          let
  14.163            val name = Core_Data.function_name_of compilation ctxt4 full_constname output_mode
  14.164 -          val T = 
  14.165 -            case compilation of
  14.166 +          val T =
  14.167 +            (case compilation of
  14.168                Pos_Random_DSeq => mk_randompredT (HOLogic.mk_tupleT (map snd vs'))
  14.169              | New_Pos_Random_DSeq => mk_new_randompredT (HOLogic.mk_tupleT (map snd vs'))
  14.170              | Pos_Generator_DSeq => mk_new_dseqT (HOLogic.mk_tupleT (map snd vs'))
  14.171              | Depth_Limited_Random =>
  14.172 -              [@{typ natural}, @{typ natural}, @{typ natural},
  14.173 -              @{typ Random.seed}] ---> mk_predT (HOLogic.mk_tupleT (map snd vs'))
  14.174 -            | Pos_Generator_CPS => mk_cpsT (HOLogic.mk_tupleT (map snd vs'))
  14.175 +                [@{typ natural}, @{typ natural}, @{typ natural},
  14.176 +                 @{typ Random.seed}] ---> mk_predT (HOLogic.mk_tupleT (map snd vs'))
  14.177 +            | Pos_Generator_CPS => mk_cpsT (HOLogic.mk_tupleT (map snd vs')))
  14.178          in
  14.179            Const (name, T)
  14.180          end
  14.181        else error ("Predicate Compile Quickcheck failed: " ^ commas (map string_of_mode modes))
  14.182      fun mk_Some T = Const (@{const_name "Option.Some"}, T --> Type (@{type_name "Option.option"}, [T]))
  14.183      val qc_term =
  14.184 -      case compilation of
  14.185 -          Pos_Random_DSeq => mk_bind (prog,
  14.186 -            mk_split_lambda (map Free vs') (mk_return (HOLogic.mk_list @{typ term}
  14.187 -            (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
  14.188 -        | New_Pos_Random_DSeq => mk_new_bind (prog,
  14.189 -            mk_split_lambda (map Free vs') (mk_new_return (HOLogic.mk_list @{typ term}
  14.190 -            (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
  14.191 -        | Pos_Generator_DSeq => mk_gen_bind (prog,
  14.192 -            mk_split_lambda (map Free vs') (mk_gen_return (HOLogic.mk_list @{typ term}
  14.193 -            (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
  14.194 -        | Pos_Generator_CPS => prog $
  14.195 -            mk_split_lambda (map Free vs') (mk_Some @{typ "bool * term list"} $
  14.196 -            HOLogic.mk_prod (@{term "True"}, HOLogic.mk_list @{typ term}
  14.197 -                (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))     
  14.198 -        | Depth_Limited_Random => fold_rev absdummy
  14.199 -            [@{typ natural}, @{typ natural}, @{typ natural},
  14.200 -             @{typ Random.seed}]
  14.201 -            (mk_bind' (list_comb (prog, map Bound (3 downto 0)),
  14.202 -            mk_split_lambda (map Free vs') (mk_return' (HOLogic.mk_list @{typ term}
  14.203 -            (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))))
  14.204 +      (case compilation of
  14.205 +        Pos_Random_DSeq => mk_bind (prog,
  14.206 +          mk_split_lambda (map Free vs') (mk_return (HOLogic.mk_list @{typ term}
  14.207 +          (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
  14.208 +      | New_Pos_Random_DSeq => mk_new_bind (prog,
  14.209 +          mk_split_lambda (map Free vs') (mk_new_return (HOLogic.mk_list @{typ term}
  14.210 +          (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
  14.211 +      | Pos_Generator_DSeq => mk_gen_bind (prog,
  14.212 +          mk_split_lambda (map Free vs') (mk_gen_return (HOLogic.mk_list @{typ term}
  14.213 +          (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
  14.214 +      | Pos_Generator_CPS => prog $
  14.215 +          mk_split_lambda (map Free vs') (mk_Some @{typ "bool * term list"} $
  14.216 +          HOLogic.mk_prod (@{term "True"}, HOLogic.mk_list @{typ term}
  14.217 +              (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))
  14.218 +      | Depth_Limited_Random => fold_rev absdummy
  14.219 +          [@{typ natural}, @{typ natural}, @{typ natural},
  14.220 +           @{typ Random.seed}]
  14.221 +          (mk_bind' (list_comb (prog, map Bound (3 downto 0)),
  14.222 +          mk_split_lambda (map Free vs') (mk_return' (HOLogic.mk_list @{typ term}
  14.223 +          (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))))
  14.224      val prog =
  14.225        case compilation of
  14.226          Pos_Random_DSeq =>
  14.227 @@ -310,7 +314,7 @@
  14.228                    g nrandom size s depth |> (Lazy_Sequence.map o map) proc)
  14.229                    qc_term []
  14.230            in
  14.231 -            fn size => fn nrandom => fn depth => Option.map fst (Lazy_Sequence.yield 
  14.232 +            fn size => fn nrandom => fn depth => Option.map fst (Lazy_Sequence.yield
  14.233                 (
  14.234                 let
  14.235                   val seed = Random_Engine.next_seed ()
  14.236 @@ -346,7 +350,7 @@
  14.237                    g depth nrandom size seed |> (Predicate.map o map) proc)
  14.238                  qc_term []
  14.239            in
  14.240 -            fn size => fn nrandom => fn depth => Option.map fst (Predicate.yield 
  14.241 +            fn size => fn nrandom => fn depth => Option.map fst (Predicate.yield
  14.242                (compiled_term depth nrandom size (Random_Engine.run (fn s => (s, s)))))
  14.243            end
  14.244    in
  14.245 @@ -368,14 +372,14 @@
  14.246           val _ = if Config.get ctxt Quickcheck.timing then
  14.247             message (fst time ^ ": " ^ string_of_int (snd time) ^ " ms") else ()
  14.248          in
  14.249 -          case result of NONE => try' (i + 1) | SOME q => SOME q
  14.250 +          (case result of NONE => try' (i + 1) | SOME q => SOME q)
  14.251          end
  14.252 -      else
  14.253 -        NONE
  14.254 +      else NONE
  14.255    in
  14.256      try' 0
  14.257    end
  14.258  
  14.259 +
  14.260  (* quickcheck interface functions *)
  14.261  
  14.262  fun compile_term' compilation options ctxt (t, _) =
  14.263 @@ -386,7 +390,8 @@
  14.264        (Code_Numeral.natural_of_integer (!nrandom)) o Code_Numeral.natural_of_integer)
  14.265    in
  14.266      Quickcheck.Result
  14.267 -      {counterexample = Option.map (pair true o (curry (op ~~)) (Term.add_free_names t [])) counterexample,
  14.268 +      {counterexample =
  14.269 +        Option.map (pair true o (curry (op ~~)) (Term.add_free_names t [])) counterexample,
  14.270         evaluation_terms = Option.map (K []) counterexample, timings = [], reports = []}
  14.271    end
  14.272  
  14.273 @@ -412,14 +417,16 @@
  14.274        (maps (map snd) correct_inst_goals) []
  14.275    end
  14.276  
  14.277 -val smart_exhaustive_active = Attrib.setup_config_bool @{binding quickcheck_smart_exhaustive_active} (K true);
  14.278 -val smart_slow_exhaustive_active = Attrib.setup_config_bool @{binding quickcheck_slow_smart_exhaustive_active} (K false);
  14.279 +val smart_exhaustive_active =
  14.280 +  Attrib.setup_config_bool @{binding quickcheck_smart_exhaustive_active} (K true)
  14.281 +val smart_slow_exhaustive_active =
  14.282 +  Attrib.setup_config_bool @{binding quickcheck_slow_smart_exhaustive_active} (K false)
  14.283  
  14.284  val setup =
  14.285 -  Exhaustive_Generators.setup_exhaustive_datatype_interpretation 
  14.286 +  Exhaustive_Generators.setup_exhaustive_datatype_interpretation
  14.287    #> Context.theory_map (Quickcheck.add_tester ("smart_exhaustive",
  14.288      (smart_exhaustive_active, test_goals (Predicate_Compile_Aux.Pos_Generator_CPS, false))))
  14.289    #> Context.theory_map (Quickcheck.add_tester ("smart_slow_exhaustive",
  14.290      (smart_slow_exhaustive_active, test_goals (Predicate_Compile_Aux.Pos_Generator_DSeq, false))))
  14.291  
  14.292 -end;
  14.293 +end
    15.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_specialisation.ML	Wed Feb 12 10:59:25 2014 +0100
    15.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_specialisation.ML	Wed Feb 12 14:32:45 2014 +0100
    15.3 @@ -6,7 +6,8 @@
    15.4  
    15.5  signature PREDICATE_COMPILE_SPECIALISATION =
    15.6  sig
    15.7 -  val find_specialisations : string list -> (string * thm list) list -> theory -> (string * thm list) list * theory
    15.8 +  val find_specialisations : string list -> (string * thm list) list ->
    15.9 +    theory -> (string * thm list) list * theory
   15.10  end;
   15.11  
   15.12  structure Predicate_Compile_Specialisation : PREDICATE_COMPILE_SPECIALISATION =
   15.13 @@ -17,10 +18,10 @@
   15.14  (* table of specialisations *)
   15.15  structure Specialisations = Theory_Data
   15.16  (
   15.17 -  type T = (term * term) Item_Net.T;
   15.18 -  val empty : T = Item_Net.init (op aconv o pairself fst) (single o fst);
   15.19 -  val extend = I;
   15.20 -  val merge = Item_Net.merge;
   15.21 +  type T = (term * term) Item_Net.T
   15.22 +  val empty : T = Item_Net.init (op aconv o pairself fst) (single o fst)
   15.23 +  val extend = I
   15.24 +  val merge = Item_Net.merge
   15.25  )
   15.26  
   15.27  fun specialisation_of thy atom =
   15.28 @@ -29,7 +30,8 @@
   15.29  fun import (_, intros) args ctxt =
   15.30    let
   15.31      val ((_, intros'), ctxt') = Variable.importT intros ctxt
   15.32 -    val pred' = fst (strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl (prop_of (hd intros')))))
   15.33 +    val pred' =
   15.34 +      fst (strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl (prop_of (hd intros')))))
   15.35      val Ts = binder_types (fastype_of pred')
   15.36      val argTs = map fastype_of args
   15.37      val Tsubst = Type.raw_matches (argTs, Ts) Vartab.empty
   15.38 @@ -42,17 +44,19 @@
   15.39  fun is_nontrivial_constrt thy t =
   15.40    let
   15.41      val cnstrs = get_constrs thy
   15.42 -    fun check t = (case strip_comb t of
   15.43 +    fun check t =
   15.44 +      (case strip_comb t of
   15.45          (Var _, []) => (true, true)
   15.46        | (Free _, []) => (true, true)
   15.47        | (Const (@{const_name Pair}, _), ts) =>
   15.48          pairself (forall I) (split_list (map check ts))
   15.49 -      | (Const (s, T), ts) => (case (AList.lookup (op =) cnstrs s, body_type T) of
   15.50 +      | (Const (s, T), ts) =>
   15.51 +          (case (AList.lookup (op =) cnstrs s, body_type T) of
   15.52              (SOME (i, Tname), Type (Tname', _)) => (false,
   15.53                length ts = i andalso Tname = Tname' andalso forall (snd o check) ts)
   15.54            | _ => (false, false))
   15.55        | _ => (false, false))
   15.56 -  in check t = (false, true) end;
   15.57 +  in check t = (false, true) end
   15.58  
   15.59  fun specialise_intros black_list (pred, intros) pats thy =
   15.60    let
   15.61 @@ -89,7 +93,8 @@
   15.62          SOME intro
   15.63        end handle Pattern.Unif => NONE)
   15.64      val specialised_intros_t = map_filter I (map specialise_intro intros)
   15.65 -    val thy' = Sign.add_consts_i [(Binding.name (Long_Name.base_name constname), constT, NoSyn)] thy
   15.66 +    val thy' =
   15.67 +      Sign.add_consts_i [(Binding.name (Long_Name.base_name constname), constT, NoSyn)] thy
   15.68      val specialised_intros = map (Skip_Proof.make_thm thy') specialised_intros_t
   15.69      val exported_intros = Variable.exportT ctxt' ctxt specialised_intros
   15.70      val [t, specialised_t] = Variable.exportT_terms ctxt' ctxt
   15.71 @@ -123,30 +128,31 @@
   15.72        end
   15.73      and restrict_pattern' thy [] free_names = ([], free_names)
   15.74        | restrict_pattern' thy ((T, Free (x, _)) :: Tts) free_names =
   15.75 -      let
   15.76 -        val (ts', free_names') = restrict_pattern' thy Tts free_names
   15.77 -      in
   15.78 -        (Free (x, T) :: ts', free_names')
   15.79 -      end
   15.80 +          let
   15.81 +            val (ts', free_names') = restrict_pattern' thy Tts free_names
   15.82 +          in
   15.83 +            (Free (x, T) :: ts', free_names')
   15.84 +          end
   15.85        | restrict_pattern' thy ((T as TFree _, t) :: Tts) free_names =
   15.86 -        replace_term_and_restrict thy T t Tts free_names
   15.87 +          replace_term_and_restrict thy T t Tts free_names
   15.88        | restrict_pattern' thy ((T as Type (Tcon, _), t) :: Tts) free_names =
   15.89          case Ctr_Sugar.ctr_sugar_of ctxt Tcon of
   15.90            NONE => replace_term_and_restrict thy T t Tts free_names
   15.91 -        | SOME {ctrs, ...} => (case strip_comb t of
   15.92 -          (Const (s, _), ats) =>
   15.93 -          (case AList.lookup (op =) (map_filter (try dest_Const) ctrs) s of
   15.94 -            SOME constr_T =>
   15.95 -              let
   15.96 -                val (Ts', T') = strip_type constr_T
   15.97 -                val Tsubst = Type.raw_match (T', T) Vartab.empty
   15.98 -                val Ts = map (Envir.subst_type Tsubst) Ts'
   15.99 -                val (bts', free_names') = restrict_pattern' thy ((Ts ~~ ats) @ Tts) free_names
  15.100 -                val (ats', ts') = chop (length ats) bts'
  15.101 -              in
  15.102 -                (list_comb (Const (s, map fastype_of ats' ---> T), ats') :: ts', free_names')
  15.103 -              end
  15.104 -            | NONE => replace_term_and_restrict thy T t Tts free_names))
  15.105 +        | SOME {ctrs, ...} =>
  15.106 +          (case strip_comb t of
  15.107 +            (Const (s, _), ats) =>
  15.108 +              (case AList.lookup (op =) (map_filter (try dest_Const) ctrs) s of
  15.109 +                SOME constr_T =>
  15.110 +                  let
  15.111 +                    val (Ts', T') = strip_type constr_T
  15.112 +                    val Tsubst = Type.raw_match (T', T) Vartab.empty
  15.113 +                    val Ts = map (Envir.subst_type Tsubst) Ts'
  15.114 +                    val (bts', free_names') = restrict_pattern' thy ((Ts ~~ ats) @ Tts) free_names
  15.115 +                    val (ats', ts') = chop (length ats) bts'
  15.116 +                  in
  15.117 +                    (list_comb (Const (s, map fastype_of ats' ---> T), ats') :: ts', free_names')
  15.118 +                  end
  15.119 +              | NONE => replace_term_and_restrict thy T t Tts free_names))
  15.120      fun restrict_pattern thy Ts args =
  15.121        let
  15.122          val args = map Logic.unvarify_global args
  15.123 @@ -155,42 +161,42 @@
  15.124          val (pat, _) = restrict_pattern' thy (Ts ~~ args) free_names
  15.125        in map Logic.varify_global pat end
  15.126      fun detect' atom thy =
  15.127 -      case strip_comb atom of
  15.128 +      (case strip_comb atom of
  15.129          (pred as Const (pred_name, _), args) =>
  15.130            let
  15.131 -          val Ts = binder_types (Sign.the_const_type thy pred_name)
  15.132 -          val pats = restrict_pattern thy Ts args
  15.133 -        in
  15.134 -          if (exists (is_nontrivial_constrt thy) pats)
  15.135 -            orelse (has_duplicates (op =) (fold add_vars pats [])) then
  15.136 -            let
  15.137 -              val thy' =
  15.138 -                case specialisation_of thy atom of
  15.139 -                  [] =>
  15.140 -                    if member (op =) ((map fst specs) @ black_list) pred_name then
  15.141 -                      thy
  15.142 -                    else
  15.143 -                      (case try (Core_Data.intros_of (Proof_Context.init_global thy)) pred_name of
  15.144 -                        NONE => thy
  15.145 -                      | SOME [] => thy
  15.146 -                      | SOME intros =>
  15.147 -                          specialise_intros ((map fst specs) @ (pred_name :: black_list))
  15.148 -                            (pred, intros) pats thy)
  15.149 -                  | _ :: _ => thy
  15.150 +            val Ts = binder_types (Sign.the_const_type thy pred_name)
  15.151 +            val pats = restrict_pattern thy Ts args
  15.152 +          in
  15.153 +            if (exists (is_nontrivial_constrt thy) pats)
  15.154 +              orelse (has_duplicates (op =) (fold add_vars pats [])) then
  15.155 +              let
  15.156 +                val thy' =
  15.157 +                  (case specialisation_of thy atom of
  15.158 +                    [] =>
  15.159 +                      if member (op =) ((map fst specs) @ black_list) pred_name then
  15.160 +                        thy
  15.161 +                      else
  15.162 +                        (case try (Core_Data.intros_of (Proof_Context.init_global thy)) pred_name of
  15.163 +                          NONE => thy
  15.164 +                        | SOME [] => thy
  15.165 +                        | SOME intros =>
  15.166 +                            specialise_intros ((map fst specs) @ (pred_name :: black_list))
  15.167 +                              (pred, intros) pats thy)
  15.168 +                  | _ :: _ => thy)
  15.169                  val atom' =
  15.170 -                  case specialisation_of thy' atom of
  15.171 +                  (case specialisation_of thy' atom of
  15.172                      [] => atom
  15.173                    | (t, specialised_t) :: _ =>
  15.174                      let
  15.175                        val subst = Pattern.match thy' (t, atom) (Vartab.empty, Vartab.empty)
  15.176 -                    in Envir.subst_term subst specialised_t end handle Pattern.MATCH => atom
  15.177 -                    (*FIXME: this exception could be caught earlier in specialisation_of *)
  15.178 -            in
  15.179 -              (atom', thy')
  15.180 -            end
  15.181 -          else (atom, thy)
  15.182 -        end
  15.183 -      | _ => (atom, thy)
  15.184 +                    in Envir.subst_term subst specialised_t end handle Pattern.MATCH => atom)
  15.185 +                    (*FIXME: this exception could be handled earlier in specialisation_of *)
  15.186 +              in
  15.187 +                (atom', thy')
  15.188 +              end
  15.189 +            else (atom, thy)
  15.190 +          end
  15.191 +      | _ => (atom, thy))
  15.192      fun specialise' (constname, intros) thy =
  15.193        let
  15.194          (* FIXME: only necessary because of sloppy Logic.unvarify in restrict_pattern *)
  15.195 @@ -203,4 +209,4 @@
  15.196      fold_map specialise' specs thy
  15.197    end
  15.198  
  15.199 -end;
  15.200 \ No newline at end of file
  15.201 +end
  15.202 \ No newline at end of file
    16.1 --- a/src/HOL/Tools/prop_logic.ML	Wed Feb 12 10:59:25 2014 +0100
    16.2 +++ b/src/HOL/Tools/prop_logic.ML	Wed Feb 12 14:32:45 2014 +0100
    16.3 @@ -258,12 +258,9 @@
    16.4      let
    16.5        val fm' = nnf fm
    16.6        (* 'new' specifies the next index that is available to introduce an auxiliary variable *)
    16.7 -      (* int ref *)
    16.8        val new = Unsynchronized.ref (maxidx fm' + 1)
    16.9 -      (* unit -> int *)
   16.10        fun new_idx () = let val idx = !new in new := idx+1; idx end
   16.11        (* replaces 'And' by an auxiliary variable (and its definition) *)
   16.12 -      (* prop_formula -> prop_formula * prop_formula list *)
   16.13        fun defcnf_or (And x) =
   16.14              let
   16.15                val i = new_idx ()
   16.16 @@ -279,7 +276,6 @@
   16.17                (Or (fm1', fm2'), defs1 @ defs2)
   16.18              end
   16.19          | defcnf_or fm = (fm, [])
   16.20 -      (* prop_formula -> prop_formula *)
   16.21        fun defcnf_from_nnf True = True
   16.22          | defcnf_from_nnf False = False
   16.23          | defcnf_from_nnf (BoolVar i) = BoolVar i
    17.1 --- a/src/HOL/Tools/sat_solver.ML	Wed Feb 12 10:59:25 2014 +0100
    17.2 +++ b/src/HOL/Tools/sat_solver.ML	Wed Feb 12 14:32:45 2014 +0100
    17.3 @@ -108,11 +108,8 @@
    17.4  (* Note: 'fm' must be given in CNF.                                          *)
    17.5  (* ------------------------------------------------------------------------- *)
    17.6  
    17.7 -  (* Path.T -> prop_formula -> unit *)
    17.8 -
    17.9    fun write_dimacs_cnf_file path fm =
   17.10    let
   17.11 -    (* prop_formula -> prop_formula *)
   17.12      fun cnf_True_False_elim True =
   17.13        Or (BoolVar 1, Not (BoolVar 1))
   17.14        | cnf_True_False_elim False =
   17.15 @@ -120,15 +117,12 @@
   17.16        | cnf_True_False_elim fm =
   17.17        fm  (* since 'fm' is in CNF, either 'fm'='True'/'False',
   17.18               or 'fm' does not contain 'True'/'False' at all *)
   17.19 -    (* prop_formula -> int *)
   17.20      fun cnf_number_of_clauses (And (fm1, fm2)) =
   17.21        (cnf_number_of_clauses fm1) + (cnf_number_of_clauses fm2)
   17.22        | cnf_number_of_clauses _ =
   17.23        1
   17.24 -    (* TextIO.outstream -> unit *)
   17.25      fun write_cnf_file out =
   17.26      let
   17.27 -      (* prop_formula -> unit *)
   17.28        fun write_formula True =
   17.29            error "formula is not in CNF"
   17.30          | write_formula False =
   17.31 @@ -170,14 +164,10 @@
   17.32  (* Note: 'fm' must not contain a variable index less than 1.                 *)
   17.33  (* ------------------------------------------------------------------------- *)
   17.34  
   17.35 -  (* Path.T -> prop_formula -> unit *)
   17.36 -
   17.37    fun write_dimacs_sat_file path fm =
   17.38    let
   17.39 -    (* TextIO.outstream -> unit *)
   17.40      fun write_sat_file out =
   17.41      let
   17.42 -      (* prop_formula -> unit *)
   17.43        fun write_formula True =
   17.44            TextIO.output (out, "*()")
   17.45          | write_formula False =
   17.46 @@ -243,21 +233,16 @@
   17.47  (*      value of i is taken to be unspecified.                               *)
   17.48  (* ------------------------------------------------------------------------- *)
   17.49  
   17.50 -  (* Path.T -> string * string * string -> result *)
   17.51 -
   17.52    fun read_std_result_file path (satisfiable, assignment_prefix, unsatisfiable) =
   17.53    let
   17.54 -    (* string -> int list *)
   17.55      fun int_list_from_string s =
   17.56        map_filter Int.fromString (space_explode " " s)
   17.57 -    (* int list -> assignment *)
   17.58      fun assignment_from_list [] i =
   17.59        NONE  (* the SAT solver didn't provide a value for this variable *)
   17.60        | assignment_from_list (x::xs) i =
   17.61        if x=i then (SOME true)
   17.62        else if x=(~i) then (SOME false)
   17.63        else assignment_from_list xs i
   17.64 -    (* int list -> string list -> assignment *)
   17.65      fun parse_assignment xs [] =
   17.66        assignment_from_list xs
   17.67        | parse_assignment xs (line::lines) =
   17.68 @@ -265,7 +250,6 @@
   17.69          parse_assignment (xs @ int_list_from_string line) lines
   17.70        else
   17.71          assignment_from_list xs
   17.72 -    (* string -> string -> bool *)
   17.73      fun is_substring needle haystack =
   17.74      let
   17.75        val length1 = String.size needle
   17.76 @@ -277,7 +261,6 @@
   17.77          true
   17.78        else is_substring needle (String.substring (haystack, 1, length2-1))
   17.79      end
   17.80 -    (* string list -> result *)
   17.81      fun parse_lines [] =
   17.82        UNKNOWN
   17.83        | parse_lines (line::lines) =
   17.84 @@ -305,7 +288,6 @@
   17.85  
   17.86    fun read_dimacs_cnf_file path =
   17.87    let
   17.88 -    (* string list -> string list *)
   17.89      fun filter_preamble [] =
   17.90        error "problem line not found in DIMACS CNF file"
   17.91        | filter_preamble (line::lines) =
   17.92 @@ -319,12 +301,10 @@
   17.93          lines
   17.94        else
   17.95          error "preamble in DIMACS CNF file contains a line that does not begin with \"c \" or \"p \""
   17.96 -    (* string -> int *)
   17.97      fun int_from_string s =
   17.98        case Int.fromString s of
   17.99          SOME i => i
  17.100        | NONE   => error ("token " ^ quote s ^ " in DIMACS CNF file is not a number")
  17.101 -    (* int list -> int list list *)
  17.102      fun clauses xs =
  17.103        let
  17.104          val (xs1, xs2) = take_prefix (fn i => i <> 0) xs
  17.105 @@ -377,8 +357,6 @@
  17.106  (* add_solver: updates 'solvers' by adding a new solver                      *)
  17.107  (* ------------------------------------------------------------------------- *)
  17.108  
  17.109 -  (* string * solver -> unit *)
  17.110 -
  17.111      fun add_solver (name, new_solver) = CRITICAL (fn () =>
  17.112        let
  17.113          val the_solvers = !solvers;
  17.114 @@ -393,8 +371,6 @@
  17.115  (*       raised.                                                             *)
  17.116  (* ------------------------------------------------------------------------- *)
  17.117  
  17.118 -  (* string -> solver *)
  17.119 -
  17.120    fun invoke_solver name =
  17.121      (the o AList.lookup (op =) (!solvers)) name;
  17.122  
  17.123 @@ -413,9 +389,7 @@
  17.124  let
  17.125    fun enum_solver fm =
  17.126    let
  17.127 -    (* int list *)
  17.128      val indices = Prop_Logic.indices fm
  17.129 -    (* int list -> int list -> int list option *)
  17.130      (* binary increment: list 'xs' of current bits, list 'ys' of all bits (lower bits first) *)
  17.131      fun next_list _ ([]:int list) =
  17.132        NONE
  17.133 @@ -428,10 +402,8 @@
  17.134        else
  17.135          (* set the lowest bit that wasn't set before, keep the higher bits *)
  17.136          SOME (y::x::xs)
  17.137 -    (* int list -> int -> bool *)
  17.138      fun assignment_from_list xs i =
  17.139        member (op =) xs i
  17.140 -    (* int list -> SatSolver.result *)
  17.141      fun solver_loop xs =
  17.142        if Prop_Logic.eval (assignment_from_list xs) fm then
  17.143          SatSolver.SATISFIABLE (SOME o (assignment_from_list xs))
  17.144 @@ -463,19 +435,15 @@
  17.145        (* but that sometimes leads to worse performance due to the         *)
  17.146        (* introduction of additional variables.                            *)
  17.147        val fm' = Prop_Logic.nnf fm
  17.148 -      (* int list *)
  17.149        val indices = Prop_Logic.indices fm'
  17.150 -      (* int list -> int -> prop_formula *)
  17.151        fun partial_var_eval []      i = BoolVar i
  17.152          | partial_var_eval (x::xs) i = if x=i then True else if x=(~i) then False else partial_var_eval xs i
  17.153 -      (* int list -> prop_formula -> prop_formula *)
  17.154        fun partial_eval xs True             = True
  17.155          | partial_eval xs False            = False
  17.156          | partial_eval xs (BoolVar i)      = partial_var_eval xs i
  17.157          | partial_eval xs (Not fm)         = SNot (partial_eval xs fm)
  17.158          | partial_eval xs (Or (fm1, fm2))  = SOr (partial_eval xs fm1, partial_eval xs fm2)
  17.159          | partial_eval xs (And (fm1, fm2)) = SAnd (partial_eval xs fm1, partial_eval xs fm2)
  17.160 -      (* prop_formula -> int list *)
  17.161        fun forced_vars True              = []
  17.162          | forced_vars False             = []
  17.163          | forced_vars (BoolVar i)       = [i]
  17.164 @@ -485,7 +453,6 @@
  17.165          (* Above, i *and* ~i may be forced.  In this case the first occurrence takes   *)
  17.166          (* precedence, and the next partial evaluation of the formula returns 'False'. *)
  17.167          | forced_vars _                 = error "formula is not in negation normal form"
  17.168 -      (* int list -> prop_formula -> (int list * prop_formula) *)
  17.169        fun eval_and_force xs fm =
  17.170        let
  17.171          val fm' = partial_eval xs fm
  17.172 @@ -497,10 +464,8 @@
  17.173            eval_and_force (xs@xs') fm'  (* xs and xs' should be distinct, so '@' here should have *)
  17.174                                         (* the same effect as 'union_int'                         *)
  17.175        end
  17.176 -      (* int list -> int option *)
  17.177        fun fresh_var xs =
  17.178          find_first (fn i => not (member (op =) xs i) andalso not (member (op =) xs (~i))) indices
  17.179 -      (* int list -> prop_formula -> int list option *)
  17.180        (* partial assignment 'xs' *)
  17.181        fun dpll xs fm =
  17.182        let
  17.183 @@ -518,7 +483,6 @@
  17.184              | NONE      => dpll ((~x)::xs') fm'  (* now try interpreting 'x' as 'False' *)
  17.185            end
  17.186        end
  17.187 -      (* int list -> assignment *)
  17.188        fun assignment_from_list [] i =
  17.189          NONE  (* the DPLL procedure didn't provide a value for this variable *)
  17.190          | assignment_from_list (x::xs) i =
  17.191 @@ -603,11 +567,9 @@
  17.192    in  case result of
  17.193      SatSolver.UNSATISFIABLE NONE =>
  17.194      (let
  17.195 -      (* string list *)
  17.196        val proof_lines = (split_lines o File.read) proofpath
  17.197          handle IO.Io _ => raise INVALID_PROOF "Could not read file \"result.prf\""
  17.198        (* representation of clauses as ordered lists of literals (with duplicates removed) *)
  17.199 -      (* prop_formula -> int list *)
  17.200        fun clause_to_lit_list (Prop_Logic.Or (fm1, fm2)) =
  17.201          Ord_List.union int_ord (clause_to_lit_list fm1) (clause_to_lit_list fm2)
  17.202          | clause_to_lit_list (Prop_Logic.BoolVar i) =
  17.203 @@ -616,7 +578,6 @@
  17.204          [~i]
  17.205          | clause_to_lit_list _ =
  17.206          raise INVALID_PROOF "Error: invalid clause in CNF formula."
  17.207 -      (* prop_formula -> int *)
  17.208        fun cnf_number_of_clauses (Prop_Logic.And (fm1, fm2)) =
  17.209          cnf_number_of_clauses fm1 + cnf_number_of_clauses fm2
  17.210          | cnf_number_of_clauses _ =
  17.211 @@ -625,7 +586,6 @@
  17.212        (* int list array *)
  17.213        val clauses = Array.array (number_of_clauses, [])
  17.214        (* initialize the 'clauses' array *)
  17.215 -      (* prop_formula * int -> int *)
  17.216        fun init_array (Prop_Logic.And (fm1, fm2), n) =
  17.217          init_array (fm2, init_array (fm1, n))
  17.218          | init_array (fm, n) =
  17.219 @@ -636,7 +596,6 @@
  17.220        val last_ref_clause = Unsynchronized.ref (number_of_clauses - 1)
  17.221        (* search the 'clauses' array for the given list of literals 'lits', *)
  17.222        (* starting at index '!last_ref_clause + 1'                          *)
  17.223 -      (* int list -> int option *)
  17.224        fun original_clause_id lits =
  17.225        let
  17.226          fun original_clause_id_from index =
  17.227 @@ -658,12 +617,10 @@
  17.228        in
  17.229          original_clause_id_from (!last_ref_clause + 1)
  17.230        end
  17.231 -      (* string -> int *)
  17.232 -      fun int_from_string s = (
  17.233 -        case Int.fromString s of
  17.234 +      fun int_from_string s =
  17.235 +        (case Int.fromString s of
  17.236            SOME i => i
  17.237 -        | NONE   => raise INVALID_PROOF ("File format error: number expected (" ^ quote s ^ " encountered).")
  17.238 -      )
  17.239 +        | NONE   => raise INVALID_PROOF ("File format error: number expected (" ^ quote s ^ " encountered)."))
  17.240        (* parse the proof file *)
  17.241        val clause_table  = Unsynchronized.ref (Inttab.empty : int list Inttab.table)
  17.242        val empty_id      = Unsynchronized.ref ~1
  17.243 @@ -676,7 +633,6 @@
  17.244          | NONE     => raise INVALID_PROOF ("Clause ID " ^ string_of_int id ^ " used, but not defined.")
  17.245        )
  17.246        val next_id = Unsynchronized.ref (number_of_clauses - 1)
  17.247 -      (* string list -> unit *)
  17.248        fun process_tokens [] =
  17.249          ()
  17.250          | process_tokens (tok::toks) =
  17.251 @@ -749,7 +705,6 @@
  17.252              raise INVALID_PROOF "File format error: \"X\" followed by an illegal number of tokens."
  17.253          ) else
  17.254            raise INVALID_PROOF ("File format error: unknown token " ^ quote tok ^ " encountered.")
  17.255 -      (* string list -> unit *)
  17.256        fun process_lines [] =
  17.257          ()
  17.258          | process_lines (l::ls) = (
  17.259 @@ -812,14 +767,12 @@
  17.260    case SatSolver.invoke_solver "zchaff" fm of
  17.261      SatSolver.UNSATISFIABLE NONE =>
  17.262      (let
  17.263 -      (* string list *)
  17.264        (* FIXME File.tmp_path (!?) *)
  17.265        val proof_lines = ((split_lines o File.read) (Path.explode "resolve_trace"))
  17.266          handle IO.Io _ => raise INVALID_PROOF "Could not read file \"resolve_trace\""
  17.267        fun cnf_number_of_clauses (Prop_Logic.And (fm1, fm2)) =
  17.268              cnf_number_of_clauses fm1 + cnf_number_of_clauses fm2
  17.269          | cnf_number_of_clauses _ = 1
  17.270 -      (* string -> int *)
  17.271        fun int_from_string s = (
  17.272          case Int.fromString s of
  17.273            SOME i => i
  17.274 @@ -829,7 +782,6 @@
  17.275        val clause_offset = Unsynchronized.ref ~1
  17.276        val clause_table  = Unsynchronized.ref (Inttab.empty : int list Inttab.table)
  17.277        val empty_id      = Unsynchronized.ref ~1
  17.278 -      (* string list -> unit *)
  17.279        fun process_tokens [] =
  17.280          ()
  17.281          | process_tokens (tok::toks) =
  17.282 @@ -910,7 +862,6 @@
  17.283              raise INVALID_PROOF "File format error: \"CONF:\" followed by an insufficient number of tokens."
  17.284          ) else
  17.285            raise INVALID_PROOF ("File format error: unknown token " ^ quote tok ^ " encountered.")
  17.286 -      (* string list -> unit *)
  17.287        fun process_lines [] =
  17.288          ()
  17.289          | process_lines (l::ls) = (
  17.290 @@ -1004,16 +955,3 @@
  17.291    SatSolver.add_solver ("jerusat", jerusat)
  17.292  end;
  17.293  
  17.294 -(* ------------------------------------------------------------------------- *)
  17.295 -(* Add code for other SAT solvers below.                                     *)
  17.296 -(* ------------------------------------------------------------------------- *)
  17.297 -
  17.298 -(*
  17.299 -let
  17.300 -  fun mysolver fm = ...
  17.301 -in
  17.302 -  SatSolver.add_solver ("myname", (fn fm => if mysolver_is_configured then mysolver fm else raise SatSolver.NOT_CONFIGURED));  -- register the solver
  17.303 -end;
  17.304 -
  17.305 --- the solver is now available as SatSolver.invoke_solver "myname"
  17.306 -*)
    18.1 --- a/src/Pure/General/position.scala	Wed Feb 12 10:59:25 2014 +0100
    18.2 +++ b/src/Pure/General/position.scala	Wed Feb 12 14:32:45 2014 +0100
    18.3 @@ -75,11 +75,12 @@
    18.4        }
    18.5    }
    18.6  
    18.7 -  object Id_Range
    18.8 +  object Reported
    18.9    {
   18.10 -    def unapply(pos: T): Option[(Long, Text.Range)] =
   18.11 +    def unapply(pos: T): Option[(Long, String, Text.Range)] =
   18.12        (pos, pos) match {
   18.13 -        case (Id(id), Range(range)) => Some((id, range))
   18.14 +        case (Id(id), Range(range)) =>
   18.15 +          Some((id, File.unapply(pos).getOrElse(""), range))
   18.16          case _ => None
   18.17        }
   18.18    }
    19.1 --- a/src/Pure/General/symbol.scala	Wed Feb 12 10:59:25 2014 +0100
    19.2 +++ b/src/Pure/General/symbol.scala	Wed Feb 12 14:32:45 2014 +0100
    19.3 @@ -118,8 +118,8 @@
    19.4  
    19.5    final class Index private(text: CharSequence)
    19.6    {
    19.7 -    sealed case class Entry(chr: Int, sym: Int)
    19.8 -    val index: Array[Entry] =
    19.9 +    private sealed case class Entry(chr: Int, sym: Int)
   19.10 +    private val index: Array[Entry] =
   19.11      {
   19.12        val matcher = new Matcher(text)
   19.13        val buf = new mutable.ArrayBuffer[Entry]
   19.14 @@ -133,6 +133,7 @@
   19.15        }
   19.16        buf.toArray
   19.17      }
   19.18 +
   19.19      def decode(sym1: Int): Int =
   19.20      {
   19.21        val sym = sym1 - 1
    20.1 --- a/src/Pure/PIDE/command.ML	Wed Feb 12 10:59:25 2014 +0100
    20.2 +++ b/src/Pure/PIDE/command.ML	Wed Feb 12 14:32:45 2014 +0100
    20.3 @@ -102,8 +102,14 @@
    20.4            fun make_file src_path (Exn.Res (_, NONE)) =
    20.5                  Exn.interruptible_capture (fn () => read_file master_dir pos src_path) ()
    20.6              | make_file src_path (Exn.Res (file, SOME text)) =
    20.7 -                let val _ = Position.report pos (Markup.path file)
    20.8 -                in Exn.Res {src_path = src_path, text = text, pos = Position.file file} end
    20.9 +                let
   20.10 +                  val _ = Position.report pos (Markup.path file);
   20.11 +                  val file_pos =
   20.12 +                    Position.file file (*sic!*) |>
   20.13 +                    (case Position.get_id (Position.thread_data ()) of
   20.14 +                      NONE => I
   20.15 +                    | SOME exec_id => Position.put_id exec_id);
   20.16 +                in Exn.Res {src_path = src_path, text = text, pos = file_pos} end
   20.17              | make_file _ (Exn.Exn e) = Exn.Exn e;
   20.18  
   20.19            val src_paths = Keyword.command_files cmd path;
    21.1 --- a/src/Pure/PIDE/command.scala	Wed Feb 12 10:59:25 2014 +0100
    21.2 +++ b/src/Pure/PIDE/command.scala	Wed Feb 12 14:32:45 2014 +0100
    21.3 @@ -60,8 +60,13 @@
    21.4      command: Command,
    21.5      status: List[Markup] = Nil,
    21.6      results: Results = Results.empty,
    21.7 -    markup: Markup_Tree = Markup_Tree.empty)
    21.8 +    markups: Map[String, Markup_Tree] = Map.empty)
    21.9    {
   21.10 +    def get_markup(file_name: String): Markup_Tree =
   21.11 +      markups.getOrElse(file_name, Markup_Tree.empty)
   21.12 +
   21.13 +    def markup: Markup_Tree = get_markup("")
   21.14 +
   21.15      def markup_to_XML(filter: XML.Elem => Boolean): XML.Body =
   21.16        markup.to_XML(command.range, command.source, filter)
   21.17  
   21.18 @@ -72,10 +77,12 @@
   21.19        command.source == other.command.source &&
   21.20        status == other.status &&
   21.21        results == other.results &&
   21.22 -      markup == other.markup
   21.23 +      markups == other.markups
   21.24  
   21.25      private def add_status(st: Markup): State = copy(status = st :: status)
   21.26 -    private def add_markup(m: Text.Markup): State = copy(markup = markup + m)
   21.27 +
   21.28 +    private def add_markup(file_name: String, m: Text.Markup): State =
   21.29 +      copy(markups = markups + (file_name -> (get_markup(file_name) + m)))
   21.30  
   21.31      def + (alt_id: Document_ID.Generic, message: XML.Elem): State =
   21.32        message match {
   21.33 @@ -84,7 +91,7 @@
   21.34              msg match {
   21.35                case elem @ XML.Elem(markup, Nil) =>
   21.36                  state.add_status(markup)
   21.37 -                  .add_markup(Text.Info(command.proper_range, elem))  // FIXME cumulation order!?
   21.38 +                  .add_markup("", Text.Info(command.proper_range, elem))  // FIXME cumulation order!?
   21.39  
   21.40                case _ =>
   21.41                  java.lang.System.err.println("Ignored status message: " + msg)
   21.42 @@ -93,23 +100,40 @@
   21.43  
   21.44          case XML.Elem(Markup(Markup.REPORT, _), msgs) =>
   21.45            (this /: msgs)((state, msg) =>
   21.46 -            msg match {
   21.47 -              case XML.Elem(Markup(name, atts @ Position.Id_Range(id, raw_range)), args)
   21.48 -              if (id == command.id || id == alt_id) &&
   21.49 -                  command.range.contains(command.decode(raw_range)) =>
   21.50 -                val range = command.decode(raw_range)
   21.51 -                val props = Position.purge(atts)
   21.52 -                val info: Text.Markup = Text.Info(range, XML.Elem(Markup(name, props), args))
   21.53 -                state.add_markup(info)
   21.54 -              case XML.Elem(Markup(name, atts), args)
   21.55 -              if !atts.exists({ case (a, _) => Markup.POSITION_PROPERTIES(a) }) =>
   21.56 -                val range = command.proper_range
   21.57 -                val props = Position.purge(atts)
   21.58 -                val info: Text.Markup = Text.Info(range, XML.Elem(Markup(name, props), args))
   21.59 -                state.add_markup(info)
   21.60 -              case _ =>
   21.61 -                // FIXME java.lang.System.err.println("Ignored report message: " + msg)
   21.62 -                state
   21.63 +            {
   21.64 +              def bad(): Unit = java.lang.System.err.println("Ignored report message: " + msg)
   21.65 +
   21.66 +              msg match {
   21.67 +                case XML.Elem(Markup(name, atts @ Position.Reported(id, file_name, raw_range)), args)
   21.68 +                if id == command.id || id == alt_id =>
   21.69 +                  command.chunks.get(file_name) match {
   21.70 +                    case Some(chunk) =>
   21.71 +                      val range = chunk.decode(raw_range)
   21.72 +                      if (chunk.range.contains(range)) {
   21.73 +                        val props = Position.purge(atts)
   21.74 +                        val info: Text.Markup = Text.Info(range, XML.Elem(Markup(name, props), args))
   21.75 +                        state.add_markup(file_name, info)
   21.76 +                      }
   21.77 +                      else {
   21.78 +                        bad()
   21.79 +                        state
   21.80 +                      }
   21.81 +                    case None =>
   21.82 +                      bad()
   21.83 +                      state
   21.84 +                  }
   21.85 +
   21.86 +                case XML.Elem(Markup(name, atts), args)
   21.87 +                if !atts.exists({ case (a, _) => Markup.POSITION_PROPERTIES(a) }) =>
   21.88 +                  val range = command.proper_range
   21.89 +                  val props = Position.purge(atts)
   21.90 +                  val info: Text.Markup = Text.Info(range, XML.Elem(Markup(name, props), args))
   21.91 +                  state.add_markup("", info)
   21.92 +
   21.93 +                case _ =>
   21.94 +                  // FIXME bad()
   21.95 +                  state
   21.96 +              }
   21.97              })
   21.98          case XML.Elem(Markup(name, props), body) =>
   21.99            props match {
  21.100 @@ -117,14 +141,15 @@
  21.101                val message1 = XML.Elem(Markup(Markup.message(name), props), body)
  21.102                val message2 = XML.Elem(Markup(name, props), body)
  21.103  
  21.104 -              val st0 = copy(results = results + (i -> message1))
  21.105 -              val st1 =
  21.106 -                if (Protocol.is_inlined(message))
  21.107 -                  (st0 /: Protocol.message_positions(command, message))(
  21.108 -                    (st, range) => st.add_markup(Text.Info(range, message2)))
  21.109 -                else st0
  21.110 +              var st = copy(results = results + (i -> message1))
  21.111 +              if (Protocol.is_inlined(message)) {
  21.112 +                for {
  21.113 +                  (file_name, chunk) <- command.chunks
  21.114 +                  range <- Protocol.message_positions(command.id, alt_id, chunk, message)
  21.115 +                } st = st.add_markup(file_name, Text.Info(range, message2))
  21.116 +              }
  21.117 +              st
  21.118  
  21.119 -              st1
  21.120              case _ =>
  21.121                java.lang.System.err.println("Ignored message without serial number: " + message)
  21.122                this
  21.123 @@ -135,7 +160,32 @@
  21.124        copy(
  21.125          status = other.status ::: status,
  21.126          results = results ++ other.results,
  21.127 -        markup = markup ++ other.markup)
  21.128 +        markups =
  21.129 +          (markups.keySet ++ other.markups.keySet)
  21.130 +            .map(a => a -> (get_markup(a) ++ other.get_markup(a))).toMap
  21.131 +      )
  21.132 +  }
  21.133 +
  21.134 +
  21.135 +
  21.136 +  /** static content **/
  21.137 +
  21.138 +  /* text chunks */
  21.139 +
  21.140 +  abstract class Chunk
  21.141 +  {
  21.142 +    def file_name: String
  21.143 +    def length: Int
  21.144 +    def range: Text.Range
  21.145 +    def decode(r: Text.Range): Text.Range
  21.146 +  }
  21.147 +
  21.148 +  class File(val file_name: String, text: CharSequence) extends Chunk
  21.149 +  {
  21.150 +    val length = text.length
  21.151 +    val range = Text.Range(0, length)
  21.152 +    private val symbol_index = Symbol.Index(text)
  21.153 +    def decode(r: Text.Range): Text.Range = symbol_index.decode(r)
  21.154    }
  21.155  
  21.156  
  21.157 @@ -144,7 +194,7 @@
  21.158    def name(span: List[Token]): String =
  21.159      span.find(_.is_command) match { case Some(tok) => tok.source case _ => "" }
  21.160  
  21.161 -  type Blob = Exn.Result[(Document.Node.Name, Option[SHA1.Digest])]
  21.162 +  type Blob = Exn.Result[(Document.Node.Name, Option[(SHA1.Digest, File)])]
  21.163  
  21.164    def apply(
  21.165      id: Document_ID.Command,
  21.166 @@ -220,6 +270,7 @@
  21.167      val source: String,
  21.168      val init_results: Command.Results,
  21.169      val init_markup: Markup_Tree)
  21.170 +  extends Command.Chunk
  21.171  {
  21.172    /* classification */
  21.173  
  21.174 @@ -243,11 +294,17 @@
  21.175      for (Exn.Res((name, _)) <- blobs) yield name
  21.176  
  21.177    def blobs_digests: List[SHA1.Digest] =
  21.178 -    for (Exn.Res((_, Some(digest))) <- blobs) yield digest
  21.179 +    for (Exn.Res((_, Some((digest, _)))) <- blobs) yield digest
  21.180 +
  21.181 +  val chunks: Map[String, Command.Chunk] =
  21.182 +    (("" -> this) ::
  21.183 +      (for (Exn.Res((name, Some((_, file)))) <- blobs) yield (name.node -> file))).toMap
  21.184  
  21.185  
  21.186    /* source */
  21.187  
  21.188 +  def file_name: String = ""
  21.189 +
  21.190    def length: Int = source.length
  21.191    val range: Text.Range = Text.Range(0, length)
  21.192  
  21.193 @@ -256,7 +313,7 @@
  21.194  
  21.195    def source(range: Text.Range): String = source.substring(range.start, range.stop)
  21.196  
  21.197 -  lazy val symbol_index = Symbol.Index(source)
  21.198 +  private lazy val symbol_index = Symbol.Index(source)
  21.199    def decode(i: Text.Offset): Text.Offset = symbol_index.decode(i)
  21.200    def decode(r: Text.Range): Text.Range = symbol_index.decode(r)
  21.201  
  21.202 @@ -264,7 +321,7 @@
  21.203    /* accumulated results */
  21.204  
  21.205    val init_state: Command.State =
  21.206 -    Command.State(this, results = init_results, markup = init_markup)
  21.207 +    Command.State(this, results = init_results, markups = Map("" -> init_markup))
  21.208  
  21.209    val empty_state: Command.State = Command.State(this)
  21.210  }
    22.1 --- a/src/Pure/PIDE/document.scala	Wed Feb 12 10:59:25 2014 +0100
    22.2 +++ b/src/Pure/PIDE/document.scala	Wed Feb 12 14:32:45 2014 +0100
    22.3 @@ -47,7 +47,7 @@
    22.4    type Edit_Text = Edit[Text.Edit, Text.Perspective]
    22.5    type Edit_Command = Edit[Command.Edit, Command.Perspective]
    22.6  
    22.7 -  type Blobs = Map[Node.Name, Bytes]
    22.8 +  type Blobs = Map[Node.Name, (Bytes, Command.File)]
    22.9  
   22.10    object Node
   22.11    {
   22.12 @@ -192,6 +192,7 @@
   22.13    }
   22.14  
   22.15    final class Node private(
   22.16 +    val is_blob: Boolean = false,
   22.17      val header: Node.Header = Node.bad_header("Bad theory header"),
   22.18      val perspective: Node.Perspective_Command =
   22.19        Node.Perspective(false, Command.Perspective.empty, Node.Overlays.empty),
   22.20 @@ -199,11 +200,13 @@
   22.21    {
   22.22      def clear: Node = new Node(header = header)
   22.23  
   22.24 +    def init_blob: Node = new Node(is_blob = true)
   22.25 +
   22.26      def update_header(new_header: Node.Header): Node =
   22.27 -      new Node(new_header, perspective, _commands)
   22.28 +      new Node(is_blob, new_header, perspective, _commands)
   22.29  
   22.30      def update_perspective(new_perspective: Node.Perspective_Command): Node =
   22.31 -      new Node(header, new_perspective, _commands)
   22.32 +      new Node(is_blob, header, new_perspective, _commands)
   22.33  
   22.34      def same_perspective(other_perspective: Node.Perspective_Command): Boolean =
   22.35        perspective.required == other_perspective.required &&
   22.36 @@ -215,7 +218,7 @@
   22.37  
   22.38      def update_commands(new_commands: Linear_Set[Command]): Node =
   22.39        if (new_commands eq _commands.commands) this
   22.40 -      else new Node(header, perspective, Node.Commands(new_commands))
   22.41 +      else new Node(is_blob, header, perspective, Node.Commands(new_commands))
   22.42  
   22.43      def command_range(i: Text.Offset = 0): Iterator[(Command, Text.Offset)] =
   22.44        _commands.range(i)
   22.45 @@ -361,6 +364,7 @@
   22.46  
   22.47      val node_name: Node.Name
   22.48      val node: Node
   22.49 +    val thy_load_commands: List[Command]
   22.50      def eq_content(other: Snapshot): Boolean
   22.51      def cumulate_markup[A](
   22.52        range: Text.Range,
   22.53 @@ -608,28 +612,51 @@
   22.54          val node_name = name
   22.55          val node = version.nodes(name)
   22.56  
   22.57 +        val thy_load_commands: List[Command] =
   22.58 +          if (node_name.is_theory) Nil
   22.59 +          else version.nodes.thy_load_commands(node_name)
   22.60 +
   22.61          def eq_content(other: Snapshot): Boolean =
   22.62 +        {
   22.63 +          def eq_commands(commands: (Command, Command)): Boolean =
   22.64 +            state.command_state(version, commands._1) eq_content
   22.65 +              other.state.command_state(other.version, commands._2)
   22.66 +
   22.67            !is_outdated && !other.is_outdated &&
   22.68 -            node.commands.size == other.node.commands.size &&
   22.69 -            ((node.commands.iterator zip other.node.commands.iterator) forall {
   22.70 -              case (cmd1, cmd2) =>
   22.71 -                state.command_state(version, cmd1) eq_content
   22.72 -                  other.state.command_state(other.version, cmd2)
   22.73 -            })
   22.74 +          node.commands.size == other.node.commands.size &&
   22.75 +          (node.commands.iterator zip other.node.commands.iterator).forall(eq_commands) &&
   22.76 +          thy_load_commands.length == other.thy_load_commands.length &&
   22.77 +          (thy_load_commands zip other.thy_load_commands).forall(eq_commands)
   22.78 +        }
   22.79  
   22.80          def cumulate_markup[A](range: Text.Range, info: A, elements: Option[Set[String]],
   22.81            result: Command.State => (A, Text.Markup) => Option[A]): List[Text.Info[A]] =
   22.82          {
   22.83            val former_range = revert(range)
   22.84 -          (for {
   22.85 -            (command, command_start) <- node.command_range(former_range)
   22.86 -            st = state.command_state(version, command)
   22.87 -            res = result(st)
   22.88 -            Text.Info(r0, a) <- st.markup.cumulate[A](
   22.89 -              (former_range - command_start).restrict(command.range), info, elements,
   22.90 -              { case (a, Text.Info(r0, b)) => res(a, Text.Info(convert(r0 + command_start), b)) }
   22.91 -            ).iterator
   22.92 -          } yield Text.Info(convert(r0 + command_start), a)).toList
   22.93 +          thy_load_commands match {
   22.94 +            case thy_load_command :: _ =>
   22.95 +              val file_name = node_name.node
   22.96 +              (for {
   22.97 +                chunk <- thy_load_command.chunks.get(file_name).iterator
   22.98 +                st = state.command_state(version, thy_load_command)
   22.99 +                res = result(st)
  22.100 +                Text.Info(r0, a) <- st.get_markup(file_name).cumulate[A](
  22.101 +                  former_range.restrict(chunk.range), info, elements,
  22.102 +                  { case (a, Text.Info(r0, b)) => res(a, Text.Info(convert(r0), b)) }
  22.103 +                ).iterator
  22.104 +              } yield Text.Info(convert(r0), a)).toList
  22.105 +
  22.106 +            case _ =>
  22.107 +              (for {
  22.108 +                (command, command_start) <- node.command_range(former_range)
  22.109 +                st = state.command_state(version, command)
  22.110 +                res = result(st)
  22.111 +                Text.Info(r0, a) <- st.markup.cumulate[A](
  22.112 +                  (former_range - command_start).restrict(command.range), info, elements,
  22.113 +                  { case (a, Text.Info(r0, b)) => res(a, Text.Info(convert(r0 + command_start), b)) }
  22.114 +                ).iterator
  22.115 +              } yield Text.Info(convert(r0 + command_start), a)).toList
  22.116 +          }
  22.117          }
  22.118  
  22.119          def select_markup[A](range: Text.Range, elements: Option[Set[String]],
    23.1 --- a/src/Pure/PIDE/protocol.scala	Wed Feb 12 10:59:25 2014 +0100
    23.2 +++ b/src/Pure/PIDE/protocol.scala	Wed Feb 12 14:32:45 2014 +0100
    23.3 @@ -274,33 +274,32 @@
    23.4  
    23.5    private val include_pos = Set(Markup.BINDING, Markup.ENTITY, Markup.REPORT, Markup.POSITION)
    23.6  
    23.7 -  def message_positions(command: Command, message: XML.Elem): Set[Text.Range] =
    23.8 +  def message_positions(
    23.9 +    command_id: Document_ID.Command,
   23.10 +    alt_id: Document_ID.Generic,
   23.11 +    chunk: Command.Chunk,
   23.12 +    message: XML.Elem): Set[Text.Range] =
   23.13    {
   23.14 -    def elem_positions(raw_range: Text.Range, set: Set[Text.Range], body: XML.Body)
   23.15 -      : Set[Text.Range] =
   23.16 -    {
   23.17 -      val range = command.decode(raw_range).restrict(command.range)
   23.18 -      body.foldLeft(if (range.is_singularity) set else set + range)(positions)
   23.19 -    }
   23.20 +    def elem_positions(props: Properties.T, set: Set[Text.Range]): Set[Text.Range] =
   23.21 +      props match {
   23.22 +        case Position.Reported(id, file_name, range)
   23.23 +        if (id == command_id || id == alt_id) && file_name == chunk.file_name =>
   23.24 +          val range1 = chunk.decode(range).restrict(chunk.range)
   23.25 +          if (range1.is_singularity) set else set + range1
   23.26 +        case _ => set
   23.27 +      }
   23.28  
   23.29      def positions(set: Set[Text.Range], tree: XML.Tree): Set[Text.Range] =
   23.30        tree match {
   23.31 -        case XML.Wrapped_Elem(Markup(name, Position.Id_Range(id, range)), _, body)
   23.32 -        if include_pos(name) && id == command.id => elem_positions(range, set, body)
   23.33 -
   23.34 -        case XML.Elem(Markup(name, Position.Id_Range(id, range)), body)
   23.35 -        if include_pos(name) && id == command.id => elem_positions(range, set, body)
   23.36 -
   23.37 -        case XML.Wrapped_Elem(_, _, body) => body.foldLeft(set)(positions)
   23.38 -
   23.39 -        case XML.Elem(_, body) => body.foldLeft(set)(positions)
   23.40 -
   23.41 -        case _ => set
   23.42 +        case XML.Wrapped_Elem(Markup(name, props), _, body) =>
   23.43 +          body.foldLeft(if (include_pos(name)) elem_positions(props, set) else set)(positions)
   23.44 +        case XML.Elem(Markup(name, props), body) =>
   23.45 +          body.foldLeft(if (include_pos(name)) elem_positions(props, set) else set)(positions)
   23.46 +        case XML.Text(_) => set
   23.47        }
   23.48  
   23.49      val set = positions(Set.empty, message)
   23.50 -    if (set.isEmpty)
   23.51 -      set ++ Position.Range.unapply(message.markup.properties).map(command.decode(_))
   23.52 +    if (set.isEmpty) elem_positions(message.markup.properties, set)
   23.53      else set
   23.54    }
   23.55  }
   23.56 @@ -323,7 +322,7 @@
   23.57        val encode_blob: T[Command.Blob] =
   23.58          variant(List(
   23.59            { case Exn.Res((a, b)) =>
   23.60 -              (Nil, pair(string, option(string))((a.node, b.map(_.toString)))) },
   23.61 +              (Nil, pair(string, option(string))((a.node, b.map(p => p._1.toString)))) },
   23.62            { case Exn.Exn(e) => (Nil, string(Exn.message(e))) }))
   23.63        YXML.string_of_body(list(encode_blob)(command.blobs))
   23.64      }
    24.1 --- a/src/Pure/System/session.scala	Wed Feb 12 10:59:25 2014 +0100
    24.2 +++ b/src/Pure/System/session.scala	Wed Feb 12 14:32:45 2014 +0100
    24.3 @@ -379,7 +379,7 @@
    24.4            digest <- command.blobs_digests
    24.5            if !global_state().defined_blob(digest)
    24.6          } {
    24.7 -          doc_blobs.collectFirst({ case (_, b) if b.sha1_digest == digest => b }) match {
    24.8 +          doc_blobs.collectFirst({ case (_, (b, _)) if b.sha1_digest == digest => b }) match {
    24.9              case Some(blob) =>
   24.10                global_state >> (_.define_blob(digest))
   24.11                prover.get.define_blob(blob)
    25.1 --- a/src/Pure/Thy/thy_syntax.scala	Wed Feb 12 10:59:25 2014 +0100
    25.2 +++ b/src/Pure/Thy/thy_syntax.scala	Wed Feb 12 14:32:45 2014 +0100
    25.3 @@ -264,11 +264,16 @@
    25.4        doc_blobs: Document.Blobs)
    25.5      : List[Command.Blob] =
    25.6    {
    25.7 -    span_files(syntax, span).map(file =>
    25.8 +    span_files(syntax, span).map(file_name =>
    25.9        Exn.capture {
   25.10          val name =
   25.11 -          Document.Node.Name(thy_load.append(node_name.master_dir, Path.explode(file)))
   25.12 -        (name, doc_blobs.get(name).map(_.sha1_digest))
   25.13 +          Document.Node.Name(thy_load.append(node_name.master_dir, Path.explode(file_name)))
   25.14 +        val blob =
   25.15 +          doc_blobs.get(name) match {
   25.16 +            case Some((bytes, file)) => Some((bytes.sha1_digest, file))
   25.17 +            case None => None
   25.18 +          }
   25.19 +        (name, blob)
   25.20        }
   25.21      )
   25.22    }
   25.23 @@ -402,14 +407,17 @@
   25.24      edit match {
   25.25        case (_, Document.Node.Clear()) => node.clear
   25.26  
   25.27 -      case (_, Document.Node.Blob()) => node
   25.28 +      case (_, Document.Node.Blob()) => node.init_blob
   25.29  
   25.30        case (name, Document.Node.Edits(text_edits)) =>
   25.31 -        val commands0 = node.commands
   25.32 -        val commands1 = edit_text(text_edits, commands0)
   25.33 -        val commands2 =
   25.34 -          recover_spans(thy_load, syntax, doc_blobs, name, node.perspective.visible, commands1)
   25.35 -        node.update_commands(commands2)
   25.36 +        if (node.is_blob) node
   25.37 +        else {
   25.38 +          val commands0 = node.commands
   25.39 +          val commands1 = edit_text(text_edits, commands0)
   25.40 +          val commands2 =
   25.41 +            recover_spans(thy_load, syntax, doc_blobs, name, node.perspective.visible, commands1)
   25.42 +          node.update_commands(commands2)
   25.43 +        }
   25.44  
   25.45        case (_, Document.Node.Deps(_)) => node
   25.46  
    26.1 --- a/src/Tools/jEdit/src/document_model.scala	Wed Feb 12 10:59:25 2014 +0100
    26.2 +++ b/src/Tools/jEdit/src/document_model.scala	Wed Feb 12 14:32:45 2014 +0100
    26.3 @@ -106,10 +106,13 @@
    26.4        val snapshot = this.snapshot()
    26.5  
    26.6        val document_view_ranges =
    26.7 -        for {
    26.8 -          doc_view <- PIDE.document_views(buffer)
    26.9 -          range <- doc_view.perspective(snapshot).ranges
   26.10 -        } yield range
   26.11 +        if (is_theory) {
   26.12 +          for {
   26.13 +            doc_view <- PIDE.document_views(buffer)
   26.14 +            range <- doc_view.perspective(snapshot).ranges
   26.15 +          } yield range
   26.16 +        }
   26.17 +        else Nil
   26.18  
   26.19        val thy_load_ranges =
   26.20          for {
   26.21 @@ -131,18 +134,19 @@
   26.22  
   26.23    /* blob */
   26.24  
   26.25 -  private var _blob: Option[Bytes] = None  // owned by Swing thread
   26.26 +  private var _blob: Option[(Bytes, Command.File)] = None  // owned by Swing thread
   26.27  
   26.28    private def reset_blob(): Unit = Swing_Thread.require { _blob = None }
   26.29  
   26.30 -  def blob(): Bytes =
   26.31 +  def blob(): (Bytes, Command.File) =
   26.32      Swing_Thread.require {
   26.33        _blob match {
   26.34 -        case Some(b) => b
   26.35 +        case Some(x) => x
   26.36          case None =>
   26.37            val b = PIDE.thy_load.file_content(buffer)
   26.38 -          _blob = Some(b)
   26.39 -          b
   26.40 +          val file = new Command.File(node_name.node, buffer.getSegment(0, buffer.getLength))
   26.41 +          _blob = Some((b, file))
   26.42 +          (b, file)
   26.43        }
   26.44      }
   26.45  
   26.46 @@ -163,7 +167,8 @@
   26.47          node_name -> Document.Node.Edits(List(Text.Edit.insert(0, text))),
   26.48          node_name -> perspective)
   26.49      else
   26.50 -      List(node_name -> Document.Node.Blob())
   26.51 +      List(node_name -> Document.Node.Blob(),
   26.52 +        node_name -> Document.Node.Edits(List(Text.Edit.insert(0, text))))
   26.53    }
   26.54  
   26.55    def node_edits(
   26.56 @@ -186,7 +191,8 @@
   26.57            node_name -> perspective)
   26.58      }
   26.59      else
   26.60 -      List(node_name -> Document.Node.Blob())
   26.61 +      List(node_name -> Document.Node.Blob(),
   26.62 +        node_name -> Document.Node.Edits(text_edits))
   26.63    }
   26.64  
   26.65  
    27.1 --- a/src/Tools/jEdit/src/document_view.scala	Wed Feb 12 10:59:25 2014 +0100
    27.2 +++ b/src/Tools/jEdit/src/document_view.scala	Wed Feb 12 14:32:45 2014 +0100
    27.3 @@ -210,14 +210,18 @@
    27.4                if (model.buffer == text_area.getBuffer) {
    27.5                  val snapshot = model.snapshot()
    27.6  
    27.7 -                if (changed.assignment ||
    27.8 +                val thy_load_changed =
    27.9 +                  snapshot.thy_load_commands.exists(changed.commands.contains)
   27.10 +
   27.11 +                if (changed.assignment || thy_load_changed ||
   27.12                      (changed.nodes.contains(model.node_name) &&
   27.13                       changed.commands.exists(snapshot.node.commands.contains)))
   27.14                    Swing_Thread.later { overview.delay_repaint.invoke() }
   27.15  
   27.16                  val visible_lines = text_area.getVisibleLines
   27.17                  if (visible_lines > 0) {
   27.18 -                  if (changed.assignment) text_area.invalidateScreenLineRange(0, visible_lines)
   27.19 +                  if (changed.assignment || thy_load_changed)
   27.20 +                    text_area.invalidateScreenLineRange(0, visible_lines)
   27.21                    else {
   27.22                      val visible_range = JEdit_Lib.visible_range(text_area).get
   27.23                      val visible_cmds =
    28.1 --- a/src/Tools/jEdit/src/isabelle_sidekick.scala	Wed Feb 12 10:59:25 2014 +0100
    28.2 +++ b/src/Tools/jEdit/src/isabelle_sidekick.scala	Wed Feb 12 14:32:45 2014 +0100
    28.3 @@ -148,8 +148,9 @@
    28.4  {
    28.5    override def parser(buffer: Buffer, syntax: Outer_Syntax, data: SideKickParsedData): Boolean =
    28.6    {
    28.7 -    Swing_Thread.now { Document_Model(buffer).map(_.snapshot) } match {
    28.8 -      case Some(snapshot) =>
    28.9 +    Swing_Thread.now { Document_Model(buffer) } match {
   28.10 +      case Some(model) if model.is_theory =>
   28.11 +        val snapshot = model.snapshot
   28.12          val root = data.root
   28.13          for ((command, command_start) <- snapshot.node.command_range() if !stopped) {
   28.14            Isabelle_Sidekick.swing_markup_tree(
   28.15 @@ -171,7 +172,7 @@
   28.16                })
   28.17          }
   28.18          true
   28.19 -      case None => false
   28.20 +      case _ => false
   28.21      }
   28.22    }
   28.23  }
    29.1 --- a/src/Tools/jEdit/src/jedit_editor.scala	Wed Feb 12 10:59:25 2014 +0100
    29.2 +++ b/src/Tools/jEdit/src/jedit_editor.scala	Wed Feb 12 14:32:45 2014 +0100
    29.3 @@ -69,7 +69,7 @@
    29.4      val buffer = view.getBuffer
    29.5  
    29.6      PIDE.document_view(text_area) match {
    29.7 -      case Some(doc_view) =>
    29.8 +      case Some(doc_view) if doc_view.model.is_theory =>
    29.9          val node = snapshot.version.nodes(doc_view.model.node_name)
   29.10          val caret = snapshot.revert(text_area.getCaretPosition)
   29.11          if (caret < buffer.getLength) {
   29.12 @@ -81,7 +81,7 @@
   29.13            else None
   29.14          }
   29.15          else node.commands.reverse.iterator.find(cmd => !cmd.is_ignored)
   29.16 -      case None =>
   29.17 +      case _ =>
   29.18          PIDE.document_model(buffer) match {
   29.19            case Some(model) if !model.is_theory =>
   29.20              snapshot.version.nodes.thy_load_commands(model.node_name) match {
    30.1 --- a/src/Tools/jEdit/src/plugin.scala	Wed Feb 12 10:59:25 2014 +0100
    30.2 +++ b/src/Tools/jEdit/src/plugin.scala	Wed Feb 12 14:32:45 2014 +0100
    30.3 @@ -114,12 +114,10 @@
    30.4                      val model = Document_Model.init(session, buffer, node_name)
    30.5                      (model.init_edits(), model)
    30.6                  }
    30.7 -              if (model.is_theory) {
    30.8 -                for (text_area <- JEdit_Lib.jedit_text_areas(buffer)) {
    30.9 -                  if (document_view(text_area).map(_.model) != Some(model))
   30.10 -                    Document_View.init(model, text_area)
   30.11 -                }
   30.12 -              }
   30.13 +              for {
   30.14 +                text_area <- JEdit_Lib.jedit_text_areas(buffer)
   30.15 +                if document_view(text_area).map(_.model) != Some(model)
   30.16 +              } Document_View.init(model, text_area)
   30.17                model_edits ::: edits
   30.18              }
   30.19            }
   30.20 @@ -132,8 +130,8 @@
   30.21    {
   30.22      JEdit_Lib.swing_buffer_lock(buffer) {
   30.23        document_model(buffer) match {
   30.24 -        case Some(model) if model.is_theory => Document_View.init(model, text_area)
   30.25 -        case _ =>
   30.26 +        case Some(model) => Document_View.init(model, text_area)
   30.27 +        case None =>
   30.28        }
   30.29      }
   30.30    }