moved predicate compiler to Tools
authorbulwahn
Wed Sep 23 16:20:12 2009 +0200 (2009-09-23)
changeset 3266709546e654222
parent 32666 fd96d5f49d59
child 32668 b2de45007537
moved predicate compiler to Tools
src/HOL/IsaMakefile
src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML
src/HOL/ex/Predicate_Compile.thy
src/HOL/ex/predicate_compile.ML
     1.1 --- a/src/HOL/IsaMakefile	Wed Sep 23 16:20:12 2009 +0200
     1.2 +++ b/src/HOL/IsaMakefile	Wed Sep 23 16:20:12 2009 +0200
     1.3 @@ -6,7 +6,7 @@
     1.4  
     1.5  default: HOL
     1.6  generate: HOL-Generate-HOL HOL-Generate-HOLLight
     1.7 -images: HOL HOL-Base HOL-Plain HOL-Main HOL-Algebra HOL-Nominal HOL-NSA HOL-Word TLA HOL4 HOL-MicroJava
     1.8 +images: HOL HOL-Base HOL-Plain HOL-Main HOL-Algebra HOL-Nominal HOL-NSA HOL-Word TLA HOL4
     1.9  
    1.10  #Note: keep targets sorted (except for HOL-Library and HOL-ex)
    1.11  test: \
    1.12 @@ -909,7 +909,7 @@
    1.13    ex/Sudoku.thy ex/Tarski.thy \
    1.14    ex/Termination.thy ex/Transfer_Ex.thy ex/Unification.thy ex/document/root.bib		\
    1.15    ex/document/root.tex ex/set.thy ex/svc_funcs.ML ex/svc_test.thy \
    1.16 -  ex/Predicate_Compile.thy ex/predicate_compile.ML ex/Predicate_Compile_ex.thy
    1.17 +  ex/Predicate_Compile.thy Tools/Predicate_Compile/predicate_compile_core.ML ex/Predicate_Compile_ex.thy
    1.18  	@$(ISABELLE_TOOL) usedir $(OUT)/HOL ex
    1.19  
    1.20  
     2.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML	Wed Sep 23 16:20:12 2009 +0200
     2.3 @@ -0,0 +1,2400 @@
     2.4 +(* Author: Lukas Bulwahn, TU Muenchen
     2.5 +
     2.6 +(Prototype of) A compiler from predicates specified by intro/elim rules
     2.7 +to equations.
     2.8 +*)
     2.9 +
    2.10 +signature PREDICATE_COMPILE_CORE =
    2.11 +sig
    2.12 +  type smode = (int * int list option) list
    2.13 +  type mode = smode option list * smode
    2.14 +  datatype tmode = Mode of mode * smode * tmode option list;
    2.15 +  (*val add_equations_of: bool -> string list -> theory -> theory *)
    2.16 +  val register_predicate : (thm list * thm * int) -> theory -> theory
    2.17 +  val is_registered : theory -> string -> bool
    2.18 + (* val fetch_pred_data : theory -> string -> (thm list * thm * int)  *)
    2.19 +  val predfun_intro_of: theory -> string -> mode -> thm
    2.20 +  val predfun_elim_of: theory -> string -> mode -> thm
    2.21 +  val strip_intro_concl: int -> term -> term * (term list * term list)
    2.22 +  val predfun_name_of: theory -> string -> mode -> string
    2.23 +  val all_preds_of : theory -> string list
    2.24 +  val modes_of: theory -> string -> mode list
    2.25 +  val string_of_mode : mode -> string
    2.26 +  val intros_of: theory -> string -> thm list
    2.27 +  val nparams_of: theory -> string -> int
    2.28 +  val add_intro: thm -> theory -> theory
    2.29 +  val set_elim: thm -> theory -> theory
    2.30 +  val setup: theory -> theory
    2.31 +  val code_pred: string -> Proof.context -> Proof.state
    2.32 +  val code_pred_cmd: string -> Proof.context -> Proof.state
    2.33 +  val print_stored_rules: theory -> unit
    2.34 +  val print_all_modes: theory -> unit
    2.35 +  val do_proofs: bool ref
    2.36 +  val mk_casesrule : Proof.context -> int -> thm list -> term
    2.37 +  val analyze_compr: theory -> term -> term
    2.38 +  val eval_ref: (unit -> term Predicate.pred) option ref
    2.39 +  val add_equations : string list -> theory -> theory
    2.40 +  val code_pred_intros_attrib : attribute
    2.41 +  (* used by Quickcheck_Generator *) 
    2.42 +  (*val funT_of : mode -> typ -> typ
    2.43 +  val mk_if_pred : term -> term
    2.44 +  val mk_Eval : term * term -> term*)
    2.45 +  val mk_tupleT : typ list -> typ
    2.46 +(*  val mk_predT :  typ -> typ *)
    2.47 +  (* temporary for testing of the compilation *)
    2.48 +  datatype indprem = Prem of term list * term | Negprem of term list * term | Sidecond of term |
    2.49 +    GeneratorPrem of term list * term | Generator of (string * typ);
    2.50 + (* val prepare_intrs: theory -> string list ->
    2.51 +    (string * typ) list * int * string list * string list * (string * mode list) list *
    2.52 +    (string * (term list * indprem list) list) list * (string * (int option list * int)) list*)
    2.53 +  datatype compilation_funs = CompilationFuns of {
    2.54 +    mk_predT : typ -> typ,
    2.55 +    dest_predT : typ -> typ,
    2.56 +    mk_bot : typ -> term,
    2.57 +    mk_single : term -> term,
    2.58 +    mk_bind : term * term -> term,
    2.59 +    mk_sup : term * term -> term,
    2.60 +    mk_if : term -> term,
    2.61 +    mk_not : term -> term,
    2.62 +    mk_map : typ -> typ -> term -> term -> term,
    2.63 +    lift_pred : term -> term
    2.64 +  };  
    2.65 +  type moded_clause = term list * (indprem * tmode) list
    2.66 +  type 'a pred_mode_table = (string * (mode * 'a) list) list
    2.67 +  val infer_modes : theory -> (string * mode list) list
    2.68 +    -> (string * mode list) list
    2.69 +    -> string list
    2.70 +    -> (string * (term list * indprem list) list) list
    2.71 +    -> (moded_clause list) pred_mode_table
    2.72 +  val infer_modes_with_generator : theory -> (string * mode list) list
    2.73 +    -> (string * mode list) list
    2.74 +    -> string list
    2.75 +    -> (string * (term list * indprem list) list) list
    2.76 +    -> (moded_clause list) pred_mode_table  
    2.77 +  (*val compile_preds : theory -> compilation_funs -> string list -> string list
    2.78 +    -> (string * typ) list -> (moded_clause list) pred_mode_table -> term pred_mode_table
    2.79 +  val rpred_create_definitions :(string * typ) list -> string * mode list
    2.80 +    -> theory -> theory 
    2.81 +  val split_smode : int list -> term list -> (term list * term list) *)
    2.82 +  val print_moded_clauses :
    2.83 +    theory -> (moded_clause list) pred_mode_table -> unit
    2.84 +  val print_compiled_terms : theory -> term pred_mode_table -> unit
    2.85 +  (*val rpred_prove_preds : theory -> term pred_mode_table -> thm pred_mode_table*)
    2.86 +  val rpred_compfuns : compilation_funs
    2.87 +  val dest_funT : typ -> typ * typ
    2.88 + (* val depending_preds_of : theory -> thm list -> string list *)
    2.89 +  val add_quickcheck_equations : string list -> theory -> theory
    2.90 +  val add_sizelim_equations : string list -> theory -> theory
    2.91 +  val is_inductive_predicate : theory -> string -> bool
    2.92 +  val terms_vs : term list -> string list
    2.93 +  val subsets : int -> int -> int list list
    2.94 +  val check_mode_clause : bool -> theory -> string list ->
    2.95 +    (string * mode list) list -> (string * mode list) list -> mode -> (term list * indprem list)
    2.96 +      -> (term list * (indprem * tmode) list) option
    2.97 +  val string_of_moded_prem : theory -> (indprem * tmode) -> string
    2.98 +  val all_modes_of : theory -> (string * mode list) list
    2.99 +  val all_generator_modes_of : theory -> (string * mode list) list
   2.100 +  val compile_clause : compilation_funs -> term option -> (term list -> term) ->
   2.101 +    theory -> string list -> string list -> mode -> term -> moded_clause -> term
   2.102 +  val preprocess_intro : theory -> thm -> thm
   2.103 +  val is_constrt : theory -> term -> bool
   2.104 +  val is_predT : typ -> bool
   2.105 +  val guess_nparams : typ -> int
   2.106 +  val cprods_subset : 'a list list -> 'a list list
   2.107 +end;
   2.108 +
   2.109 +structure Predicate_Compile_Core : PREDICATE_COMPILE_CORE =
   2.110 +struct
   2.111 +
   2.112 +(** auxiliary **)
   2.113 +
   2.114 +(* debug stuff *)
   2.115 +
   2.116 +fun tracing s = (if ! Toplevel.debug then Output.tracing s else ());
   2.117 +
   2.118 +fun print_tac s = Seq.single; (*Tactical.print_tac s;*) (* (if ! Toplevel.debug then Tactical.print_tac s else Seq.single); *)
   2.119 +fun debug_tac msg = Seq.single; (* (fn st => (Output.tracing msg; Seq.single st)); *)
   2.120 +
   2.121 +val do_proofs = ref true;
   2.122 +
   2.123 +fun mycheat_tac thy i st =
   2.124 +  (Tactic.rtac (SkipProof.make_thm thy (Var (("A", 0), propT))) i) st
   2.125 +
   2.126 +fun remove_last_goal thy st =
   2.127 +  (Tactic.rtac (SkipProof.make_thm thy (Var (("A", 0), propT))) (nprems_of st)) st
   2.128 +
   2.129 +(* reference to preprocessing of InductiveSet package *)
   2.130 +
   2.131 +val ind_set_codegen_preproc = Inductive_Set.codegen_preproc;
   2.132 +
   2.133 +(** fundamentals **)
   2.134 +
   2.135 +(* syntactic operations *)
   2.136 +
   2.137 +fun mk_eq (x, xs) =
   2.138 +  let fun mk_eqs _ [] = []
   2.139 +        | mk_eqs a (b::cs) =
   2.140 +            HOLogic.mk_eq (Free (a, fastype_of b), b) :: mk_eqs a cs
   2.141 +  in mk_eqs x xs end;
   2.142 +
   2.143 +fun mk_tupleT [] = HOLogic.unitT
   2.144 +  | mk_tupleT Ts = foldr1 HOLogic.mk_prodT Ts;
   2.145 +
   2.146 +fun dest_tupleT (Type (@{type_name Product_Type.unit}, [])) = []
   2.147 +  | dest_tupleT (Type (@{type_name "*"}, [T1, T2])) = T1 :: (dest_tupleT T2)
   2.148 +  | dest_tupleT t = [t]
   2.149 +
   2.150 +fun mk_tuple [] = HOLogic.unit
   2.151 +  | mk_tuple ts = foldr1 HOLogic.mk_prod ts;
   2.152 +
   2.153 +fun dest_tuple (Const (@{const_name Product_Type.Unity}, _)) = []
   2.154 +  | dest_tuple (Const (@{const_name Pair}, _) $ t1 $ t2) = t1 :: (dest_tuple t2)
   2.155 +  | dest_tuple t = [t]
   2.156 +
   2.157 +fun mk_scomp (t, u) =
   2.158 +  let
   2.159 +    val T = fastype_of t
   2.160 +    val U = fastype_of u
   2.161 +    val [A] = binder_types T
   2.162 +    val D = body_type U 
   2.163 +  in 
   2.164 +    Const (@{const_name "scomp"}, T --> U --> A --> D) $ t $ u
   2.165 +  end;
   2.166 +
   2.167 +fun dest_funT (Type ("fun",[S, T])) = (S, T)
   2.168 +  | dest_funT T = raise TYPE ("dest_funT", [T], [])
   2.169 + 
   2.170 +fun mk_fun_comp (t, u) =
   2.171 +  let
   2.172 +    val (_, B) = dest_funT (fastype_of t)
   2.173 +    val (C, A) = dest_funT (fastype_of u)
   2.174 +  in
   2.175 +    Const(@{const_name "Fun.comp"}, (A --> B) --> (C --> A) --> C --> B) $ t $ u
   2.176 +  end;
   2.177 +
   2.178 +fun dest_randomT (Type ("fun", [@{typ Random.seed},
   2.179 +  Type ("*", [Type ("*", [T, @{typ "unit => Code_Eval.term"}]) ,@{typ Random.seed}])])) = T
   2.180 +  | dest_randomT T = raise TYPE ("dest_randomT", [T], [])
   2.181 +
   2.182 +(* destruction of intro rules *)
   2.183 +
   2.184 +(* FIXME: look for other place where this functionality was used before *)
   2.185 +fun strip_intro_concl nparams intro = let
   2.186 +  val _ $ u = Logic.strip_imp_concl intro
   2.187 +  val (pred, all_args) = strip_comb u
   2.188 +  val (params, args) = chop nparams all_args
   2.189 +in (pred, (params, args)) end
   2.190 +
   2.191 +(** data structures **)
   2.192 +
   2.193 +type smode = (int * int list option) list;
   2.194 +type mode = smode option list * smode;
   2.195 +datatype tmode = Mode of mode * smode * tmode option list;
   2.196 +
   2.197 +fun gen_split_smode (mk_tuple, strip_tuple) smode ts =
   2.198 +  let
   2.199 +    fun split_tuple' _ _ [] = ([], [])
   2.200 +    | split_tuple' is i (t::ts) =
   2.201 +      (if i mem is then apfst else apsnd) (cons t)
   2.202 +        (split_tuple' is (i+1) ts)
   2.203 +    fun split_tuple is t = split_tuple' is 1 (strip_tuple t)
   2.204 +    fun split_smode' _ _ [] = ([], [])
   2.205 +      | split_smode' smode i (t::ts) =
   2.206 +        (if i mem (map fst smode) then
   2.207 +          case (the (AList.lookup (op =) smode i)) of
   2.208 +            NONE => apfst (cons t)
   2.209 +            | SOME is =>
   2.210 +              let
   2.211 +                val (ts1, ts2) = split_tuple is t
   2.212 +                fun cons_tuple ts = if null ts then I else cons (mk_tuple ts)
   2.213 +                in (apfst (cons_tuple ts1)) o (apsnd (cons_tuple ts2)) end
   2.214 +          else apsnd (cons t))
   2.215 +        (split_smode' smode (i+1) ts)
   2.216 +  in split_smode' smode 1 ts end
   2.217 +
   2.218 +val split_smode = gen_split_smode (HOLogic.mk_tuple, HOLogic.strip_tuple)   
   2.219 +val split_smodeT = gen_split_smode (HOLogic.mk_tupleT, HOLogic.strip_tupleT)
   2.220 +
   2.221 +fun gen_split_mode split_smode (iss, is) ts =
   2.222 +  let
   2.223 +    val (t1, t2) = chop (length iss) ts 
   2.224 +  in (t1, split_smode is t2) end
   2.225 +
   2.226 +val split_mode = gen_split_mode split_smode
   2.227 +val split_modeT = gen_split_mode split_smodeT
   2.228 +
   2.229 +fun string_of_smode js =
   2.230 +    commas (map
   2.231 +      (fn (i, is) =>
   2.232 +        string_of_int i ^ (case is of NONE => ""
   2.233 +    | SOME is => "p" ^ enclose "[" "]" (commas (map string_of_int is)))) js)
   2.234 +
   2.235 +fun string_of_mode (iss, is) = space_implode " -> " (map
   2.236 +  (fn NONE => "X"
   2.237 +    | SOME js => enclose "[" "]" (string_of_smode js))
   2.238 +       (iss @ [SOME is]));
   2.239 +
   2.240 +fun string_of_tmode (Mode (predmode, termmode, param_modes)) =
   2.241 +  "predmode: " ^ (string_of_mode predmode) ^ 
   2.242 +  (if null param_modes then "" else
   2.243 +    "; " ^ "params: " ^ commas (map (the_default "NONE" o Option.map string_of_tmode) param_modes))
   2.244 +    
   2.245 +datatype indprem = Prem of term list * term | Negprem of term list * term | Sidecond of term |
   2.246 +  GeneratorPrem of term list * term | Generator of (string * typ);
   2.247 +
   2.248 +type moded_clause = term list * (indprem * tmode) list
   2.249 +type 'a pred_mode_table = (string * (mode * 'a) list) list
   2.250 +
   2.251 +datatype predfun_data = PredfunData of {
   2.252 +  name : string,
   2.253 +  definition : thm,
   2.254 +  intro : thm,
   2.255 +  elim : thm
   2.256 +};
   2.257 +
   2.258 +fun rep_predfun_data (PredfunData data) = data;
   2.259 +fun mk_predfun_data (name, definition, intro, elim) =
   2.260 +  PredfunData {name = name, definition = definition, intro = intro, elim = elim}
   2.261 +
   2.262 +datatype function_data = FunctionData of {
   2.263 +  name : string,
   2.264 +  equation : thm option (* is not used at all? *)
   2.265 +};
   2.266 +
   2.267 +fun rep_function_data (FunctionData data) = data;
   2.268 +fun mk_function_data (name, equation) =
   2.269 +  FunctionData {name = name, equation = equation}
   2.270 +
   2.271 +datatype pred_data = PredData of {
   2.272 +  intros : thm list,
   2.273 +  elim : thm option,
   2.274 +  nparams : int,
   2.275 +  functions : (mode * predfun_data) list,
   2.276 +  generators : (mode * function_data) list,
   2.277 +  sizelim_functions : (mode * function_data) list 
   2.278 +};
   2.279 +
   2.280 +fun rep_pred_data (PredData data) = data;
   2.281 +fun mk_pred_data ((intros, elim, nparams), (functions, generators, sizelim_functions)) =
   2.282 +  PredData {intros = intros, elim = elim, nparams = nparams,
   2.283 +    functions = functions, generators = generators, sizelim_functions = sizelim_functions}
   2.284 +fun map_pred_data f (PredData {intros, elim, nparams, functions, generators, sizelim_functions}) =
   2.285 +  mk_pred_data (f ((intros, elim, nparams), (functions, generators, sizelim_functions)))
   2.286 +  
   2.287 +fun eq_option eq (NONE, NONE) = true
   2.288 +  | eq_option eq (SOME x, SOME y) = eq (x, y)
   2.289 +  | eq_option eq _ = false
   2.290 +  
   2.291 +fun eq_pred_data (PredData d1, PredData d2) = 
   2.292 +  eq_list (Thm.eq_thm) (#intros d1, #intros d2) andalso
   2.293 +  eq_option (Thm.eq_thm) (#elim d1, #elim d2) andalso
   2.294 +  #nparams d1 = #nparams d2
   2.295 +  
   2.296 +structure PredData = TheoryDataFun
   2.297 +(
   2.298 +  type T = pred_data Graph.T;
   2.299 +  val empty = Graph.empty;
   2.300 +  val copy = I;
   2.301 +  val extend = I;
   2.302 +  fun merge _ = Graph.merge eq_pred_data;
   2.303 +);
   2.304 +
   2.305 +(* queries *)
   2.306 +
   2.307 +fun lookup_pred_data thy name =
   2.308 +  Option.map rep_pred_data (try (Graph.get_node (PredData.get thy)) name)
   2.309 +
   2.310 +fun the_pred_data thy name = case lookup_pred_data thy name
   2.311 + of NONE => error ("No such predicate " ^ quote name)  
   2.312 +  | SOME data => data;
   2.313 +
   2.314 +val is_registered = is_some oo lookup_pred_data 
   2.315 +
   2.316 +val all_preds_of = Graph.keys o PredData.get
   2.317 +
   2.318 +fun intros_of thy = map (Thm.transfer thy) o #intros o the_pred_data thy
   2.319 +
   2.320 +fun the_elim_of thy name = case #elim (the_pred_data thy name)
   2.321 + of NONE => error ("No elimination rule for predicate " ^ quote name)
   2.322 +  | SOME thm => Thm.transfer thy thm 
   2.323 +  
   2.324 +val has_elim = is_some o #elim oo the_pred_data;
   2.325 +
   2.326 +val nparams_of = #nparams oo the_pred_data
   2.327 +
   2.328 +val modes_of = (map fst) o #functions oo the_pred_data
   2.329 +
   2.330 +fun all_modes_of thy = map (fn name => (name, modes_of thy name)) (all_preds_of thy) 
   2.331 +
   2.332 +val is_compiled = not o null o #functions oo the_pred_data
   2.333 +
   2.334 +fun lookup_predfun_data thy name mode =
   2.335 +  Option.map rep_predfun_data (AList.lookup (op =)
   2.336 +  (#functions (the_pred_data thy name)) mode)
   2.337 +
   2.338 +fun the_predfun_data thy name mode = case lookup_predfun_data thy name mode
   2.339 +  of NONE => error ("No function defined for mode " ^ string_of_mode mode ^ " of predicate " ^ name)
   2.340 +   | SOME data => data;
   2.341 +
   2.342 +val predfun_name_of = #name ooo the_predfun_data
   2.343 +
   2.344 +val predfun_definition_of = #definition ooo the_predfun_data
   2.345 +
   2.346 +val predfun_intro_of = #intro ooo the_predfun_data
   2.347 +
   2.348 +val predfun_elim_of = #elim ooo the_predfun_data
   2.349 +
   2.350 +fun lookup_generator_data thy name mode = 
   2.351 +  Option.map rep_function_data (AList.lookup (op =)
   2.352 +  (#generators (the_pred_data thy name)) mode)
   2.353 +  
   2.354 +fun the_generator_data thy name mode = case lookup_generator_data thy name mode
   2.355 +  of NONE => error ("No generator defined for mode " ^ string_of_mode mode ^ " of predicate " ^ name)
   2.356 +   | SOME data => data
   2.357 +
   2.358 +val generator_name_of = #name ooo the_generator_data
   2.359 +
   2.360 +val generator_modes_of = (map fst) o #generators oo the_pred_data
   2.361 +
   2.362 +fun all_generator_modes_of thy =
   2.363 +  map (fn name => (name, generator_modes_of thy name)) (all_preds_of thy) 
   2.364 +
   2.365 +fun lookup_sizelim_function_data thy name mode =
   2.366 +  Option.map rep_function_data (AList.lookup (op =)
   2.367 +  (#sizelim_functions (the_pred_data thy name)) mode)
   2.368 +
   2.369 +fun the_sizelim_function_data thy name mode = case lookup_sizelim_function_data thy name mode
   2.370 +  of NONE => error ("No size-limited function defined for mode " ^ string_of_mode mode
   2.371 +    ^ " of predicate " ^ name)
   2.372 +   | SOME data => data
   2.373 +
   2.374 +val sizelim_function_name_of = #name ooo the_sizelim_function_data
   2.375 +
   2.376 +(*val generator_modes_of = (map fst) o #generators oo the_pred_data*)
   2.377 +     
   2.378 +(* diagnostic display functions *)
   2.379 +
   2.380 +fun print_modes modes = Output.tracing ("Inferred modes:\n" ^
   2.381 +  cat_lines (map (fn (s, ms) => s ^ ": " ^ commas (map
   2.382 +    string_of_mode ms)) modes));
   2.383 +
   2.384 +fun print_pred_mode_table string_of_entry thy pred_mode_table =
   2.385 +  let
   2.386 +    fun print_mode pred (mode, entry) =  "mode : " ^ (string_of_mode mode)
   2.387 +      ^ (string_of_entry pred mode entry)  
   2.388 +    fun print_pred (pred, modes) =
   2.389 +      "predicate " ^ pred ^ ": " ^ cat_lines (map (print_mode pred) modes)
   2.390 +    val _ = Output.tracing (cat_lines (map print_pred pred_mode_table))
   2.391 +  in () end;
   2.392 +
   2.393 +fun string_of_moded_prem thy (Prem (ts, p), tmode) =
   2.394 +    (Syntax.string_of_term_global thy (list_comb (p, ts))) ^
   2.395 +    "(" ^ (string_of_tmode tmode) ^ ")"
   2.396 +  | string_of_moded_prem thy (GeneratorPrem (ts, p), Mode (predmode, is, _)) =
   2.397 +    (Syntax.string_of_term_global thy (list_comb (p, ts))) ^
   2.398 +    "(generator_mode: " ^ (string_of_mode predmode) ^ ")"
   2.399 +  | string_of_moded_prem thy (Generator (v, T), _) =
   2.400 +    "Generator for " ^ v ^ " of Type " ^ (Syntax.string_of_typ_global thy T)
   2.401 +  | string_of_moded_prem thy (Negprem (ts, p), Mode (_, is, _)) =
   2.402 +    (Syntax.string_of_term_global thy (list_comb (p, ts))) ^
   2.403 +    "(negative mode: " ^ string_of_smode is ^ ")"
   2.404 +  | string_of_moded_prem thy (Sidecond t, Mode (_, is, _)) =
   2.405 +    (Syntax.string_of_term_global thy t) ^
   2.406 +    "(sidecond mode: " ^ string_of_smode is ^ ")"    
   2.407 +  | string_of_moded_prem _ _ = error "string_of_moded_prem: unimplemented"
   2.408 +     
   2.409 +fun print_moded_clauses thy =
   2.410 +  let        
   2.411 +    fun string_of_clause pred mode clauses =
   2.412 +      cat_lines (map (fn (ts, prems) => (space_implode " --> "
   2.413 +        (map (string_of_moded_prem thy) prems)) ^ " --> " ^ pred ^ " "
   2.414 +        ^ (space_implode " " (map (Syntax.string_of_term_global thy) ts))) clauses)
   2.415 +  in print_pred_mode_table string_of_clause thy end;
   2.416 +
   2.417 +fun print_compiled_terms thy =
   2.418 +  print_pred_mode_table (fn _ => fn _ => Syntax.string_of_term_global thy) thy
   2.419 +    
   2.420 +fun print_stored_rules thy =
   2.421 +  let
   2.422 +    val preds = (Graph.keys o PredData.get) thy
   2.423 +    fun print pred () = let
   2.424 +      val _ = writeln ("predicate: " ^ pred)
   2.425 +      val _ = writeln ("number of parameters: " ^ string_of_int (nparams_of thy pred))
   2.426 +      val _ = writeln ("introrules: ")
   2.427 +      val _ = fold (fn thm => fn u => writeln (Display.string_of_thm_global thy thm))
   2.428 +        (rev (intros_of thy pred)) ()
   2.429 +    in
   2.430 +      if (has_elim thy pred) then
   2.431 +        writeln ("elimrule: " ^ Display.string_of_thm_global thy (the_elim_of thy pred))
   2.432 +      else
   2.433 +        writeln ("no elimrule defined")
   2.434 +    end
   2.435 +  in
   2.436 +    fold print preds ()
   2.437 +  end;
   2.438 +
   2.439 +fun print_all_modes thy =
   2.440 +  let
   2.441 +    val _ = writeln ("Inferred modes:")
   2.442 +    fun print (pred, modes) u =
   2.443 +      let
   2.444 +        val _ = writeln ("predicate: " ^ pred)
   2.445 +        val _ = writeln ("modes: " ^ (commas (map string_of_mode modes)))
   2.446 +      in u end  
   2.447 +  in
   2.448 +    fold print (all_modes_of thy) ()
   2.449 +  end
   2.450 +  
   2.451 +(** preprocessing rules **)  
   2.452 +
   2.453 +fun imp_prems_conv cv ct =
   2.454 +  case Thm.term_of ct of
   2.455 +    Const ("==>", _) $ _ $ _ => Conv.combination_conv (Conv.arg_conv cv) (imp_prems_conv cv) ct
   2.456 +  | _ => Conv.all_conv ct
   2.457 +
   2.458 +fun Trueprop_conv cv ct =
   2.459 +  case Thm.term_of ct of
   2.460 +    Const ("Trueprop", _) $ _ => Conv.arg_conv cv ct  
   2.461 +  | _ => error "Trueprop_conv"
   2.462 +
   2.463 +fun preprocess_intro thy rule =
   2.464 +  Conv.fconv_rule
   2.465 +    (imp_prems_conv
   2.466 +      (Trueprop_conv (Conv.try_conv (Conv.rewr_conv (Thm.symmetric @{thm Predicate.eq_is_eq})))))
   2.467 +    (Thm.transfer thy rule)
   2.468 +
   2.469 +fun preprocess_elim thy nparams elimrule =
   2.470 +  let
   2.471 +    val _ = Output.tracing ("Preprocessing elimination rule "
   2.472 +      ^ (Display.string_of_thm_global thy elimrule))
   2.473 +    fun replace_eqs (Const ("Trueprop", _) $ (Const ("op =", T) $ lhs $ rhs)) =
   2.474 +       HOLogic.mk_Trueprop (Const (@{const_name Predicate.eq}, T) $ lhs $ rhs)
   2.475 +     | replace_eqs t = t
   2.476 +    val prems = Thm.prems_of elimrule
   2.477 +    val nargs = length (snd (strip_comb (HOLogic.dest_Trueprop (hd prems)))) - nparams
   2.478 +    fun preprocess_case t =
   2.479 +     let
   2.480 +       val params = Logic.strip_params t
   2.481 +       val (assums1, assums2) = chop nargs (Logic.strip_assums_hyp t)
   2.482 +       val assums_hyp' = assums1 @ (map replace_eqs assums2)
   2.483 +     in
   2.484 +       list_all (params, Logic.list_implies (assums_hyp', Logic.strip_assums_concl t))
   2.485 +     end
   2.486 +    val cases' = map preprocess_case (tl prems)
   2.487 +    val elimrule' = Logic.list_implies ((hd prems) :: cases', Thm.concl_of elimrule)
   2.488 +    (*val _ =  Output.tracing ("elimrule': "^ (Syntax.string_of_term_global thy elimrule'))*)
   2.489 +    val bigeq = (Thm.symmetric (Conv.implies_concl_conv
   2.490 +      (MetaSimplifier.rewrite true [@{thm Predicate.eq_is_eq}])
   2.491 +        (cterm_of thy elimrule')))
   2.492 +    (*
   2.493 +    val _ = Output.tracing ("bigeq:" ^ (Display.string_of_thm_global thy bigeq))   
   2.494 +    val res = 
   2.495 +    Thm.equal_elim bigeq elimrule
   2.496 +    *)
   2.497 +    (*
   2.498 +    val t = (fn {...} => mycheat_tac thy 1)
   2.499 +    val eq = Goal.prove (ProofContext.init thy) [] [] (Logic.mk_equals ((Thm.prop_of elimrule), elimrule')) t
   2.500 +    *)
   2.501 +    val _ = Output.tracing "Preprocessed elimination rule"
   2.502 +  in
   2.503 +    Thm.equal_elim bigeq elimrule
   2.504 +  end;
   2.505 +
   2.506 +(* special case: predicate with no introduction rule *)
   2.507 +fun noclause thy predname elim = let
   2.508 +  val T = (Logic.unvarifyT o Sign.the_const_type thy) predname
   2.509 +  val Ts = binder_types T
   2.510 +  val names = Name.variant_list []
   2.511 +        (map (fn i => "x" ^ (string_of_int i)) (1 upto (length Ts)))
   2.512 +  val vs = map2 (curry Free) names Ts
   2.513 +  val clausehd = HOLogic.mk_Trueprop (list_comb (Const (predname, T), vs))
   2.514 +  val intro_t = Logic.mk_implies (@{prop False}, clausehd)
   2.515 +  val P = HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT))
   2.516 +  val elim_t = Logic.list_implies ([clausehd, Logic.mk_implies (@{prop False}, P)], P)
   2.517 +  val intro = Goal.prove (ProofContext.init thy) names [] intro_t
   2.518 +        (fn {...} => etac @{thm FalseE} 1)
   2.519 +  val elim = Goal.prove (ProofContext.init thy) ("P" :: names) [] elim_t
   2.520 +        (fn {...} => etac elim 1) 
   2.521 +in
   2.522 +  ([intro], elim)
   2.523 +end
   2.524 +
   2.525 +fun fetch_pred_data thy name =
   2.526 +  case try (Inductive.the_inductive (ProofContext.init thy)) name of
   2.527 +    SOME (info as (_, result)) => 
   2.528 +      let
   2.529 +        fun is_intro_of intro =
   2.530 +          let
   2.531 +            val (const, _) = strip_comb (HOLogic.dest_Trueprop (concl_of intro))
   2.532 +          in (fst (dest_Const const) = name) end;      
   2.533 +        val intros = ind_set_codegen_preproc thy ((map (preprocess_intro thy))
   2.534 +          (filter is_intro_of (#intrs result)))
   2.535 +        val pre_elim = nth (#elims result) (find_index (fn s => s = name) (#names (fst info)))
   2.536 +        val nparams = length (Inductive.params_of (#raw_induct result))
   2.537 +        val elim = singleton (ind_set_codegen_preproc thy) (preprocess_elim thy nparams pre_elim)
   2.538 +        val (intros, elim) = if null intros then noclause thy name elim else (intros, elim)
   2.539 +      in
   2.540 +        mk_pred_data ((intros, SOME elim, nparams), ([], [], []))
   2.541 +      end                                                                    
   2.542 +  | NONE => error ("No such predicate: " ^ quote name)
   2.543 +  
   2.544 +(* updaters *)
   2.545 +
   2.546 +fun apfst3 f (x, y, z) =  (f x, y, z)
   2.547 +fun apsnd3 f (x, y, z) =  (x, f y, z)
   2.548 +fun aptrd3 f (x, y, z) =  (x, y, f z)
   2.549 +
   2.550 +fun add_predfun name mode data =
   2.551 +  let
   2.552 +    val add = (apsnd o apfst3 o cons) (mode, mk_predfun_data data)
   2.553 +  in PredData.map (Graph.map_node name (map_pred_data add)) end
   2.554 +
   2.555 +fun is_inductive_predicate thy name =
   2.556 +  is_some (try (Inductive.the_inductive (ProofContext.init thy)) name)
   2.557 +
   2.558 +fun depending_preds_of thy (key, value) =
   2.559 +  let
   2.560 +    val intros = (#intros o rep_pred_data) value
   2.561 +  in
   2.562 +    fold Term.add_const_names (map Thm.prop_of intros) []
   2.563 +      |> filter (fn c => (not (c = key)) andalso (is_inductive_predicate thy c orelse is_registered thy c))
   2.564 +  end;
   2.565 +
   2.566 +
   2.567 +(* code dependency graph *)
   2.568 +(*
   2.569 +fun dependencies_of thy name =
   2.570 +  let
   2.571 +    val (intros, elim, nparams) = fetch_pred_data thy name 
   2.572 +    val data = mk_pred_data ((intros, SOME elim, nparams), ([], [], []))
   2.573 +    val keys = depending_preds_of thy intros
   2.574 +  in
   2.575 +    (data, keys)
   2.576 +  end;
   2.577 +*)
   2.578 +(* guessing number of parameters *)
   2.579 +fun find_indexes pred xs =
   2.580 +  let
   2.581 +    fun find is n [] = is
   2.582 +      | find is n (x :: xs) = find (if pred x then (n :: is) else is) (n + 1) xs;
   2.583 +  in rev (find [] 0 xs) end;
   2.584 +
   2.585 +fun is_predT (T as Type("fun", [_, _])) = (snd (strip_type T) = HOLogic.boolT)
   2.586 +  | is_predT _ = false
   2.587 +  
   2.588 +fun guess_nparams T =
   2.589 +  let
   2.590 +    val argTs = binder_types T
   2.591 +    val nparams = fold (curry Int.max)
   2.592 +      (map (fn x => x + 1) (find_indexes is_predT argTs)) 0
   2.593 +  in nparams end;
   2.594 +
   2.595 +fun add_intro thm thy = let
   2.596 +   val (name, T) = dest_Const (fst (strip_intro_concl 0 (prop_of thm)))
   2.597 +   fun cons_intro gr =
   2.598 +     case try (Graph.get_node gr) name of
   2.599 +       SOME pred_data => Graph.map_node name (map_pred_data
   2.600 +         (apfst (fn (intro, elim, nparams) => (thm::intro, elim, nparams)))) gr
   2.601 +     | NONE =>
   2.602 +       let
   2.603 +         val nparams = the_default (guess_nparams T)  (try (#nparams o rep_pred_data o (fetch_pred_data thy)) name)
   2.604 +       in Graph.new_node (name, mk_pred_data (([thm], NONE, nparams), ([], [], []))) gr end;
   2.605 +  in PredData.map cons_intro thy end
   2.606 +
   2.607 +fun set_elim thm = let
   2.608 +    val (name, _) = dest_Const (fst 
   2.609 +      (strip_comb (HOLogic.dest_Trueprop (hd (prems_of thm)))))
   2.610 +    fun set (intros, _, nparams) = (intros, SOME thm, nparams)  
   2.611 +  in PredData.map (Graph.map_node name (map_pred_data (apfst set))) end
   2.612 +
   2.613 +fun set_nparams name nparams = let
   2.614 +    fun set (intros, elim, _ ) = (intros, elim, nparams) 
   2.615 +  in PredData.map (Graph.map_node name (map_pred_data (apfst set))) end
   2.616 +    
   2.617 +fun register_predicate (pre_intros, pre_elim, nparams) thy = let
   2.618 +    val (name, _) = dest_Const (fst (strip_intro_concl nparams (prop_of (hd pre_intros))))
   2.619 +    (* preprocessing *)
   2.620 +    val intros = ind_set_codegen_preproc thy (map (preprocess_intro thy) pre_intros)
   2.621 +    val elim = singleton (ind_set_codegen_preproc thy) (preprocess_elim thy nparams pre_elim)
   2.622 +  in
   2.623 +    PredData.map
   2.624 +      (Graph.new_node (name, mk_pred_data ((intros, SOME elim, nparams), ([], [], [])))) thy
   2.625 +  end
   2.626 +
   2.627 +fun set_generator_name pred mode name = 
   2.628 +  let
   2.629 +    val set = (apsnd o apsnd3 o cons) (mode, mk_function_data (name, NONE))
   2.630 +  in
   2.631 +    PredData.map (Graph.map_node pred (map_pred_data set))
   2.632 +  end
   2.633 +
   2.634 +fun set_sizelim_function_name pred mode name = 
   2.635 +  let
   2.636 +    val set = (apsnd o aptrd3 o cons) (mode, mk_function_data (name, NONE))
   2.637 +  in
   2.638 +    PredData.map (Graph.map_node pred (map_pred_data set))
   2.639 +  end
   2.640 +
   2.641 +(** data structures for generic compilation for different monads **)
   2.642 +
   2.643 +(* maybe rename functions more generic:
   2.644 +  mk_predT -> mk_monadT; dest_predT -> dest_monadT
   2.645 +  mk_single -> mk_return (?)
   2.646 +*)
   2.647 +datatype compilation_funs = CompilationFuns of {
   2.648 +  mk_predT : typ -> typ,
   2.649 +  dest_predT : typ -> typ,
   2.650 +  mk_bot : typ -> term,
   2.651 +  mk_single : term -> term,
   2.652 +  mk_bind : term * term -> term,
   2.653 +  mk_sup : term * term -> term,
   2.654 +  mk_if : term -> term,
   2.655 +  mk_not : term -> term,
   2.656 +(*  funT_of : mode -> typ -> typ, *)
   2.657 +(*  mk_fun_of : theory -> (string * typ) -> mode -> term, *) 
   2.658 +  mk_map : typ -> typ -> term -> term -> term,
   2.659 +  lift_pred : term -> term
   2.660 +};
   2.661 +
   2.662 +fun mk_predT (CompilationFuns funs) = #mk_predT funs
   2.663 +fun dest_predT (CompilationFuns funs) = #dest_predT funs
   2.664 +fun mk_bot (CompilationFuns funs) = #mk_bot funs
   2.665 +fun mk_single (CompilationFuns funs) = #mk_single funs
   2.666 +fun mk_bind (CompilationFuns funs) = #mk_bind funs
   2.667 +fun mk_sup (CompilationFuns funs) = #mk_sup funs
   2.668 +fun mk_if (CompilationFuns funs) = #mk_if funs
   2.669 +fun mk_not (CompilationFuns funs) = #mk_not funs
   2.670 +(*fun funT_of (CompilationFuns funs) = #funT_of funs*)
   2.671 +(*fun mk_fun_of (CompilationFuns funs) = #mk_fun_of funs*)
   2.672 +fun mk_map (CompilationFuns funs) = #mk_map funs
   2.673 +fun lift_pred (CompilationFuns funs) = #lift_pred funs
   2.674 +
   2.675 +fun funT_of compfuns (iss, is) T =
   2.676 +  let
   2.677 +    val Ts = binder_types T
   2.678 +    val (paramTs, (inargTs, outargTs)) = split_modeT (iss, is) Ts
   2.679 +    val paramTs' = map2 (fn NONE => I | SOME is => funT_of compfuns ([], is)) iss paramTs
   2.680 +  in
   2.681 +    (paramTs' @ inargTs) ---> (mk_predT compfuns (mk_tupleT outargTs))
   2.682 +  end;
   2.683 +
   2.684 +fun sizelim_funT_of compfuns (iss, is) T =
   2.685 +  let
   2.686 +    val Ts = binder_types T
   2.687 +    val (paramTs, (inargTs, outargTs)) = split_modeT (iss, is) Ts
   2.688 +    val paramTs' = map2 (fn SOME is => sizelim_funT_of compfuns ([], is) | NONE => I) iss paramTs 
   2.689 +  in
   2.690 +    (paramTs' @ inargTs @ [@{typ "code_numeral"}]) ---> (mk_predT compfuns (mk_tupleT outargTs))
   2.691 +  end;  
   2.692 +
   2.693 +fun mk_fun_of compfuns thy (name, T) mode = 
   2.694 +  Const (predfun_name_of thy name mode, funT_of compfuns mode T)
   2.695 +
   2.696 +fun mk_sizelim_fun_of compfuns thy (name, T) mode =
   2.697 +  Const (sizelim_function_name_of thy name mode, sizelim_funT_of compfuns mode T)
   2.698 +  
   2.699 +fun mk_generator_of compfuns thy (name, T) mode = 
   2.700 +  Const (generator_name_of thy name mode, sizelim_funT_of compfuns mode T)
   2.701 +
   2.702 +
   2.703 +structure PredicateCompFuns =
   2.704 +struct
   2.705 +
   2.706 +fun mk_predT T = Type (@{type_name "Predicate.pred"}, [T])
   2.707 +
   2.708 +fun dest_predT (Type (@{type_name "Predicate.pred"}, [T])) = T
   2.709 +  | dest_predT T = raise TYPE ("dest_predT", [T], []);
   2.710 +
   2.711 +fun mk_bot T = Const (@{const_name Orderings.bot}, mk_predT T);
   2.712 +
   2.713 +fun mk_single t =
   2.714 +  let val T = fastype_of t
   2.715 +  in Const(@{const_name Predicate.single}, T --> mk_predT T) $ t end;
   2.716 +
   2.717 +fun mk_bind (x, f) =
   2.718 +  let val T as Type ("fun", [_, U]) = fastype_of f
   2.719 +  in
   2.720 +    Const (@{const_name Predicate.bind}, fastype_of x --> T --> U) $ x $ f
   2.721 +  end;
   2.722 +
   2.723 +val mk_sup = HOLogic.mk_binop @{const_name sup};
   2.724 +
   2.725 +fun mk_if cond = Const (@{const_name Predicate.if_pred},
   2.726 +  HOLogic.boolT --> mk_predT HOLogic.unitT) $ cond;
   2.727 +
   2.728 +fun mk_not t = let val T = mk_predT HOLogic.unitT
   2.729 +  in Const (@{const_name Predicate.not_pred}, T --> T) $ t end
   2.730 +
   2.731 +fun mk_Enum f =
   2.732 +  let val T as Type ("fun", [T', _]) = fastype_of f
   2.733 +  in
   2.734 +    Const (@{const_name Predicate.Pred}, T --> mk_predT T') $ f    
   2.735 +  end;
   2.736 +
   2.737 +fun mk_Eval (f, x) =
   2.738 +  let
   2.739 +    val T = fastype_of x
   2.740 +  in
   2.741 +    Const (@{const_name Predicate.eval}, mk_predT T --> T --> HOLogic.boolT) $ f $ x
   2.742 +  end;
   2.743 +
   2.744 +fun mk_map T1 T2 tf tp = Const (@{const_name Predicate.map},
   2.745 +  (T1 --> T2) --> mk_predT T1 --> mk_predT T2) $ tf $ tp;
   2.746 +
   2.747 +val lift_pred = I
   2.748 +
   2.749 +val compfuns = CompilationFuns {mk_predT = mk_predT, dest_predT = dest_predT, mk_bot = mk_bot,
   2.750 +  mk_single = mk_single, mk_bind = mk_bind, mk_sup = mk_sup, mk_if = mk_if, mk_not = mk_not,
   2.751 +  mk_map = mk_map, lift_pred = lift_pred};
   2.752 +
   2.753 +end;
   2.754 +
   2.755 +(* termify_code:
   2.756 +val termT = Type ("Code_Eval.term", []);
   2.757 +fun termifyT T = HOLogic.mk_prodT (T, HOLogic.unitT --> termT)
   2.758 +*)
   2.759 +(*
   2.760 +fun lift_random random =
   2.761 +  let
   2.762 +    val T = dest_randomT (fastype_of random)
   2.763 +  in
   2.764 +    mk_scomp (random,
   2.765 +      mk_fun_comp (HOLogic.pair_const (PredicateCompFuns.mk_predT T) @{typ Random.seed},
   2.766 +        mk_fun_comp (Const (@{const_name Predicate.single}, T --> (PredicateCompFuns.mk_predT T)),
   2.767 +          Const (@{const_name "fst"}, HOLogic.mk_prodT (T, @{typ "unit => term"}) --> T)))) 
   2.768 +  end;
   2.769 +*)
   2.770 + 
   2.771 +structure RPredCompFuns =
   2.772 +struct
   2.773 +
   2.774 +fun mk_rpredT T =
   2.775 +  @{typ "Random.seed"} --> HOLogic.mk_prodT (PredicateCompFuns.mk_predT T, @{typ "Random.seed"})
   2.776 +
   2.777 +fun dest_rpredT (Type ("fun", [_,
   2.778 +  Type (@{type_name "*"}, [Type (@{type_name "Predicate.pred"}, [T]), _])])) = T
   2.779 +  | dest_rpredT T = raise TYPE ("dest_rpredT", [T], []); 
   2.780 +
   2.781 +fun mk_bot T = Const(@{const_name RPred.bot}, mk_rpredT T)
   2.782 +
   2.783 +fun mk_single t =
   2.784 +  let
   2.785 +    val T = fastype_of t
   2.786 +  in
   2.787 +    Const (@{const_name RPred.return}, T --> mk_rpredT T) $ t
   2.788 +  end;
   2.789 +
   2.790 +fun mk_bind (x, f) =
   2.791 +  let
   2.792 +    val T as (Type ("fun", [_, U])) = fastype_of f
   2.793 +  in
   2.794 +    Const (@{const_name RPred.bind}, fastype_of x --> T --> U) $ x $ f
   2.795 +  end
   2.796 +
   2.797 +val mk_sup = HOLogic.mk_binop @{const_name RPred.supp}
   2.798 +
   2.799 +fun mk_if cond = Const (@{const_name RPred.if_rpred},
   2.800 +  HOLogic.boolT --> mk_rpredT HOLogic.unitT) $ cond;
   2.801 +
   2.802 +fun mk_not t = error "Negation is not defined for RPred"
   2.803 +
   2.804 +fun mk_map t = error "FIXME" (*FIXME*)
   2.805 +
   2.806 +fun lift_pred t =
   2.807 +  let
   2.808 +    val T = PredicateCompFuns.dest_predT (fastype_of t)
   2.809 +    val lift_predT = PredicateCompFuns.mk_predT T --> mk_rpredT T 
   2.810 +  in
   2.811 +    Const (@{const_name "RPred.lift_pred"}, lift_predT) $ t  
   2.812 +  end;
   2.813 +
   2.814 +val compfuns = CompilationFuns {mk_predT = mk_rpredT, dest_predT = dest_rpredT, mk_bot = mk_bot,
   2.815 +    mk_single = mk_single, mk_bind = mk_bind, mk_sup = mk_sup, mk_if = mk_if, mk_not = mk_not,
   2.816 +    mk_map = mk_map, lift_pred = lift_pred};
   2.817 +
   2.818 +end;
   2.819 +(* for external use with interactive mode *)
   2.820 +val rpred_compfuns = RPredCompFuns.compfuns;
   2.821 +
   2.822 +fun lift_random random =
   2.823 +  let
   2.824 +    val T = dest_randomT (fastype_of random)
   2.825 +  in
   2.826 +    Const (@{const_name lift_random}, (@{typ Random.seed} -->
   2.827 +      HOLogic.mk_prodT (HOLogic.mk_prodT (T, @{typ "unit => term"}), @{typ Random.seed})) --> 
   2.828 +      RPredCompFuns.mk_rpredT T) $ random
   2.829 +  end;
   2.830 + 
   2.831 +(* Mode analysis *)
   2.832 +
   2.833 +(*** check if a term contains only constructor functions ***)
   2.834 +fun is_constrt thy =
   2.835 +  let
   2.836 +    val cnstrs = flat (maps
   2.837 +      (map (fn (_, (Tname, _, cs)) => map (apsnd (rpair Tname o length)) cs) o #descr o snd)
   2.838 +      (Symtab.dest (Datatype.get_all thy)));
   2.839 +    fun check t = (case strip_comb t of
   2.840 +        (Free _, []) => true
   2.841 +      | (Const (s, T), ts) => (case (AList.lookup (op =) cnstrs s, body_type T) of
   2.842 +            (SOME (i, Tname), Type (Tname', _)) => length ts = i andalso Tname = Tname' andalso forall check ts
   2.843 +          | _ => false)
   2.844 +      | _ => false)
   2.845 +  in check end;
   2.846 +
   2.847 +(*** check if a type is an equality type (i.e. doesn't contain fun)
   2.848 +  FIXME this is only an approximation ***)
   2.849 +fun is_eqT (Type (s, Ts)) = s <> "fun" andalso forall is_eqT Ts
   2.850 +  | is_eqT _ = true;
   2.851 +
   2.852 +fun term_vs tm = fold_aterms (fn Free (x, T) => cons x | _ => I) tm [];
   2.853 +val terms_vs = distinct (op =) o maps term_vs;
   2.854 +
   2.855 +(** collect all Frees in a term (with duplicates!) **)
   2.856 +fun term_vTs tm =
   2.857 +  fold_aterms (fn Free xT => cons xT | _ => I) tm [];
   2.858 +
   2.859 +(*FIXME this function should not be named merge... make it local instead*)
   2.860 +fun merge xs [] = xs
   2.861 +  | merge [] ys = ys
   2.862 +  | merge (x::xs) (y::ys) = if length x >= length y then x::merge xs (y::ys)
   2.863 +      else y::merge (x::xs) ys;
   2.864 +
   2.865 +fun subsets i j = if i <= j then
   2.866 +       let val is = subsets (i+1) j
   2.867 +       in merge (map (fn ks => i::ks) is) is end
   2.868 +     else [[]];
   2.869 +     
   2.870 +(* FIXME: should be in library - map_prod *)
   2.871 +fun cprod ([], ys) = []
   2.872 +  | cprod (x :: xs, ys) = map (pair x) ys @ cprod (xs, ys);
   2.873 +
   2.874 +fun cprods xss = foldr (map op :: o cprod) [[]] xss;
   2.875 +
   2.876 +fun cprods_subset [] = [[]]
   2.877 +  | cprods_subset (xs :: xss) =
   2.878 +  let
   2.879 +    val yss = (cprods_subset xss)
   2.880 +  in maps (fn ys => map (fn x => cons x ys) xs) yss @ yss end
   2.881 +  
   2.882 +(*TODO: cleanup function and put together with modes_of_term *)
   2.883 +(*
   2.884 +fun modes_of_param default modes t = let
   2.885 +    val (vs, t') = strip_abs t
   2.886 +    val b = length vs
   2.887 +    fun mk_modes name args = Option.map (maps (fn (m as (iss, is)) =>
   2.888 +        let
   2.889 +          val (args1, args2) =
   2.890 +            if length args < length iss then
   2.891 +              error ("Too few arguments for inductive predicate " ^ name)
   2.892 +            else chop (length iss) args;
   2.893 +          val k = length args2;
   2.894 +          val perm = map (fn i => (find_index_eq (Bound (b - i)) args2) + 1)
   2.895 +            (1 upto b)  
   2.896 +          val partial_mode = (1 upto k) \\ perm
   2.897 +        in
   2.898 +          if not (partial_mode subset is) then [] else
   2.899 +          let
   2.900 +            val is' = 
   2.901 +            (fold_index (fn (i, j) => if j mem is then cons (i + 1) else I) perm [])
   2.902 +            |> fold (fn i => if i > k then cons (i - k + b) else I) is
   2.903 +              
   2.904 +           val res = map (fn x => Mode (m, is', x)) (cprods (map
   2.905 +            (fn (NONE, _) => [NONE]
   2.906 +              | (SOME js, arg) => map SOME (filter
   2.907 +                  (fn Mode (_, js', _) => js=js') (modes_of_term modes arg)))
   2.908 +                    (iss ~~ args1)))
   2.909 +          in res end
   2.910 +        end)) (AList.lookup op = modes name)
   2.911 +  in case strip_comb t' of
   2.912 +    (Const (name, _), args) => the_default default (mk_modes name args)
   2.913 +    | (Var ((name, _), _), args) => the (mk_modes name args)
   2.914 +    | (Free (name, _), args) => the (mk_modes name args)
   2.915 +    | _ => default end
   2.916 +  
   2.917 +and
   2.918 +*)
   2.919 +fun modes_of_term modes t =
   2.920 +  let
   2.921 +    val ks = map_index (fn (i, T) => (i, NONE)) (binder_types (fastype_of t));
   2.922 +    val default = [Mode (([], ks), ks, [])];
   2.923 +    fun mk_modes name args = Option.map (maps (fn (m as (iss, is)) =>
   2.924 +        let
   2.925 +          val (args1, args2) =
   2.926 +            if length args < length iss then
   2.927 +              error ("Too few arguments for inductive predicate " ^ name)
   2.928 +            else chop (length iss) args;
   2.929 +          val k = length args2;
   2.930 +          val prfx = map (rpair NONE) (1 upto k)
   2.931 +        in
   2.932 +          if not (is_prefix op = prfx is) then [] else
   2.933 +          let val is' = List.drop (is, k)
   2.934 +          in map (fn x => Mode (m, is', x)) (cprods (map
   2.935 +            (fn (NONE, _) => [NONE]
   2.936 +              | (SOME js, arg) => map SOME (filter
   2.937 +                  (fn Mode (_, js', _) => js=js') (modes_of_term modes arg)))
   2.938 +                    (iss ~~ args1)))
   2.939 +          end
   2.940 +        end)) (AList.lookup op = modes name)
   2.941 +
   2.942 +  in
   2.943 +    case strip_comb (Envir.eta_contract t) of
   2.944 +      (Const (name, _), args) => the_default default (mk_modes name args)
   2.945 +    | (Var ((name, _), _), args) => the (mk_modes name args)
   2.946 +    | (Free (name, _), args) => the (mk_modes name args)
   2.947 +    | (Abs _, []) => error "Abs at param position" (* modes_of_param default modes t *)
   2.948 +    | _ => default
   2.949 +  end
   2.950 +  
   2.951 +fun select_mode_prem thy modes vs ps =
   2.952 +  find_first (is_some o snd) (ps ~~ map
   2.953 +    (fn Prem (us, t) => find_first (fn Mode (_, is, _) =>
   2.954 +          let
   2.955 +            val (in_ts, out_ts) = split_smode is us;
   2.956 +            val (out_ts', in_ts') = List.partition (is_constrt thy) out_ts;
   2.957 +            val vTs = maps term_vTs out_ts';
   2.958 +            val dupTs = map snd (duplicates (op =) vTs) @
   2.959 +              List.mapPartial (AList.lookup (op =) vTs) vs;
   2.960 +          in
   2.961 +            terms_vs (in_ts @ in_ts') subset vs andalso
   2.962 +            forall (is_eqT o fastype_of) in_ts' andalso
   2.963 +            term_vs t subset vs andalso
   2.964 +            forall is_eqT dupTs
   2.965 +          end)
   2.966 +            (modes_of_term modes t handle Option =>
   2.967 +               error ("Bad predicate: " ^ Syntax.string_of_term_global thy t))
   2.968 +      | Negprem (us, t) => find_first (fn Mode (_, is, _) =>
   2.969 +            length us = length is andalso
   2.970 +            terms_vs us subset vs andalso
   2.971 +            term_vs t subset vs)
   2.972 +            (modes_of_term modes t handle Option =>
   2.973 +               error ("Bad predicate: " ^ Syntax.string_of_term_global thy t))
   2.974 +      | Sidecond t => if term_vs t subset vs then SOME (Mode (([], []), [], []))
   2.975 +          else NONE
   2.976 +      ) ps);
   2.977 +
   2.978 +fun fold_prem f (Prem (args, _)) = fold f args
   2.979 +  | fold_prem f (Negprem (args, _)) = fold f args
   2.980 +  | fold_prem f (Sidecond t) = f t
   2.981 +
   2.982 +fun all_subsets [] = [[]]
   2.983 +  | all_subsets (x::xs) = let val xss' = all_subsets xs in xss' @ (map (cons x) xss') end
   2.984 +
   2.985 +fun generator vTs v = 
   2.986 +  let
   2.987 +    val T = the (AList.lookup (op =) vTs v)
   2.988 +  in
   2.989 +    (Generator (v, T), Mode (([], []), [], []))
   2.990 +  end;
   2.991 +
   2.992 +fun gen_prem (Prem (us, t)) = GeneratorPrem (us, t) 
   2.993 +  | gen_prem _ = error "gen_prem : invalid input for gen_prem"
   2.994 +
   2.995 +fun param_gen_prem param_vs (p as Prem (us, t as Free (v, _))) =
   2.996 +  if member (op =) param_vs v then
   2.997 +    GeneratorPrem (us, t)
   2.998 +  else p  
   2.999 +  | param_gen_prem param_vs p = p
  2.1000 +  
  2.1001 +fun check_mode_clause with_generator thy param_vs modes gen_modes (iss, is) (ts, ps) =
  2.1002 +  let
  2.1003 +    val modes' = modes @ List.mapPartial
  2.1004 +      (fn (_, NONE) => NONE | (v, SOME js) => SOME (v, [([], js)]))
  2.1005 +        (param_vs ~~ iss);
  2.1006 +    val gen_modes' = gen_modes @ List.mapPartial
  2.1007 +      (fn (_, NONE) => NONE | (v, SOME js) => SOME (v, [([], js)]))
  2.1008 +        (param_vs ~~ iss);  
  2.1009 +    val vTs = distinct (op =) ((fold o fold_prem) Term.add_frees ps (fold Term.add_frees ts []))
  2.1010 +    val prem_vs = distinct (op =) ((fold o fold_prem) Term.add_free_names ps [])
  2.1011 +    fun check_mode_prems acc_ps vs [] = SOME (acc_ps, vs)
  2.1012 +      | check_mode_prems acc_ps vs ps = (case select_mode_prem thy modes' vs ps of
  2.1013 +          NONE =>
  2.1014 +            (if with_generator then
  2.1015 +              (case select_mode_prem thy gen_modes' vs ps of
  2.1016 +                  SOME (p, SOME mode) => check_mode_prems ((gen_prem p, mode) :: acc_ps) 
  2.1017 +                  (case p of Prem (us, _) => vs union terms_vs us | _ => vs)
  2.1018 +                  (filter_out (equal p) ps)
  2.1019 +                | NONE =>
  2.1020 +                  let 
  2.1021 +                    val all_generator_vs = all_subsets (prem_vs \\ vs) |> sort (int_ord o (pairself length))
  2.1022 +                  in
  2.1023 +                    case (find_first (fn generator_vs => is_some
  2.1024 +                      (select_mode_prem thy modes' (vs union generator_vs) ps)) all_generator_vs) of
  2.1025 +                      SOME generator_vs => check_mode_prems ((map (generator vTs) generator_vs) @ acc_ps)
  2.1026 +                        (vs union generator_vs) ps
  2.1027 +                    | NONE => NONE
  2.1028 +                  end)
  2.1029 +            else
  2.1030 +              NONE)
  2.1031 +        | SOME (p, SOME mode) => check_mode_prems ((if with_generator then param_gen_prem param_vs p else p, mode) :: acc_ps) 
  2.1032 +            (case p of Prem (us, _) => vs union terms_vs us | _ => vs)
  2.1033 +            (filter_out (equal p) ps))
  2.1034 +    val (in_ts, in_ts') = List.partition (is_constrt thy) (fst (split_smode is ts));
  2.1035 +    val in_vs = terms_vs in_ts;
  2.1036 +    val concl_vs = terms_vs ts
  2.1037 +  in
  2.1038 +    if forall is_eqT (map snd (duplicates (op =) (maps term_vTs in_ts))) andalso
  2.1039 +    forall (is_eqT o fastype_of) in_ts' then
  2.1040 +      case check_mode_prems [] (param_vs union in_vs) ps of
  2.1041 +         NONE => NONE
  2.1042 +       | SOME (acc_ps, vs) =>
  2.1043 +         if with_generator then
  2.1044 +           SOME (ts, (rev acc_ps) @ (map (generator vTs) (concl_vs \\ vs))) 
  2.1045 +         else
  2.1046 +           if concl_vs subset vs then SOME (ts, rev acc_ps) else NONE
  2.1047 +    else NONE
  2.1048 +  end;
  2.1049 +
  2.1050 +fun check_modes_pred with_generator thy param_vs clauses modes gen_modes (p, ms) =
  2.1051 +  let val SOME rs = AList.lookup (op =) clauses p
  2.1052 +  in (p, List.filter (fn m => case find_index
  2.1053 +    (is_none o check_mode_clause with_generator thy param_vs modes gen_modes m) rs of
  2.1054 +      ~1 => true
  2.1055 +    | i => (Output.tracing ("Clause " ^ string_of_int (i + 1) ^ " of " ^
  2.1056 +      p ^ " violates mode " ^ string_of_mode m);
  2.1057 +        Output.tracing (commas (map (Syntax.string_of_term_global thy) (fst (nth rs i)))); false)) ms)
  2.1058 +  end;
  2.1059 +
  2.1060 +fun get_modes_pred with_generator thy param_vs clauses modes gen_modes (p, ms) =
  2.1061 +  let
  2.1062 +    val SOME rs = AList.lookup (op =) clauses p 
  2.1063 +  in
  2.1064 +    (p, map (fn m =>
  2.1065 +      (m, map (the o check_mode_clause with_generator thy param_vs modes gen_modes m) rs)) ms)
  2.1066 +  end;
  2.1067 +  
  2.1068 +fun fixp f (x : (string * mode list) list) =
  2.1069 +  let val y = f x
  2.1070 +  in if x = y then x else fixp f y end;
  2.1071 +
  2.1072 +fun infer_modes thy extra_modes all_modes param_vs clauses =
  2.1073 +  let
  2.1074 +    val modes =
  2.1075 +      fixp (fn modes =>
  2.1076 +        map (check_modes_pred false thy param_vs clauses (modes @ extra_modes) []) modes)
  2.1077 +          all_modes
  2.1078 +  in
  2.1079 +    map (get_modes_pred false thy param_vs clauses (modes @ extra_modes) []) modes
  2.1080 +  end;
  2.1081 +
  2.1082 +fun remove_from rem [] = []
  2.1083 +  | remove_from rem ((k, vs) :: xs) =
  2.1084 +    (case AList.lookup (op =) rem k of
  2.1085 +      NONE => (k, vs)
  2.1086 +    | SOME vs' => (k, vs \\ vs'))
  2.1087 +    :: remove_from rem xs
  2.1088 +    
  2.1089 +fun infer_modes_with_generator thy extra_modes all_modes param_vs clauses =
  2.1090 +  let
  2.1091 +    val prednames = map fst clauses
  2.1092 +    val extra_modes = all_modes_of thy
  2.1093 +    val gen_modes = all_generator_modes_of thy
  2.1094 +      |> filter_out (fn (name, _) => member (op =) prednames name)
  2.1095 +    val starting_modes = remove_from extra_modes all_modes 
  2.1096 +    val modes =
  2.1097 +      fixp (fn modes =>
  2.1098 +        map (check_modes_pred true thy param_vs clauses extra_modes (gen_modes @ modes)) modes)
  2.1099 +         starting_modes 
  2.1100 +  in
  2.1101 +    map (get_modes_pred true thy param_vs clauses extra_modes (gen_modes @ modes)) modes
  2.1102 +  end;
  2.1103 +
  2.1104 +(* term construction *)
  2.1105 +
  2.1106 +fun mk_v (names, vs) s T = (case AList.lookup (op =) vs s of
  2.1107 +      NONE => (Free (s, T), (names, (s, [])::vs))
  2.1108 +    | SOME xs =>
  2.1109 +        let
  2.1110 +          val s' = Name.variant names s;
  2.1111 +          val v = Free (s', T)
  2.1112 +        in
  2.1113 +          (v, (s'::names, AList.update (op =) (s, v::xs) vs))
  2.1114 +        end);
  2.1115 +
  2.1116 +fun distinct_v (Free (s, T)) nvs = mk_v nvs s T
  2.1117 +  | distinct_v (t $ u) nvs =
  2.1118 +      let
  2.1119 +        val (t', nvs') = distinct_v t nvs;
  2.1120 +        val (u', nvs'') = distinct_v u nvs';
  2.1121 +      in (t' $ u', nvs'') end
  2.1122 +  | distinct_v x nvs = (x, nvs);
  2.1123 +
  2.1124 +fun compile_match thy compfuns eqs eqs' out_ts success_t =
  2.1125 +  let
  2.1126 +    val eqs'' = maps mk_eq eqs @ eqs'
  2.1127 +    val names = fold Term.add_free_names (success_t :: eqs'' @ out_ts) [];
  2.1128 +    val name = Name.variant names "x";
  2.1129 +    val name' = Name.variant (name :: names) "y";
  2.1130 +    val T = mk_tupleT (map fastype_of out_ts);
  2.1131 +    val U = fastype_of success_t;
  2.1132 +    val U' = dest_predT compfuns U;
  2.1133 +    val v = Free (name, T);
  2.1134 +    val v' = Free (name', T);
  2.1135 +  in
  2.1136 +    lambda v (fst (Datatype.make_case
  2.1137 +      (ProofContext.init thy) false [] v
  2.1138 +      [(mk_tuple out_ts,
  2.1139 +        if null eqs'' then success_t
  2.1140 +        else Const (@{const_name HOL.If}, HOLogic.boolT --> U --> U --> U) $
  2.1141 +          foldr1 HOLogic.mk_conj eqs'' $ success_t $
  2.1142 +            mk_bot compfuns U'),
  2.1143 +       (v', mk_bot compfuns U')]))
  2.1144 +  end;
  2.1145 +
  2.1146 +(*FIXME function can be removed*)
  2.1147 +fun mk_funcomp f t =
  2.1148 +  let
  2.1149 +    val names = Term.add_free_names t [];
  2.1150 +    val Ts = binder_types (fastype_of t);
  2.1151 +    val vs = map Free
  2.1152 +      (Name.variant_list names (replicate (length Ts) "x") ~~ Ts)
  2.1153 +  in
  2.1154 +    fold_rev lambda vs (f (list_comb (t, vs)))
  2.1155 +  end;
  2.1156 +(*
  2.1157 +fun compile_param_ext thy compfuns modes (NONE, t) = t
  2.1158 +  | compile_param_ext thy compfuns modes (m as SOME (Mode ((iss, is'), is, ms)), t) =
  2.1159 +      let
  2.1160 +        val (vs, u) = strip_abs t
  2.1161 +        val (ivs, ovs) = split_mode is vs    
  2.1162 +        val (f, args) = strip_comb u
  2.1163 +        val (params, args') = chop (length ms) args
  2.1164 +        val (inargs, outargs) = split_mode is' args'
  2.1165 +        val b = length vs
  2.1166 +        val perm = map (fn i => (find_index_eq (Bound (b - i)) args') + 1) (1 upto b)
  2.1167 +        val outp_perm =
  2.1168 +          snd (split_mode is perm)
  2.1169 +          |> map (fn i => i - length (filter (fn x => x < i) is'))
  2.1170 +        val names = [] -- TODO
  2.1171 +        val out_names = Name.variant_list names (replicate (length outargs) "x")
  2.1172 +        val f' = case f of
  2.1173 +            Const (name, T) =>
  2.1174 +              if AList.defined op = modes name then
  2.1175 +                mk_predfun_of thy compfuns (name, T) (iss, is')
  2.1176 +              else error "compile param: Not an inductive predicate with correct mode"
  2.1177 +          | Free (name, T) => Free (name, param_funT_of compfuns T (SOME is'))
  2.1178 +        val outTs = dest_tupleT (dest_predT compfuns (body_type (fastype_of f')))
  2.1179 +        val out_vs = map Free (out_names ~~ outTs)
  2.1180 +        val params' = map (compile_param thy modes) (ms ~~ params)
  2.1181 +        val f_app = list_comb (f', params' @ inargs)
  2.1182 +        val single_t = (mk_single compfuns (mk_tuple (map (fn i => nth out_vs (i - 1)) outp_perm)))
  2.1183 +        val match_t = compile_match thy compfuns [] [] out_vs single_t
  2.1184 +      in list_abs (ivs,
  2.1185 +        mk_bind compfuns (f_app, match_t))
  2.1186 +      end
  2.1187 +  | compile_param_ext _ _ _ _ = error "compile params"
  2.1188 +*)
  2.1189 +
  2.1190 +fun compile_param size thy compfuns (NONE, t) = t
  2.1191 +  | compile_param size thy compfuns (m as SOME (Mode ((iss, is'), is, ms)), t) =
  2.1192 +   let
  2.1193 +     val (f, args) = strip_comb (Envir.eta_contract t)
  2.1194 +     val (params, args') = chop (length ms) args
  2.1195 +     val params' = map (compile_param size thy compfuns) (ms ~~ params)
  2.1196 +     val mk_fun_of = case size of NONE => mk_fun_of | SOME _ => mk_sizelim_fun_of
  2.1197 +     val funT_of = case size of NONE => funT_of | SOME _ => sizelim_funT_of
  2.1198 +     val f' =
  2.1199 +       case f of
  2.1200 +         Const (name, T) =>
  2.1201 +           mk_fun_of compfuns thy (name, T) (iss, is')
  2.1202 +       | Free (name, T) => Free (name, funT_of compfuns (iss, is') T)
  2.1203 +       | _ => error ("PredicateCompiler: illegal parameter term")
  2.1204 +   in list_comb (f', params' @ args') end
  2.1205 +   
  2.1206 +fun compile_expr size thy ((Mode (mode, is, ms)), t) =
  2.1207 +  case strip_comb t of
  2.1208 +    (Const (name, T), params) =>
  2.1209 +       let
  2.1210 +         val params' = map (compile_param size thy PredicateCompFuns.compfuns) (ms ~~ params)
  2.1211 +         val mk_fun_of = case size of NONE => mk_fun_of | SOME _ => mk_sizelim_fun_of
  2.1212 +       in
  2.1213 +         list_comb (mk_fun_of PredicateCompFuns.compfuns thy (name, T) mode, params')
  2.1214 +       end
  2.1215 +  | (Free (name, T), args) =>
  2.1216 +       let 
  2.1217 +         val funT_of = case size of NONE => funT_of | SOME _ => sizelim_funT_of 
  2.1218 +       in
  2.1219 +         list_comb (Free (name, funT_of PredicateCompFuns.compfuns ([], is) T), args)
  2.1220 +       end;
  2.1221 +       
  2.1222 +fun compile_gen_expr size thy compfuns ((Mode (mode, is, ms)), t) =
  2.1223 +  case strip_comb t of
  2.1224 +    (Const (name, T), params) =>
  2.1225 +      let
  2.1226 +        val params' = map (compile_param size thy compfuns) (ms ~~ params)
  2.1227 +      in
  2.1228 +        list_comb (mk_generator_of compfuns thy (name, T) mode, params')
  2.1229 +      end
  2.1230 +    | (Free (name, T), args) =>
  2.1231 +      list_comb (Free (name, sizelim_funT_of RPredCompFuns.compfuns ([], is) T), args)
  2.1232 +          
  2.1233 +(** specific rpred functions -- move them to the correct place in this file *)
  2.1234 +
  2.1235 +(* uncommented termify code; causes more trouble than expected at first *) 
  2.1236 +(*
  2.1237 +fun mk_valtermify_term (t as Const (c, T)) = HOLogic.mk_prod (t, Abs ("u", HOLogic.unitT, HOLogic.reflect_term t))
  2.1238 +  | mk_valtermify_term (Free (x, T)) = Free (x, termifyT T) 
  2.1239 +  | mk_valtermify_term (t1 $ t2) =
  2.1240 +    let
  2.1241 +      val T = fastype_of t1
  2.1242 +      val (T1, T2) = dest_funT T
  2.1243 +      val t1' = mk_valtermify_term t1
  2.1244 +      val t2' = mk_valtermify_term t2
  2.1245 +    in
  2.1246 +      Const ("Code_Eval.valapp", termifyT T --> termifyT T1 --> termifyT T2) $ t1' $ t2'
  2.1247 +    end
  2.1248 +  | mk_valtermify_term _ = error "Not a valid term for mk_valtermify_term"
  2.1249 +*)
  2.1250 +
  2.1251 +fun compile_clause compfuns size final_term thy all_vs param_vs (iss, is) inp (ts, moded_ps) =
  2.1252 +  let
  2.1253 +    fun check_constrt t (names, eqs) =
  2.1254 +      if is_constrt thy t then (t, (names, eqs)) else
  2.1255 +        let
  2.1256 +          val s = Name.variant names "x";
  2.1257 +          val v = Free (s, fastype_of t)
  2.1258 +        in (v, (s::names, HOLogic.mk_eq (v, t)::eqs)) end;
  2.1259 +
  2.1260 +    val (in_ts, out_ts) = split_smode is ts;
  2.1261 +    val (in_ts', (all_vs', eqs)) =
  2.1262 +      fold_map check_constrt in_ts (all_vs, []);
  2.1263 +
  2.1264 +    fun compile_prems out_ts' vs names [] =
  2.1265 +          let
  2.1266 +            val (out_ts'', (names', eqs')) =
  2.1267 +              fold_map check_constrt out_ts' (names, []);
  2.1268 +            val (out_ts''', (names'', constr_vs)) = fold_map distinct_v
  2.1269 +              out_ts'' (names', map (rpair []) vs);
  2.1270 +          in
  2.1271 +          (* termify code:
  2.1272 +            compile_match thy compfuns constr_vs (eqs @ eqs') out_ts'''
  2.1273 +              (mk_single compfuns (mk_tuple (map mk_valtermify_term out_ts)))
  2.1274 +           *)
  2.1275 +            compile_match thy compfuns constr_vs (eqs @ eqs') out_ts'''
  2.1276 +              (final_term out_ts)
  2.1277 +          end
  2.1278 +      | compile_prems out_ts vs names ((p, mode as Mode ((_, is), _, _)) :: ps) =
  2.1279 +          let
  2.1280 +            val vs' = distinct (op =) (flat (vs :: map term_vs out_ts));
  2.1281 +            val (out_ts', (names', eqs)) =
  2.1282 +              fold_map check_constrt out_ts (names, [])
  2.1283 +            val (out_ts'', (names'', constr_vs')) = fold_map distinct_v
  2.1284 +              out_ts' ((names', map (rpair []) vs))
  2.1285 +            val (compiled_clause, rest) = case p of
  2.1286 +               Prem (us, t) =>
  2.1287 +                 let
  2.1288 +                   val (in_ts, out_ts''') = split_smode is us;
  2.1289 +                   val args = case size of
  2.1290 +                     NONE => in_ts
  2.1291 +                   | SOME size_t => in_ts @ [size_t]
  2.1292 +                   val u = lift_pred compfuns
  2.1293 +                     (list_comb (compile_expr size thy (mode, t), args))                     
  2.1294 +                   val rest = compile_prems out_ts''' vs' names'' ps
  2.1295 +                 in
  2.1296 +                   (u, rest)
  2.1297 +                 end
  2.1298 +             | Negprem (us, t) =>
  2.1299 +                 let
  2.1300 +                   val (in_ts, out_ts''') = split_smode is us
  2.1301 +                   val u = lift_pred compfuns
  2.1302 +                     (mk_not PredicateCompFuns.compfuns (list_comb (compile_expr NONE thy (mode, t), in_ts)))
  2.1303 +                   val rest = compile_prems out_ts''' vs' names'' ps
  2.1304 +                 in
  2.1305 +                   (u, rest)
  2.1306 +                 end
  2.1307 +             | Sidecond t =>
  2.1308 +                 let
  2.1309 +                   val rest = compile_prems [] vs' names'' ps;
  2.1310 +                 in
  2.1311 +                   (mk_if compfuns t, rest)
  2.1312 +                 end
  2.1313 +             | GeneratorPrem (us, t) =>
  2.1314 +                 let
  2.1315 +                   val (in_ts, out_ts''') = split_smode is us;
  2.1316 +                   val args = case size of
  2.1317 +                     NONE => in_ts
  2.1318 +                   | SOME size_t => in_ts @ [size_t]
  2.1319 +                   val u = list_comb (compile_gen_expr size thy compfuns (mode, t), args)
  2.1320 +                   val rest = compile_prems out_ts''' vs' names'' ps
  2.1321 +                 in
  2.1322 +                   (u, rest)
  2.1323 +                 end
  2.1324 +             | Generator (v, T) =>
  2.1325 +                 let
  2.1326 +                   val u = lift_random (HOLogic.mk_random T @{term "1::code_numeral"})
  2.1327 +                   val rest = compile_prems [Free (v, T)]  vs' names'' ps;
  2.1328 +                 in
  2.1329 +                   (u, rest)
  2.1330 +                 end
  2.1331 +          in
  2.1332 +            compile_match thy compfuns constr_vs' eqs out_ts'' 
  2.1333 +              (mk_bind compfuns (compiled_clause, rest))
  2.1334 +          end
  2.1335 +    val prem_t = compile_prems in_ts' param_vs all_vs' moded_ps;
  2.1336 +  in
  2.1337 +    mk_bind compfuns (mk_single compfuns inp, prem_t)
  2.1338 +  end
  2.1339 +
  2.1340 +fun compile_pred compfuns mk_fun_of use_size thy all_vs param_vs s T mode moded_cls =
  2.1341 +  let
  2.1342 +	  val (Ts1, Ts2) = chop (length (fst mode)) (binder_types T)
  2.1343 +    val (Us1, Us2) = split_smodeT (snd mode) Ts2
  2.1344 +    val funT_of = if use_size then sizelim_funT_of else funT_of
  2.1345 +    val Ts1' = map2 (fn NONE => I | SOME is => funT_of compfuns ([], is)) (fst mode) Ts1
  2.1346 +    val size_name = Name.variant (all_vs @ param_vs) "size"
  2.1347 +  	fun mk_input_term (i, NONE) =
  2.1348 +		    [Free (Name.variant (all_vs @ param_vs) ("x" ^ string_of_int i), nth Ts2 (i - 1))]
  2.1349 +		  | mk_input_term (i, SOME pis) = case HOLogic.strip_tupleT (nth Ts2 (i - 1)) of
  2.1350 +						   [] => error "strange unit input"
  2.1351 +					   | [T] => [Free (Name.variant (all_vs @ param_vs) ("x" ^ string_of_int i), nth Ts2 (i - 1))]
  2.1352 +						 | Ts => let
  2.1353 +							 val vnames = Name.variant_list (all_vs @ param_vs)
  2.1354 +								(map (fn j => "x" ^ string_of_int i ^ "p" ^ string_of_int j)
  2.1355 +									pis)
  2.1356 +						 in if null pis then []
  2.1357 +						   else [HOLogic.mk_tuple (map Free (vnames ~~ map (fn j => nth Ts (j - 1)) pis))] end
  2.1358 +		val in_ts = maps mk_input_term (snd mode)
  2.1359 +    val params = map2 (fn s => fn T => Free (s, T)) param_vs Ts1'
  2.1360 +    val size = Free (size_name, @{typ "code_numeral"})
  2.1361 +    val decr_size =
  2.1362 +      if use_size then
  2.1363 +        SOME (Const ("HOL.minus_class.minus", @{typ "code_numeral => code_numeral => code_numeral"})
  2.1364 +          $ size $ Const ("HOL.one_class.one", @{typ "Code_Numeral.code_numeral"}))
  2.1365 +      else
  2.1366 +        NONE
  2.1367 +    val cl_ts =
  2.1368 +      map (compile_clause compfuns decr_size (fn out_ts => mk_single compfuns (mk_tuple out_ts))
  2.1369 +        thy all_vs param_vs mode (mk_tuple in_ts)) moded_cls;
  2.1370 +    val t = foldr1 (mk_sup compfuns) cl_ts
  2.1371 +    val T' = mk_predT compfuns (mk_tupleT Us2)
  2.1372 +    val size_t = Const (@{const_name "If"}, @{typ bool} --> T' --> T' --> T')
  2.1373 +      $ HOLogic.mk_eq (size, @{term "0 :: code_numeral"})
  2.1374 +      $ mk_bot compfuns (dest_predT compfuns T') $ t
  2.1375 +    val fun_const = mk_fun_of compfuns thy (s, T) mode
  2.1376 +    val eq = if use_size then
  2.1377 +      (list_comb (fun_const, params @ in_ts @ [size]), size_t)
  2.1378 +    else
  2.1379 +      (list_comb (fun_const, params @ in_ts), t)
  2.1380 +  in
  2.1381 +    HOLogic.mk_Trueprop (HOLogic.mk_eq eq)
  2.1382 +  end;
  2.1383 +  
  2.1384 +(* special setup for simpset *)                  
  2.1385 +val HOL_basic_ss' = HOL_basic_ss addsimps (@{thms "HOL.simp_thms"} @ [@{thm Pair_eq}])
  2.1386 +  setSolver (mk_solver "all_tac_solver" (fn _ => fn _ => all_tac))
  2.1387 +	setSolver (mk_solver "True_solver" (fn _ => rtac @{thm TrueI}))
  2.1388 +
  2.1389 +(* Definition of executable functions and their intro and elim rules *)
  2.1390 +
  2.1391 +fun print_arities arities = tracing ("Arities:\n" ^
  2.1392 +  cat_lines (map (fn (s, (ks, k)) => s ^ ": " ^
  2.1393 +    space_implode " -> " (map
  2.1394 +      (fn NONE => "X" | SOME k' => string_of_int k')
  2.1395 +        (ks @ [SOME k]))) arities));
  2.1396 +
  2.1397 +fun mk_Eval_of ((x, T), NONE) names = (x, names)
  2.1398 +  | mk_Eval_of ((x, T), SOME mode) names =
  2.1399 +	let
  2.1400 +    val Ts = binder_types T
  2.1401 +    (*val argnames = Name.variant_list names
  2.1402 +        (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts)));
  2.1403 +    val args = map Free (argnames ~~ Ts)
  2.1404 +    val (inargs, outargs) = split_smode mode args*)
  2.1405 +		fun mk_split_lambda [] t = lambda (Free (Name.variant names "x", HOLogic.unitT)) t
  2.1406 +			| mk_split_lambda [x] t = lambda x t
  2.1407 +			| mk_split_lambda xs t =
  2.1408 +			let
  2.1409 +				fun mk_split_lambda' (x::y::[]) t = HOLogic.mk_split (lambda x (lambda y t))
  2.1410 +					| mk_split_lambda' (x::xs) t = HOLogic.mk_split (lambda x (mk_split_lambda' xs t))
  2.1411 +			in
  2.1412 +				mk_split_lambda' xs t
  2.1413 +			end;
  2.1414 +  	fun mk_arg (i, T) =
  2.1415 +		  let
  2.1416 +	  	  val vname = Name.variant names ("x" ^ string_of_int i)
  2.1417 +		    val default = Free (vname, T)
  2.1418 +		  in 
  2.1419 +		    case AList.lookup (op =) mode i of
  2.1420 +		      NONE => (([], [default]), [default])
  2.1421 +			  | SOME NONE => (([default], []), [default])
  2.1422 +			  | SOME (SOME pis) =>
  2.1423 +				  case HOLogic.strip_tupleT T of
  2.1424 +						[] => error "pair mode but unit tuple" (*(([default], []), [default])*)
  2.1425 +					| [_] => error "pair mode but not a tuple" (*(([default], []), [default])*)
  2.1426 +					| Ts =>
  2.1427 +					  let
  2.1428 +							val vnames = Name.variant_list names
  2.1429 +								(map (fn j => "x" ^ string_of_int i ^ "p" ^ string_of_int j)
  2.1430 +									(1 upto length Ts))
  2.1431 +							val args = map Free (vnames ~~ Ts)
  2.1432 +							fun split_args (i, arg) (ins, outs) =
  2.1433 +							  if member (op =) pis i then
  2.1434 +							    (arg::ins, outs)
  2.1435 +								else
  2.1436 +								  (ins, arg::outs)
  2.1437 +							val (inargs, outargs) = fold_rev split_args ((1 upto length Ts) ~~ args) ([], [])
  2.1438 +							fun tuple args = if null args then [] else [HOLogic.mk_tuple args]
  2.1439 +						in ((tuple inargs, tuple outargs), args) end
  2.1440 +			end
  2.1441 +		val (inoutargs, args) = split_list (map mk_arg (1 upto (length Ts) ~~ Ts))
  2.1442 +    val (inargs, outargs) = pairself flat (split_list inoutargs)
  2.1443 +		val r = PredicateCompFuns.mk_Eval (list_comb (x, inargs), mk_tuple outargs)
  2.1444 +    val t = fold_rev mk_split_lambda args r
  2.1445 +  in
  2.1446 +    (t, names)
  2.1447 +  end;
  2.1448 +
  2.1449 +fun create_intro_elim_rule (mode as (iss, is)) defthm mode_id funT pred thy =
  2.1450 +let
  2.1451 +  val Ts = binder_types (fastype_of pred)
  2.1452 +  val funtrm = Const (mode_id, funT)
  2.1453 +  val (Ts1, Ts2) = chop (length iss) Ts;
  2.1454 +  val Ts1' = map2 (fn NONE => I | SOME is => funT_of (PredicateCompFuns.compfuns) ([], is)) iss Ts1
  2.1455 +	val param_names = Name.variant_list []
  2.1456 +    (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts1)));
  2.1457 +  val params = map Free (param_names ~~ Ts1')
  2.1458 +	fun mk_args (i, T) argnames =
  2.1459 +    let
  2.1460 +		  val vname = Name.variant (param_names @ argnames) ("x" ^ string_of_int (length Ts1' + i))
  2.1461 +		  val default = (Free (vname, T), vname :: argnames)
  2.1462 +	  in
  2.1463 +  	  case AList.lookup (op =) is i of
  2.1464 +						 NONE => default
  2.1465 +					 | SOME NONE => default
  2.1466 +        	 | SOME (SOME pis) =>
  2.1467 +					   case HOLogic.strip_tupleT T of
  2.1468 +						   [] => default
  2.1469 +					   | [_] => default
  2.1470 +						 | Ts => 
  2.1471 +						let
  2.1472 +							val vnames = Name.variant_list (param_names @ argnames)
  2.1473 +								(map (fn j => "x" ^ string_of_int (length Ts1' + i) ^ "p" ^ string_of_int j)
  2.1474 +									(1 upto (length Ts)))
  2.1475 +						 in (HOLogic.mk_tuple (map Free (vnames ~~ Ts)), vnames  @ argnames) end
  2.1476 +		end
  2.1477 +	val (args, argnames) = fold_map mk_args (1 upto (length Ts2) ~~ Ts2) []
  2.1478 +  val (inargs, outargs) = split_smode is args
  2.1479 +  val param_names' = Name.variant_list (param_names @ argnames)
  2.1480 +    (map (fn i => "p" ^ string_of_int i) (1 upto (length iss)))
  2.1481 +  val param_vs = map Free (param_names' ~~ Ts1)
  2.1482 +  val (params', names) = fold_map mk_Eval_of ((params ~~ Ts1) ~~ iss) []
  2.1483 +  val predpropI = HOLogic.mk_Trueprop (list_comb (pred, param_vs @ args))
  2.1484 +  val predpropE = HOLogic.mk_Trueprop (list_comb (pred, params' @ args))
  2.1485 +  val param_eqs = map (HOLogic.mk_Trueprop o HOLogic.mk_eq) (param_vs ~~ params')
  2.1486 +  val funargs = params @ inargs
  2.1487 +  val funpropE = HOLogic.mk_Trueprop (PredicateCompFuns.mk_Eval (list_comb (funtrm, funargs),
  2.1488 +                  if null outargs then Free("y", HOLogic.unitT) else mk_tuple outargs))
  2.1489 +  val funpropI = HOLogic.mk_Trueprop (PredicateCompFuns.mk_Eval (list_comb (funtrm, funargs),
  2.1490 +                   mk_tuple outargs))
  2.1491 +  val introtrm = Logic.list_implies (predpropI :: param_eqs, funpropI)
  2.1492 +  val simprules = [defthm, @{thm eval_pred},
  2.1493 +	  @{thm "split_beta"}, @{thm "fst_conv"}, @{thm "snd_conv"}, @{thm pair_collapse}]
  2.1494 +  val unfolddef_tac = Simplifier.asm_full_simp_tac (HOL_basic_ss addsimps simprules) 1
  2.1495 +  val introthm = Goal.prove (ProofContext.init thy) (argnames @ param_names @ param_names' @ ["y"]) [] introtrm (fn {...} => unfolddef_tac)
  2.1496 +  val P = HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT));
  2.1497 +  val elimtrm = Logic.list_implies ([funpropE, Logic.mk_implies (predpropE, P)], P)
  2.1498 +  val elimthm = Goal.prove (ProofContext.init thy) (argnames @ param_names @ param_names' @ ["y", "P"]) [] elimtrm (fn {...} => unfolddef_tac)
  2.1499 +	val _ = Output.tracing (Display.string_of_thm_global thy elimthm)
  2.1500 +	val _ = Output.tracing (Display.string_of_thm_global thy introthm)
  2.1501 +
  2.1502 +in
  2.1503 +  (introthm, elimthm)
  2.1504 +end;
  2.1505 +
  2.1506 +fun create_constname_of_mode thy prefix name mode = 
  2.1507 +  let
  2.1508 +    fun string_of_mode mode = if null mode then "0"
  2.1509 +      else space_implode "_" (map (fn (i, NONE) => string_of_int i | (i, SOME pis) => string_of_int i ^ "p"
  2.1510 +        ^ space_implode "p" (map string_of_int pis)) mode)
  2.1511 +    val HOmode = space_implode "_and_"
  2.1512 +      (fold (fn NONE => I | SOME mode => cons (string_of_mode mode)) (fst mode) [])
  2.1513 +  in
  2.1514 +    (Sign.full_bname thy (prefix ^ (Long_Name.base_name name))) ^
  2.1515 +      (if HOmode = "" then "_" else "_for_" ^ HOmode ^ "_yields_") ^ (string_of_mode (snd mode))
  2.1516 +  end;
  2.1517 +
  2.1518 +fun split_tupleT is T =
  2.1519 +	let
  2.1520 +		fun split_tuple' _ _ [] = ([], [])
  2.1521 +			| split_tuple' is i (T::Ts) =
  2.1522 +			(if i mem is then apfst else apsnd) (cons T)
  2.1523 +				(split_tuple' is (i+1) Ts)
  2.1524 +	in
  2.1525 +	  split_tuple' is 1 (HOLogic.strip_tupleT T)
  2.1526 +  end
  2.1527 +	
  2.1528 +fun mk_arg xin xout pis T =
  2.1529 +  let
  2.1530 +	  val n = length (HOLogic.strip_tupleT T)
  2.1531 +		val ni = length pis
  2.1532 +	  fun mk_proj i j t =
  2.1533 +		  (if i = j then I else HOLogic.mk_fst)
  2.1534 +			  (funpow (i - 1) HOLogic.mk_snd t)
  2.1535 +	  fun mk_arg' i (si, so) = if i mem pis then
  2.1536 +		    (mk_proj si ni xin, (si+1, so))
  2.1537 +		  else
  2.1538 +			  (mk_proj so (n - ni) xout, (si, so+1))
  2.1539 +	  val (args, _) = fold_map mk_arg' (1 upto n) (1, 1)
  2.1540 +	in
  2.1541 +	  HOLogic.mk_tuple args
  2.1542 +	end
  2.1543 +
  2.1544 +fun create_definitions preds (name, modes) thy =
  2.1545 +  let
  2.1546 +    val compfuns = PredicateCompFuns.compfuns
  2.1547 +    val T = AList.lookup (op =) preds name |> the
  2.1548 +    fun create_definition (mode as (iss, is)) thy = let
  2.1549 +      val mode_cname = create_constname_of_mode thy "" name mode
  2.1550 +      val mode_cbasename = Long_Name.base_name mode_cname
  2.1551 +      val Ts = binder_types T
  2.1552 +      val (Ts1, Ts2) = chop (length iss) Ts
  2.1553 +      val (Us1, Us2) =  split_smodeT is Ts2
  2.1554 +      val Ts1' = map2 (fn NONE => I | SOME is => funT_of compfuns ([], is)) iss Ts1
  2.1555 +      val funT = (Ts1' @ Us1) ---> (mk_predT compfuns (mk_tupleT Us2))
  2.1556 +      val names = Name.variant_list []
  2.1557 +        (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts)));
  2.1558 +			(* old *)
  2.1559 +			(*
  2.1560 +		  val xs = map Free (names ~~ (Ts1' @ Ts2))
  2.1561 +      val (xparams, xargs) = chop (length iss) xs
  2.1562 +      val (xins, xouts) = split_smode is xargs
  2.1563 +			*)
  2.1564 +			(* new *)
  2.1565 +			val param_names = Name.variant_list []
  2.1566 +			  (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts1')))
  2.1567 +		  val xparams = map Free (param_names ~~ Ts1')
  2.1568 +      fun mk_vars (i, T) names =
  2.1569 +			  let
  2.1570 +				  val vname = Name.variant names ("x" ^ string_of_int (length Ts1' + i))
  2.1571 +				in
  2.1572 +					case AList.lookup (op =) is i of
  2.1573 +						 NONE => ((([], [Free (vname, T)]), Free (vname, T)), vname :: names)
  2.1574 +					 | SOME NONE => ((([Free (vname, T)], []), Free (vname, T)), vname :: names)
  2.1575 +        	 | SOME (SOME pis) =>
  2.1576 +					   let
  2.1577 +						   val (Tins, Touts) = split_tupleT pis T
  2.1578 +							 val name_in = Name.variant names ("x" ^ string_of_int (length Ts1' + i) ^ "in")
  2.1579 +							 val name_out = Name.variant names ("x" ^ string_of_int (length Ts1' + i) ^ "out")
  2.1580 +						   val xin = Free (name_in, HOLogic.mk_tupleT Tins)
  2.1581 +							 val xout = Free (name_out, HOLogic.mk_tupleT Touts)
  2.1582 +							 val xarg = mk_arg xin xout pis T
  2.1583 +						 in (((if null Tins then [] else [xin], if null Touts then [] else [xout]), xarg), name_in :: name_out :: names) end
  2.1584 +						(* HOLogic.strip_tupleT T of
  2.1585 +						[] => 
  2.1586 +							in (Free (vname, T), vname :: names) end
  2.1587 +					| [_] => let val vname = Name.variant names ("x" ^ string_of_int (length Ts1' + i))
  2.1588 +							in (Free (vname, T), vname :: names) end
  2.1589 +					| Ts =>
  2.1590 +						let
  2.1591 +							val vnames = Name.variant_list names
  2.1592 +								(map (fn j => "x" ^ string_of_int (length Ts1' + i) ^ "p" ^ string_of_int j)
  2.1593 +									(1 upto (length Ts)))
  2.1594 +						 in (HOLogic.mk_tuple (map Free (vnames ~~ Ts)), vnames @ names) end *)
  2.1595 +				end
  2.1596 +   	  val (xinoutargs, names) = fold_map mk_vars ((1 upto (length Ts2)) ~~ Ts2) param_names
  2.1597 +      val (xinout, xargs) = split_list xinoutargs
  2.1598 +			val (xins, xouts) = pairself flat (split_list xinout)
  2.1599 +			(*val (xins, xouts) = split_smode is xargs*)
  2.1600 +			val (xparams', names') = fold_map mk_Eval_of ((xparams ~~ Ts1) ~~ iss) names
  2.1601 +			val _ = Output.tracing ("xargs:" ^ commas (map (Syntax.string_of_term_global thy) xargs))
  2.1602 +      fun mk_split_lambda [] t = lambda (Free (Name.variant names' "x", HOLogic.unitT)) t
  2.1603 +        | mk_split_lambda [x] t = lambda x t
  2.1604 +        | mk_split_lambda xs t =
  2.1605 +        let
  2.1606 +          fun mk_split_lambda' (x::y::[]) t = HOLogic.mk_split (lambda x (lambda y t))
  2.1607 +            | mk_split_lambda' (x::xs) t = HOLogic.mk_split (lambda x (mk_split_lambda' xs t))
  2.1608 +        in
  2.1609 +          mk_split_lambda' xs t
  2.1610 +        end;
  2.1611 +      val predterm = PredicateCompFuns.mk_Enum (mk_split_lambda xouts
  2.1612 +        (list_comb (Const (name, T), xparams' @ xargs)))
  2.1613 +      val lhs = list_comb (Const (mode_cname, funT), xparams @ xins)
  2.1614 +      val def = Logic.mk_equals (lhs, predterm)
  2.1615 +			val _ = Output.tracing ("def:" ^ (Syntax.string_of_term_global thy def))
  2.1616 +      val ([definition], thy') = thy |>
  2.1617 +        Sign.add_consts_i [(Binding.name mode_cbasename, funT, NoSyn)] |>
  2.1618 +        PureThy.add_defs false [((Binding.name (mode_cbasename ^ "_def"), def), [])]
  2.1619 +      val (intro, elim) =
  2.1620 +        create_intro_elim_rule mode definition mode_cname funT (Const (name, T)) thy'
  2.1621 +			val _ = Output.tracing (Display.string_of_thm_global thy' definition)
  2.1622 +      in thy'
  2.1623 +			  |> add_predfun name mode (mode_cname, definition, intro, elim)
  2.1624 +        |> PureThy.store_thm (Binding.name (mode_cbasename ^ "I"), intro) |> snd
  2.1625 +        |> PureThy.store_thm (Binding.name (mode_cbasename ^ "E"), elim)  |> snd
  2.1626 +        |> Theory.checkpoint
  2.1627 +      end;
  2.1628 +  in
  2.1629 +    fold create_definition modes thy
  2.1630 +  end;
  2.1631 +
  2.1632 +fun sizelim_create_definitions preds (name, modes) thy =
  2.1633 +  let
  2.1634 +    val T = AList.lookup (op =) preds name |> the
  2.1635 +    fun create_definition mode thy =
  2.1636 +      let
  2.1637 +        val mode_cname = create_constname_of_mode thy "sizelim_" name mode
  2.1638 +        val funT = sizelim_funT_of PredicateCompFuns.compfuns mode T
  2.1639 +      in
  2.1640 +        thy |> Sign.add_consts_i [(Binding.name (Long_Name.base_name mode_cname), funT, NoSyn)]
  2.1641 +        |> set_sizelim_function_name name mode mode_cname 
  2.1642 +      end;
  2.1643 +  in
  2.1644 +    fold create_definition modes thy
  2.1645 +  end;
  2.1646 +    
  2.1647 +fun rpred_create_definitions preds (name, modes) thy =
  2.1648 +  let
  2.1649 +    val T = AList.lookup (op =) preds name |> the
  2.1650 +    fun create_definition mode thy =
  2.1651 +      let
  2.1652 +        val mode_cname = create_constname_of_mode thy "gen_" name mode
  2.1653 +        val funT = sizelim_funT_of RPredCompFuns.compfuns mode T
  2.1654 +      in
  2.1655 +        thy |> Sign.add_consts_i [(Binding.name (Long_Name.base_name mode_cname), funT, NoSyn)]
  2.1656 +        |> set_generator_name name mode mode_cname 
  2.1657 +      end;
  2.1658 +  in
  2.1659 +    fold create_definition modes thy
  2.1660 +  end;
  2.1661 +  
  2.1662 +(* Proving equivalence of term *)
  2.1663 +
  2.1664 +fun is_Type (Type _) = true
  2.1665 +  | is_Type _ = false
  2.1666 +
  2.1667 +(* returns true if t is an application of an datatype constructor *)
  2.1668 +(* which then consequently would be splitted *)
  2.1669 +(* else false *)
  2.1670 +fun is_constructor thy t =
  2.1671 +  if (is_Type (fastype_of t)) then
  2.1672 +    (case Datatype.get_info thy ((fst o dest_Type o fastype_of) t) of
  2.1673 +      NONE => false
  2.1674 +    | SOME info => (let
  2.1675 +      val constr_consts = maps (fn (_, (_, _, constrs)) => map fst constrs) (#descr info)
  2.1676 +      val (c, _) = strip_comb t
  2.1677 +      in (case c of
  2.1678 +        Const (name, _) => name mem_string constr_consts
  2.1679 +        | _ => false) end))
  2.1680 +  else false
  2.1681 +
  2.1682 +(* MAJOR FIXME:  prove_params should be simple
  2.1683 + - different form of introrule for parameters ? *)
  2.1684 +fun prove_param thy (NONE, t) = TRY (rtac @{thm refl} 1)
  2.1685 +  | prove_param thy (m as SOME (Mode (mode, is, ms)), t) =
  2.1686 +  let
  2.1687 +    val  (f, args) = strip_comb (Envir.eta_contract t)
  2.1688 +    val (params, _) = chop (length ms) args
  2.1689 +    val f_tac = case f of
  2.1690 +      Const (name, T) => simp_tac (HOL_basic_ss addsimps 
  2.1691 +         ([@{thm eval_pred}, (predfun_definition_of thy name mode),
  2.1692 +         @{thm "split_eta"}, @{thm "split_beta"}, @{thm "fst_conv"},
  2.1693 +				 @{thm "snd_conv"}, @{thm pair_collapse}, @{thm "Product_Type.split_conv"}])) 1
  2.1694 +    | Free _ => TRY (rtac @{thm refl} 1)
  2.1695 +    | Abs _ => error "prove_param: No valid parameter term"
  2.1696 +  in
  2.1697 +    REPEAT_DETERM (etac @{thm thin_rl} 1)
  2.1698 +    THEN REPEAT_DETERM (rtac @{thm ext} 1)
  2.1699 +    THEN print_tac "prove_param"
  2.1700 +    THEN f_tac
  2.1701 +    THEN print_tac "after simplification in prove_args"
  2.1702 +    THEN (EVERY (map (prove_param thy) (ms ~~ params)))
  2.1703 +    THEN (REPEAT_DETERM (atac 1))
  2.1704 +  end
  2.1705 +
  2.1706 +fun prove_expr thy (Mode (mode, is, ms), t, us) (premposition : int) =
  2.1707 +  case strip_comb t of
  2.1708 +    (Const (name, T), args) =>  
  2.1709 +      let
  2.1710 +        val introrule = predfun_intro_of thy name mode
  2.1711 +        val (args1, args2) = chop (length ms) args
  2.1712 +      in
  2.1713 +        rtac @{thm bindI} 1
  2.1714 +        THEN print_tac "before intro rule:"
  2.1715 +        (* for the right assumption in first position *)
  2.1716 +        THEN rotate_tac premposition 1
  2.1717 +        THEN debug_tac (Display.string_of_thm (ProofContext.init thy) introrule)
  2.1718 +        THEN rtac introrule 1
  2.1719 +        THEN print_tac "after intro rule"
  2.1720 +        (* work with parameter arguments *)
  2.1721 +        THEN (atac 1)
  2.1722 +        THEN (print_tac "parameter goal")
  2.1723 +        THEN (EVERY (map (prove_param thy) (ms ~~ args1)))
  2.1724 +        THEN (REPEAT_DETERM (atac 1))
  2.1725 +      end
  2.1726 +  | _ => rtac @{thm bindI} 1
  2.1727 +	  THEN asm_full_simp_tac
  2.1728 +		  (HOL_basic_ss' addsimps [@{thm "split_eta"}, @{thm "split_beta"}, @{thm "fst_conv"},
  2.1729 +				 @{thm "snd_conv"}, @{thm pair_collapse}]) 1
  2.1730 +	  THEN (atac 1)
  2.1731 +	  THEN print_tac "after prove parameter call"
  2.1732 +		
  2.1733 +
  2.1734 +fun SOLVED tac st = FILTER (fn st' => nprems_of st' = nprems_of st - 1) tac st; 
  2.1735 +
  2.1736 +fun SOLVEDALL tac st = FILTER (fn st' => nprems_of st' = 0) tac st
  2.1737 +
  2.1738 +fun prove_match thy (out_ts : term list) = let
  2.1739 +  fun get_case_rewrite t =
  2.1740 +    if (is_constructor thy t) then let
  2.1741 +      val case_rewrites = (#case_rewrites (Datatype.the_info thy
  2.1742 +        ((fst o dest_Type o fastype_of) t)))
  2.1743 +      in case_rewrites @ (flat (map get_case_rewrite (snd (strip_comb t)))) end
  2.1744 +    else []
  2.1745 +  val simprules = @{thm "unit.cases"} :: @{thm "prod.cases"} :: (flat (map get_case_rewrite out_ts))
  2.1746 +(* replace TRY by determining if it necessary - are there equations when calling compile match? *)
  2.1747 +in
  2.1748 +   (* make this simpset better! *)
  2.1749 +  asm_full_simp_tac (HOL_basic_ss' addsimps simprules) 1
  2.1750 +  THEN print_tac "after prove_match:"
  2.1751 +  THEN (DETERM (TRY (EqSubst.eqsubst_tac (ProofContext.init thy) [0] [@{thm "HOL.if_P"}] 1
  2.1752 +         THEN (REPEAT_DETERM (rtac @{thm conjI} 1 THEN (SOLVED (asm_simp_tac HOL_basic_ss 1))))
  2.1753 +         THEN (SOLVED (asm_simp_tac HOL_basic_ss 1)))))
  2.1754 +  THEN print_tac "after if simplification"
  2.1755 +end;
  2.1756 +
  2.1757 +(* corresponds to compile_fun -- maybe call that also compile_sidecond? *)
  2.1758 +
  2.1759 +fun prove_sidecond thy modes t =
  2.1760 +  let
  2.1761 +    fun preds_of t nameTs = case strip_comb t of 
  2.1762 +      (f as Const (name, T), args) =>
  2.1763 +        if AList.defined (op =) modes name then (name, T) :: nameTs
  2.1764 +          else fold preds_of args nameTs
  2.1765 +      | _ => nameTs
  2.1766 +    val preds = preds_of t []
  2.1767 +    val defs = map
  2.1768 +      (fn (pred, T) => predfun_definition_of thy pred
  2.1769 +        ([], map (rpair NONE) (1 upto (length (binder_types T)))))
  2.1770 +        preds
  2.1771 +  in 
  2.1772 +    (* remove not_False_eq_True when simpset in prove_match is better *)
  2.1773 +    simp_tac (HOL_basic_ss addsimps
  2.1774 +      (@{thms "HOL.simp_thms"} @ (@{thm not_False_eq_True} :: @{thm eval_pred} :: defs))) 1 
  2.1775 +    (* need better control here! *)
  2.1776 +  end
  2.1777 +
  2.1778 +fun prove_clause thy nargs modes (iss, is) (_, clauses) (ts, moded_ps) =
  2.1779 +  let
  2.1780 +    val (in_ts, clause_out_ts) = split_smode is ts;
  2.1781 +    fun prove_prems out_ts [] =
  2.1782 +      (prove_match thy out_ts)
  2.1783 +			THEN print_tac "before simplifying assumptions"
  2.1784 +      THEN asm_full_simp_tac HOL_basic_ss' 1
  2.1785 +			THEN print_tac "before single intro rule"
  2.1786 +      THEN (rtac (if null clause_out_ts then @{thm singleI_unit} else @{thm singleI}) 1)
  2.1787 +    | prove_prems out_ts ((p, mode as Mode ((iss, is), _, param_modes)) :: ps) =
  2.1788 +      let
  2.1789 +        val premposition = (find_index (equal p) clauses) + nargs
  2.1790 +        val rest_tac = (case p of Prem (us, t) =>
  2.1791 +            let
  2.1792 +              val (_, out_ts''') = split_smode is us
  2.1793 +              val rec_tac = prove_prems out_ts''' ps
  2.1794 +            in
  2.1795 +              print_tac "before clause:"
  2.1796 +              THEN asm_simp_tac HOL_basic_ss 1
  2.1797 +              THEN print_tac "before prove_expr:"
  2.1798 +              THEN prove_expr thy (mode, t, us) premposition
  2.1799 +              THEN print_tac "after prove_expr:"
  2.1800 +              THEN rec_tac
  2.1801 +            end
  2.1802 +          | Negprem (us, t) =>
  2.1803 +            let
  2.1804 +              val (_, out_ts''') = split_smode is us
  2.1805 +              val rec_tac = prove_prems out_ts''' ps
  2.1806 +              val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE)
  2.1807 +              val (_, params) = strip_comb t
  2.1808 +            in
  2.1809 +              rtac @{thm bindI} 1
  2.1810 +              THEN (if (is_some name) then
  2.1811 +                  simp_tac (HOL_basic_ss addsimps [predfun_definition_of thy (the name) (iss, is)]) 1
  2.1812 +                  THEN rtac @{thm not_predI} 1
  2.1813 +                  THEN simp_tac (HOL_basic_ss addsimps [@{thm not_False_eq_True}]) 1
  2.1814 +                  THEN (REPEAT_DETERM (atac 1))
  2.1815 +                  (* FIXME: work with parameter arguments *)
  2.1816 +                  THEN (EVERY (map (prove_param thy) (param_modes ~~ params)))
  2.1817 +                else
  2.1818 +                  rtac @{thm not_predI'} 1)
  2.1819 +                  THEN simp_tac (HOL_basic_ss addsimps [@{thm not_False_eq_True}]) 1
  2.1820 +              THEN rec_tac
  2.1821 +            end
  2.1822 +          | Sidecond t =>
  2.1823 +           rtac @{thm bindI} 1
  2.1824 +           THEN rtac @{thm if_predI} 1
  2.1825 +           THEN print_tac "before sidecond:"
  2.1826 +           THEN prove_sidecond thy modes t
  2.1827 +           THEN print_tac "after sidecond:"
  2.1828 +           THEN prove_prems [] ps)
  2.1829 +      in (prove_match thy out_ts)
  2.1830 +          THEN rest_tac
  2.1831 +      end;
  2.1832 +    val prems_tac = prove_prems in_ts moded_ps
  2.1833 +  in
  2.1834 +    rtac @{thm bindI} 1
  2.1835 +    THEN rtac @{thm singleI} 1
  2.1836 +    THEN prems_tac
  2.1837 +  end;
  2.1838 +
  2.1839 +fun select_sup 1 1 = []
  2.1840 +  | select_sup _ 1 = [rtac @{thm supI1}]
  2.1841 +  | select_sup n i = (rtac @{thm supI2})::(select_sup (n - 1) (i - 1));
  2.1842 +
  2.1843 +fun prove_one_direction thy clauses preds modes pred mode moded_clauses =
  2.1844 +  let
  2.1845 +    val T = the (AList.lookup (op =) preds pred)
  2.1846 +    val nargs = length (binder_types T) - nparams_of thy pred
  2.1847 +    val pred_case_rule = the_elim_of thy pred
  2.1848 +  in
  2.1849 +    REPEAT_DETERM (CHANGED (rewtac @{thm "split_paired_all"}))
  2.1850 +		THEN print_tac "before applying elim rule"
  2.1851 +    THEN etac (predfun_elim_of thy pred mode) 1
  2.1852 +    THEN etac pred_case_rule 1
  2.1853 +    THEN (EVERY (map
  2.1854 +           (fn i => EVERY' (select_sup (length moded_clauses) i) i) 
  2.1855 +             (1 upto (length moded_clauses))))
  2.1856 +    THEN (EVERY (map2 (prove_clause thy nargs modes mode) clauses moded_clauses))
  2.1857 +    THEN print_tac "proved one direction"
  2.1858 +  end;
  2.1859 +
  2.1860 +(** Proof in the other direction **)
  2.1861 +
  2.1862 +fun prove_match2 thy out_ts = let
  2.1863 +  fun split_term_tac (Free _) = all_tac
  2.1864 +    | split_term_tac t =
  2.1865 +      if (is_constructor thy t) then let
  2.1866 +        val info = Datatype.the_info thy ((fst o dest_Type o fastype_of) t)
  2.1867 +        val num_of_constrs = length (#case_rewrites info)
  2.1868 +        (* special treatment of pairs -- because of fishing *)
  2.1869 +        val split_rules = case (fst o dest_Type o fastype_of) t of
  2.1870 +          "*" => [@{thm prod.split_asm}] 
  2.1871 +          | _ => PureThy.get_thms thy (((fst o dest_Type o fastype_of) t) ^ ".split_asm")
  2.1872 +        val (_, ts) = strip_comb t
  2.1873 +      in
  2.1874 +        (Splitter.split_asm_tac split_rules 1)
  2.1875 +(*        THEN (Simplifier.asm_full_simp_tac HOL_basic_ss 1)
  2.1876 +          THEN (DETERM (TRY (etac @{thm Pair_inject} 1))) *)
  2.1877 +        THEN (REPEAT_DETERM_N (num_of_constrs - 1) (etac @{thm botE} 1 ORELSE etac @{thm botE} 2))
  2.1878 +        THEN (EVERY (map split_term_tac ts))
  2.1879 +      end
  2.1880 +    else all_tac
  2.1881 +  in
  2.1882 +    split_term_tac (mk_tuple out_ts)
  2.1883 +    THEN (DETERM (TRY ((Splitter.split_asm_tac [@{thm "split_if_asm"}] 1) THEN (etac @{thm botE} 2))))
  2.1884 +  end
  2.1885 +
  2.1886 +(* VERY LARGE SIMILIRATIY to function prove_param 
  2.1887 +-- join both functions
  2.1888 +*)
  2.1889 +(* TODO: remove function *)
  2.1890 +
  2.1891 +fun prove_param2 thy (NONE, t) = all_tac 
  2.1892 +  | prove_param2 thy (m as SOME (Mode (mode, is, ms)), t) = let
  2.1893 +    val  (f, args) = strip_comb (Envir.eta_contract t)
  2.1894 +    val (params, _) = chop (length ms) args
  2.1895 +    val f_tac = case f of
  2.1896 +        Const (name, T) => full_simp_tac (HOL_basic_ss addsimps 
  2.1897 +           (@{thm eval_pred}::(predfun_definition_of thy name mode)
  2.1898 +           :: @{thm "Product_Type.split_conv"}::[])) 1
  2.1899 +      | Free _ => all_tac
  2.1900 +      | _ => error "prove_param2: illegal parameter term"
  2.1901 +  in  
  2.1902 +    print_tac "before simplification in prove_args:"
  2.1903 +    THEN f_tac
  2.1904 +    THEN print_tac "after simplification in prove_args"
  2.1905 +    THEN (EVERY (map (prove_param2 thy) (ms ~~ params)))
  2.1906 +  end
  2.1907 +
  2.1908 +
  2.1909 +fun prove_expr2 thy (Mode (mode, is, ms), t) = 
  2.1910 +  (case strip_comb t of
  2.1911 +    (Const (name, T), args) =>
  2.1912 +      etac @{thm bindE} 1
  2.1913 +      THEN (REPEAT_DETERM (CHANGED (rewtac @{thm "split_paired_all"})))
  2.1914 +      THEN print_tac "prove_expr2-before"
  2.1915 +      THEN (debug_tac (Syntax.string_of_term_global thy
  2.1916 +        (prop_of (predfun_elim_of thy name mode))))
  2.1917 +      THEN (etac (predfun_elim_of thy name mode) 1)
  2.1918 +      THEN print_tac "prove_expr2"
  2.1919 +      THEN (EVERY (map (prove_param2 thy) (ms ~~ args)))
  2.1920 +      THEN print_tac "finished prove_expr2"      
  2.1921 +    | _ => etac @{thm bindE} 1)
  2.1922 +    
  2.1923 +(* FIXME: what is this for? *)
  2.1924 +(* replace defined by has_mode thy pred *)
  2.1925 +(* TODO: rewrite function *)
  2.1926 +fun prove_sidecond2 thy modes t = let
  2.1927 +  fun preds_of t nameTs = case strip_comb t of 
  2.1928 +    (f as Const (name, T), args) =>
  2.1929 +      if AList.defined (op =) modes name then (name, T) :: nameTs
  2.1930 +        else fold preds_of args nameTs
  2.1931 +    | _ => nameTs
  2.1932 +  val preds = preds_of t []
  2.1933 +  val defs = map
  2.1934 +    (fn (pred, T) => predfun_definition_of thy pred 
  2.1935 +      ([], map (rpair NONE) (1 upto (length (binder_types T)))))
  2.1936 +      preds
  2.1937 +  in
  2.1938 +   (* only simplify the one assumption *)
  2.1939 +   full_simp_tac (HOL_basic_ss' addsimps @{thm eval_pred} :: defs) 1 
  2.1940 +   (* need better control here! *)
  2.1941 +   THEN print_tac "after sidecond2 simplification"
  2.1942 +   end
  2.1943 +  
  2.1944 +fun prove_clause2 thy modes pred (iss, is) (ts, ps) i =
  2.1945 +  let
  2.1946 +    val pred_intro_rule = nth (intros_of thy pred) (i - 1)
  2.1947 +    val (in_ts, clause_out_ts) = split_smode is ts;
  2.1948 +    fun prove_prems2 out_ts [] =
  2.1949 +      print_tac "before prove_match2 - last call:"
  2.1950 +      THEN prove_match2 thy out_ts
  2.1951 +      THEN print_tac "after prove_match2 - last call:"
  2.1952 +      THEN (etac @{thm singleE} 1)
  2.1953 +      THEN (REPEAT_DETERM (etac @{thm Pair_inject} 1))
  2.1954 +      THEN (asm_full_simp_tac HOL_basic_ss' 1)
  2.1955 +      THEN (REPEAT_DETERM (etac @{thm Pair_inject} 1))
  2.1956 +      THEN (asm_full_simp_tac HOL_basic_ss' 1)
  2.1957 +      THEN SOLVED (print_tac "state before applying intro rule:"
  2.1958 +      THEN (rtac pred_intro_rule 1)
  2.1959 +      (* How to handle equality correctly? *)
  2.1960 +      THEN (print_tac "state before assumption matching")
  2.1961 +      THEN (REPEAT (atac 1 ORELSE 
  2.1962 +         (CHANGED (asm_full_simp_tac (HOL_basic_ss' addsimps
  2.1963 +					 [@{thm split_eta}, @{thm "split_beta"}, @{thm "fst_conv"}, @{thm "snd_conv"}, @{thm pair_collapse}]) 1)
  2.1964 +          THEN print_tac "state after simp_tac:"))))
  2.1965 +    | prove_prems2 out_ts ((p, mode as Mode ((iss, is), _, param_modes)) :: ps) =
  2.1966 +      let
  2.1967 +        val rest_tac = (case p of
  2.1968 +          Prem (us, t) =>
  2.1969 +          let
  2.1970 +            val (_, out_ts''') = split_smode is us
  2.1971 +            val rec_tac = prove_prems2 out_ts''' ps
  2.1972 +          in
  2.1973 +            (prove_expr2 thy (mode, t)) THEN rec_tac
  2.1974 +          end
  2.1975 +        | Negprem (us, t) =>
  2.1976 +          let
  2.1977 +            val (_, out_ts''') = split_smode is us
  2.1978 +            val rec_tac = prove_prems2 out_ts''' ps
  2.1979 +            val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE)
  2.1980 +            val (_, params) = strip_comb t
  2.1981 +          in
  2.1982 +            print_tac "before neg prem 2"
  2.1983 +            THEN etac @{thm bindE} 1
  2.1984 +            THEN (if is_some name then
  2.1985 +                full_simp_tac (HOL_basic_ss addsimps [predfun_definition_of thy (the name) (iss, is)]) 1 
  2.1986 +                THEN etac @{thm not_predE} 1
  2.1987 +                THEN simp_tac (HOL_basic_ss addsimps [@{thm not_False_eq_True}]) 1
  2.1988 +                THEN (EVERY (map (prove_param2 thy) (param_modes ~~ params)))
  2.1989 +              else
  2.1990 +                etac @{thm not_predE'} 1)
  2.1991 +            THEN rec_tac
  2.1992 +          end 
  2.1993 +        | Sidecond t =>
  2.1994 +          etac @{thm bindE} 1
  2.1995 +          THEN etac @{thm if_predE} 1
  2.1996 +          THEN prove_sidecond2 thy modes t 
  2.1997 +          THEN prove_prems2 [] ps)
  2.1998 +      in print_tac "before prove_match2:"
  2.1999 +         THEN prove_match2 thy out_ts
  2.2000 +         THEN print_tac "after prove_match2:"
  2.2001 +         THEN rest_tac
  2.2002 +      end;
  2.2003 +    val prems_tac = prove_prems2 in_ts ps 
  2.2004 +  in
  2.2005 +    print_tac "starting prove_clause2"
  2.2006 +    THEN etac @{thm bindE} 1
  2.2007 +    THEN (etac @{thm singleE'} 1)
  2.2008 +    THEN (TRY (etac @{thm Pair_inject} 1))
  2.2009 +    THEN print_tac "after singleE':"
  2.2010 +    THEN prems_tac
  2.2011 +  end;
  2.2012 + 
  2.2013 +fun prove_other_direction thy modes pred mode moded_clauses =
  2.2014 +  let
  2.2015 +    fun prove_clause clause i =
  2.2016 +      (if i < length moded_clauses then etac @{thm supE} 1 else all_tac)
  2.2017 +      THEN (prove_clause2 thy modes pred mode clause i)
  2.2018 +  in
  2.2019 +    (DETERM (TRY (rtac @{thm unit.induct} 1)))
  2.2020 +     THEN (REPEAT_DETERM (CHANGED (rewtac @{thm split_paired_all})))
  2.2021 +     THEN (rtac (predfun_intro_of thy pred mode) 1)
  2.2022 +     THEN (REPEAT_DETERM (rtac @{thm refl} 2))
  2.2023 +     THEN (EVERY (map2 prove_clause moded_clauses (1 upto (length moded_clauses))))
  2.2024 +  end;
  2.2025 +
  2.2026 +(** proof procedure **)
  2.2027 +
  2.2028 +fun prove_pred thy clauses preds modes pred mode (moded_clauses, compiled_term) =
  2.2029 +  let
  2.2030 +    val ctxt = ProofContext.init thy
  2.2031 +    val clauses = the (AList.lookup (op =) clauses pred)
  2.2032 +  in
  2.2033 +    Goal.prove ctxt (Term.add_free_names compiled_term []) [] compiled_term
  2.2034 +      (if !do_proofs then
  2.2035 +        (fn _ =>
  2.2036 +        rtac @{thm pred_iffI} 1
  2.2037 +				THEN print_tac "after pred_iffI"
  2.2038 +        THEN prove_one_direction thy clauses preds modes pred mode moded_clauses
  2.2039 +        THEN print_tac "proved one direction"
  2.2040 +        THEN prove_other_direction thy modes pred mode moded_clauses
  2.2041 +        THEN print_tac "proved other direction")
  2.2042 +       else (fn _ => mycheat_tac thy 1))
  2.2043 +  end;
  2.2044 +
  2.2045 +(* composition of mode inference, definition, compilation and proof *)
  2.2046 +
  2.2047 +(** auxillary combinators for table of preds and modes **)
  2.2048 +
  2.2049 +fun map_preds_modes f preds_modes_table =
  2.2050 +  map (fn (pred, modes) =>
  2.2051 +    (pred, map (fn (mode, value) => (mode, f pred mode value)) modes)) preds_modes_table
  2.2052 +
  2.2053 +fun join_preds_modes table1 table2 =
  2.2054 +  map_preds_modes (fn pred => fn mode => fn value =>
  2.2055 +    (value, the (AList.lookup (op =) (the (AList.lookup (op =) table2 pred)) mode))) table1
  2.2056 +    
  2.2057 +fun maps_modes preds_modes_table =
  2.2058 +  map (fn (pred, modes) =>
  2.2059 +    (pred, map (fn (mode, value) => value) modes)) preds_modes_table  
  2.2060 +    
  2.2061 +fun compile_preds compfuns mk_fun_of use_size thy all_vs param_vs preds moded_clauses =
  2.2062 +  map_preds_modes (fn pred => compile_pred compfuns mk_fun_of use_size thy all_vs param_vs pred
  2.2063 +      (the (AList.lookup (op =) preds pred))) moded_clauses  
  2.2064 +  
  2.2065 +fun prove thy clauses preds modes moded_clauses compiled_terms =
  2.2066 +  map_preds_modes (prove_pred thy clauses preds modes)
  2.2067 +    (join_preds_modes moded_clauses compiled_terms)
  2.2068 +
  2.2069 +fun prove_by_skip thy _ _ _ _ compiled_terms =
  2.2070 +  map_preds_modes (fn pred => fn mode => fn t => Drule.standard (SkipProof.make_thm thy t))
  2.2071 +    compiled_terms
  2.2072 +    
  2.2073 +fun prepare_intrs thy prednames =
  2.2074 +  let
  2.2075 +    val intrs = maps (intros_of thy) prednames
  2.2076 +      |> map (Logic.unvarify o prop_of)
  2.2077 +    val nparams = nparams_of thy (hd prednames)
  2.2078 +    val extra_modes = all_modes_of thy |> filter_out (fn (name, _) => member (op =) prednames name)
  2.2079 +    val preds = distinct (op =) (map (dest_Const o fst o (strip_intro_concl nparams)) intrs)
  2.2080 +    val _ $ u = Logic.strip_imp_concl (hd intrs);
  2.2081 +    val params = List.take (snd (strip_comb u), nparams);
  2.2082 +    val param_vs = maps term_vs params
  2.2083 +    val all_vs = terms_vs intrs
  2.2084 +    fun dest_prem t =
  2.2085 +      (case strip_comb t of
  2.2086 +        (v as Free _, ts) => if v mem params then Prem (ts, v) else Sidecond t
  2.2087 +      | (c as Const (@{const_name Not}, _), [t]) => (case dest_prem t of          
  2.2088 +          Prem (ts, t) => Negprem (ts, t)
  2.2089 +        | Negprem _ => error ("Double negation not allowed in premise: " ^ (Syntax.string_of_term_global thy (c $ t))) 
  2.2090 +        | Sidecond t => Sidecond (c $ t))
  2.2091 +      | (c as Const (s, _), ts) =>
  2.2092 +        if is_registered thy s then
  2.2093 +          let val (ts1, ts2) = chop (nparams_of thy s) ts
  2.2094 +          in Prem (ts2, list_comb (c, ts1)) end
  2.2095 +        else Sidecond t
  2.2096 +      | _ => Sidecond t)
  2.2097 +    fun add_clause intr (clauses, arities) =
  2.2098 +    let
  2.2099 +      val _ $ t = Logic.strip_imp_concl intr;
  2.2100 +      val (Const (name, T), ts) = strip_comb t;
  2.2101 +      val (ts1, ts2) = chop nparams ts;
  2.2102 +      val prems = map (dest_prem o HOLogic.dest_Trueprop) (Logic.strip_imp_prems intr);
  2.2103 +      val (Ts, Us) = chop nparams (binder_types T)
  2.2104 +    in
  2.2105 +      (AList.update op = (name, these (AList.lookup op = clauses name) @
  2.2106 +        [(ts2, prems)]) clauses,
  2.2107 +       AList.update op = (name, (map (fn U => (case strip_type U of
  2.2108 +                 (Rs as _ :: _, Type ("bool", [])) => SOME (length Rs)
  2.2109 +               | _ => NONE)) Ts,
  2.2110 +             length Us)) arities)
  2.2111 +    end;
  2.2112 +    val (clauses, arities) = fold add_clause intrs ([], []);
  2.2113 +    fun modes_of_arities arities =
  2.2114 +      (map (fn (s, (ks, k)) => (s, cprod (cprods (map
  2.2115 +            (fn NONE => [NONE]
  2.2116 +              | SOME k' => map SOME (map (map (rpair NONE)) (subsets 1 k'))) ks),
  2.2117 +       map (map (rpair NONE)) (subsets 1 k)))) arities)
  2.2118 +    fun modes_of_typ T =
  2.2119 +      let
  2.2120 +        val (Ts, Us) = chop nparams (binder_types T)
  2.2121 +        fun all_smodes_of_typs Ts = cprods_subset (
  2.2122 +          map_index (fn (i, U) =>
  2.2123 +            case HOLogic.strip_tupleT U of
  2.2124 +              [] => [(i + 1, NONE)]
  2.2125 +            | [U] => [(i + 1, NONE)]
  2.2126 +	    | Us =>  map (pair (i + 1) o SOME) ((subsets 1 (length Us)) \\ [[], 1 upto (length Us)]))
  2.2127 +          Ts)
  2.2128 +      in
  2.2129 +        cprod (cprods (map (fn T => case strip_type T of
  2.2130 +          (Rs as _ :: _, Type ("bool", [])) => map SOME (all_smodes_of_typs Rs) | _ => [NONE]) Ts),
  2.2131 +           all_smodes_of_typs Us)
  2.2132 +      end
  2.2133 +    val all_modes = map (fn (s, T) => (s, modes_of_typ T)) preds
  2.2134 +  in (preds, nparams, all_vs, param_vs, extra_modes, clauses, all_modes) end;
  2.2135 +
  2.2136 +(** main function of predicate compiler **)
  2.2137 +
  2.2138 +fun add_equations_of steps prednames thy =
  2.2139 +  let
  2.2140 +    val _ = Output.tracing ("Starting predicate compiler for predicates " ^ commas prednames ^ "...")
  2.2141 +    val (preds, nparams, all_vs, param_vs, extra_modes, clauses, all_modes) =
  2.2142 +      prepare_intrs thy prednames
  2.2143 +    val _ = Output.tracing "Infering modes..."
  2.2144 +    val moded_clauses = #infer_modes steps thy extra_modes all_modes param_vs clauses 
  2.2145 +    val modes = map (fn (p, mps) => (p, map fst mps)) moded_clauses
  2.2146 +    val _ = print_modes modes
  2.2147 +    val _ = print_moded_clauses thy moded_clauses
  2.2148 +    val _ = Output.tracing "Defining executable functions..."
  2.2149 +    val thy' = fold (#create_definitions steps preds) modes thy
  2.2150 +      |> Theory.checkpoint
  2.2151 +    val _ = Output.tracing "Compiling equations..."
  2.2152 +    val compiled_terms =
  2.2153 +      (#compile_preds steps) thy' all_vs param_vs preds moded_clauses
  2.2154 +    val _ = print_compiled_terms thy' compiled_terms
  2.2155 +    val _ = Output.tracing "Proving equations..."
  2.2156 +    val result_thms = #prove steps thy' clauses preds (extra_modes @ modes)
  2.2157 +      moded_clauses compiled_terms
  2.2158 +    val qname = #qname steps
  2.2159 +    (* val attrib = gn thy => Attrib.attribute_i thy Code.add_eqn_attrib *)
  2.2160 +    val attrib = fn thy => Attrib.attribute_i thy (Attrib.internal (K (Thm.declaration_attribute
  2.2161 +      (fn thm => Context.mapping (Code.add_eqn thm) I))))
  2.2162 +    val thy'' = fold (fn (name, result_thms) => fn thy => snd (PureThy.add_thmss
  2.2163 +      [((Binding.qualify true (Long_Name.base_name name) (Binding.name qname), result_thms),
  2.2164 +        [attrib thy ])] thy))
  2.2165 +      (maps_modes result_thms) thy'
  2.2166 +      |> Theory.checkpoint
  2.2167 +  in
  2.2168 +    thy''
  2.2169 +  end
  2.2170 +
  2.2171 +fun extend' value_of edges_of key (G, visited) =
  2.2172 +  let
  2.2173 +    val (G', v) = case try (Graph.get_node G) key of
  2.2174 +        SOME v => (G, v)
  2.2175 +      | NONE => (Graph.new_node (key, value_of key) G, value_of key)
  2.2176 +    val (G'', visited') = fold (extend' value_of edges_of) (edges_of (key, v) \\ visited)
  2.2177 +      (G', key :: visited) 
  2.2178 +  in
  2.2179 +    (fold (Graph.add_edge o (pair key)) (edges_of (key, v)) G'', visited')
  2.2180 +  end;
  2.2181 +
  2.2182 +fun extend value_of edges_of key G = fst (extend' value_of edges_of key (G, [])) 
  2.2183 +  
  2.2184 +fun gen_add_equations steps names thy =
  2.2185 +  let
  2.2186 +    val thy' = PredData.map (fold (extend (fetch_pred_data thy) (depending_preds_of thy)) names) thy
  2.2187 +      |> Theory.checkpoint;
  2.2188 +    fun strong_conn_of gr keys =
  2.2189 +      Graph.strong_conn (Graph.subgraph (member (op =) (Graph.all_succs gr keys)) gr)
  2.2190 +    val scc = strong_conn_of (PredData.get thy') names
  2.2191 +    val thy'' = fold_rev
  2.2192 +      (fn preds => fn thy =>
  2.2193 +        if #are_not_defined steps thy preds then add_equations_of steps preds thy else thy)
  2.2194 +      scc thy' |> Theory.checkpoint
  2.2195 +  in thy'' end
  2.2196 +
  2.2197 +(* different instantiantions of the predicate compiler *)
  2.2198 +
  2.2199 +val add_equations = gen_add_equations
  2.2200 +  {infer_modes = infer_modes,
  2.2201 +  create_definitions = create_definitions,
  2.2202 +  compile_preds = compile_preds PredicateCompFuns.compfuns mk_fun_of false,
  2.2203 +  prove = prove,
  2.2204 +  are_not_defined = (fn thy => forall (null o modes_of thy)),
  2.2205 +  qname = "equation"}
  2.2206 +
  2.2207 +val add_sizelim_equations = gen_add_equations
  2.2208 +  {infer_modes = infer_modes,
  2.2209 +  create_definitions = sizelim_create_definitions,
  2.2210 +  compile_preds = compile_preds PredicateCompFuns.compfuns mk_sizelim_fun_of true,
  2.2211 +  prove = prove_by_skip,
  2.2212 +  are_not_defined = (fn thy => fn preds => true), (* TODO *)
  2.2213 +  qname = "sizelim_equation"
  2.2214 +  }
  2.2215 +
  2.2216 +val add_quickcheck_equations = gen_add_equations
  2.2217 +  {infer_modes = infer_modes_with_generator,
  2.2218 +  create_definitions = rpred_create_definitions,
  2.2219 +  compile_preds = compile_preds RPredCompFuns.compfuns mk_generator_of true,
  2.2220 +  prove = prove_by_skip,
  2.2221 +  are_not_defined = (fn thy => fn preds => true), (* TODO *)
  2.2222 +  qname = "rpred_equation"}
  2.2223 +
  2.2224 +(** user interface **)
  2.2225 +
  2.2226 +(* generation of case rules from user-given introduction rules *)
  2.2227 +
  2.2228 +fun mk_casesrule ctxt nparams introrules =
  2.2229 +  let
  2.2230 +    val intros = map (Logic.unvarify o prop_of) introrules
  2.2231 +    val (pred, (params, args)) = strip_intro_concl nparams (hd intros)
  2.2232 +    val ([propname], ctxt1) = Variable.variant_fixes ["thesis"] ctxt
  2.2233 +    val prop = HOLogic.mk_Trueprop (Free (propname, HOLogic.boolT))
  2.2234 +    val (argnames, ctxt2) = Variable.variant_fixes
  2.2235 +      (map (fn i => "a" ^ string_of_int i) (1 upto (length args))) ctxt1
  2.2236 +    val argvs = map2 (curry Free) argnames (map fastype_of args)
  2.2237 +    fun mk_case intro =
  2.2238 +      let
  2.2239 +        val (_, (_, args)) = strip_intro_concl nparams intro
  2.2240 +        val prems = Logic.strip_imp_prems intro
  2.2241 +        val eqprems = map (HOLogic.mk_Trueprop o HOLogic.mk_eq) (argvs ~~ args)
  2.2242 +        val frees = (fold o fold_aterms)
  2.2243 +          (fn t as Free _ =>
  2.2244 +              if member (op aconv) params t then I else insert (op aconv) t
  2.2245 +           | _ => I) (args @ prems) []
  2.2246 +      in fold Logic.all frees (Logic.list_implies (eqprems @ prems, prop)) end
  2.2247 +    val assm = HOLogic.mk_Trueprop (list_comb (pred, params @ argvs))
  2.2248 +    val cases = map mk_case intros
  2.2249 +  in Logic.list_implies (assm :: cases, prop) end;
  2.2250 +
  2.2251 +(* code_pred_intro attribute *)
  2.2252 +
  2.2253 +fun attrib f = Thm.declaration_attribute (fn thm => Context.mapping (f thm) I);
  2.2254 +
  2.2255 +val code_pred_intros_attrib = attrib add_intro;
  2.2256 +
  2.2257 +local
  2.2258 +
  2.2259 +(* TODO: make TheoryDataFun to GenericDataFun & remove duplication of local theory and theory *)
  2.2260 +fun generic_code_pred prep_const raw_const lthy =
  2.2261 +  let
  2.2262 +    val thy = ProofContext.theory_of lthy
  2.2263 +    val const = prep_const thy raw_const
  2.2264 +    val lthy' = LocalTheory.theory (PredData.map
  2.2265 +        (extend (fetch_pred_data thy) (depending_preds_of thy) const)) lthy
  2.2266 +      |> LocalTheory.checkpoint
  2.2267 +    val thy' = ProofContext.theory_of lthy'
  2.2268 +    val preds = Graph.all_preds (PredData.get thy') [const] |> filter_out (has_elim thy')
  2.2269 +    fun mk_cases const =
  2.2270 +      let
  2.2271 +        val nparams = nparams_of thy' const
  2.2272 +        val intros = intros_of thy' const
  2.2273 +      in mk_casesrule lthy' nparams intros end  
  2.2274 +    val cases_rules = map mk_cases preds
  2.2275 +    val cases =
  2.2276 +      map (fn case_rule => RuleCases.Case {fixes = [],
  2.2277 +        assumes = [("", Logic.strip_imp_prems case_rule)],
  2.2278 +        binds = [], cases = []}) cases_rules
  2.2279 +    val case_env = map2 (fn p => fn c => (Long_Name.base_name p, SOME c)) preds cases
  2.2280 +    val lthy'' = lthy'
  2.2281 +      |> fold Variable.auto_fixes cases_rules 
  2.2282 +      |> ProofContext.add_cases true case_env
  2.2283 +    fun after_qed thms goal_ctxt =
  2.2284 +      let
  2.2285 +        val global_thms = ProofContext.export goal_ctxt
  2.2286 +          (ProofContext.init (ProofContext.theory_of goal_ctxt)) (map the_single thms)
  2.2287 +      in
  2.2288 +        goal_ctxt |> LocalTheory.theory (fold set_elim global_thms #> add_equations [const])
  2.2289 +      end  
  2.2290 +  in
  2.2291 +    Proof.theorem_i NONE after_qed (map (single o (rpair [])) cases_rules) lthy''
  2.2292 +  end;
  2.2293 +
  2.2294 +structure P = OuterParse
  2.2295 +
  2.2296 +in
  2.2297 +
  2.2298 +val code_pred = generic_code_pred (K I);
  2.2299 +val code_pred_cmd = generic_code_pred Code.read_const
  2.2300 +
  2.2301 +val setup = PredData.put (Graph.empty) #>
  2.2302 +  Attrib.setup @{binding code_pred_intros} (Scan.succeed (attrib add_intro))
  2.2303 +    "adding alternative introduction rules for code generation of inductive predicates"
  2.2304 +(*  Attrib.setup @{binding code_ind_cases} (Scan.succeed add_elim_attrib)
  2.2305 +    "adding alternative elimination rules for code generation of inductive predicates";
  2.2306 +    *)
  2.2307 +  (*FIXME name discrepancy in attribs and ML code*)
  2.2308 +  (*FIXME intros should be better named intro*)
  2.2309 +  (*FIXME why distinguished attribute for cases?*)
  2.2310 +
  2.2311 +val _ = OuterSyntax.local_theory_to_proof "code_pred"
  2.2312 +  "prove equations for predicate specified by intro/elim rules"
  2.2313 +  OuterKeyword.thy_goal (P.term_group >> code_pred_cmd)
  2.2314 +
  2.2315 +end
  2.2316 +
  2.2317 +(*FIXME
  2.2318 +- Naming of auxiliary rules necessary?
  2.2319 +- add default code equations P x y z = P_i_i_i x y z
  2.2320 +*)
  2.2321 +
  2.2322 +(* transformation for code generation *)
  2.2323 +
  2.2324 +val eval_ref = ref (NONE : (unit -> term Predicate.pred) option);
  2.2325 +
  2.2326 +(*FIXME turn this into an LCF-guarded preprocessor for comprehensions*)
  2.2327 +fun analyze_compr thy t_compr =
  2.2328 +  let
  2.2329 +    val split = case t_compr of (Const (@{const_name Collect}, _) $ t) => t
  2.2330 +      | _ => error ("Not a set comprehension: " ^ Syntax.string_of_term_global thy t_compr);
  2.2331 +    val (body, Ts, fp) = HOLogic.strip_psplits split;
  2.2332 +    val (pred as Const (name, T), all_args) = strip_comb body;
  2.2333 +    val (params, args) = chop (nparams_of thy name) all_args;
  2.2334 +    val user_mode = map_filter I (map_index
  2.2335 +      (fn (i, t) => case t of Bound j => if j < length Ts then NONE
  2.2336 +        else SOME (i+1) | _ => SOME (i+1)) args); (*FIXME dangling bounds should not occur*)
  2.2337 +    val user_mode' = map (rpair NONE) user_mode
  2.2338 +    val modes = filter (fn Mode (_, is, _) => is = user_mode')
  2.2339 +      (modes_of_term (all_modes_of thy) (list_comb (pred, params)));
  2.2340 +    val m = case modes
  2.2341 +     of [] => error ("No mode possible for comprehension "
  2.2342 +                ^ Syntax.string_of_term_global thy t_compr)
  2.2343 +      | [m] => m
  2.2344 +      | m :: _ :: _ => (warning ("Multiple modes possible for comprehension "
  2.2345 +                ^ Syntax.string_of_term_global thy t_compr); m);
  2.2346 +    val (inargs, outargs) = split_smode user_mode' args;
  2.2347 +    val t_pred = list_comb (compile_expr NONE thy (m, list_comb (pred, params)), inargs);
  2.2348 +    val t_eval = if null outargs then t_pred else let
  2.2349 +        val outargs_bounds = map (fn Bound i => i) outargs;
  2.2350 +        val outargsTs = map (nth Ts) outargs_bounds;
  2.2351 +        val T_pred = HOLogic.mk_tupleT outargsTs;
  2.2352 +        val T_compr = HOLogic.mk_ptupleT fp Ts;
  2.2353 +        val arrange_bounds = map_index I outargs_bounds
  2.2354 +          |> sort (prod_ord (K EQUAL) int_ord)
  2.2355 +          |> map fst;
  2.2356 +        val arrange = funpow (length outargs_bounds - 1) HOLogic.mk_split
  2.2357 +          (Term.list_abs (map (pair "") outargsTs,
  2.2358 +            HOLogic.mk_ptuple fp T_compr (map Bound arrange_bounds)))
  2.2359 +      in mk_map PredicateCompFuns.compfuns T_pred T_compr arrange t_pred end
  2.2360 +  in t_eval end;
  2.2361 +
  2.2362 +fun eval thy t_compr =
  2.2363 +  let
  2.2364 +    val t = analyze_compr thy t_compr;
  2.2365 +    val T = dest_predT PredicateCompFuns.compfuns (fastype_of t);
  2.2366 +    val t' = mk_map PredicateCompFuns.compfuns T HOLogic.termT (HOLogic.term_of_const T) t;
  2.2367 +  in (T, Code_ML.eval NONE ("Predicate_Compile.eval_ref", eval_ref) Predicate.map thy t' []) end;
  2.2368 +
  2.2369 +fun values ctxt k t_compr =
  2.2370 +  let
  2.2371 +    val thy = ProofContext.theory_of ctxt;
  2.2372 +    val (T, t) = eval thy t_compr;
  2.2373 +    val setT = HOLogic.mk_setT T;
  2.2374 +    val (ts, _) = Predicate.yieldn k t;
  2.2375 +    val elemsT = HOLogic.mk_set T ts;
  2.2376 +  in if k = ~1 orelse length ts < k then elemsT
  2.2377 +    else Const (@{const_name Set.union}, setT --> setT --> setT) $ elemsT $ t_compr
  2.2378 +  end;
  2.2379 +
  2.2380 +fun values_cmd modes k raw_t state =
  2.2381 +  let
  2.2382 +    val ctxt = Toplevel.context_of state;
  2.2383 +    val t = Syntax.read_term ctxt raw_t;
  2.2384 +    val t' = values ctxt k t;
  2.2385 +    val ty' = Term.type_of t';
  2.2386 +    val ctxt' = Variable.auto_fixes t' ctxt;
  2.2387 +    val p = PrintMode.with_modes modes (fn () =>
  2.2388 +      Pretty.block [Pretty.quote (Syntax.pretty_term ctxt' t'), Pretty.fbrk,
  2.2389 +        Pretty.str "::", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt' ty')]) ();
  2.2390 +  in Pretty.writeln p end;
  2.2391 +
  2.2392 +local structure P = OuterParse in
  2.2393 +
  2.2394 +val opt_modes = Scan.optional (P.$$$ "(" |-- P.!!! (Scan.repeat1 P.xname --| P.$$$ ")")) [];
  2.2395 +
  2.2396 +val _ = OuterSyntax.improper_command "values" "enumerate and print comprehensions" OuterKeyword.diag
  2.2397 +  (opt_modes -- Scan.optional P.nat ~1 -- P.term
  2.2398 +    >> (fn ((modes, k), t) => Toplevel.no_timing o Toplevel.keep
  2.2399 +        (values_cmd modes k t)));
  2.2400 +
  2.2401 +end;
  2.2402 +
  2.2403 +end;
     3.1 --- a/src/HOL/ex/Predicate_Compile.thy	Wed Sep 23 16:20:12 2009 +0200
     3.2 +++ b/src/HOL/ex/Predicate_Compile.thy	Wed Sep 23 16:20:12 2009 +0200
     3.3 @@ -1,6 +1,6 @@
     3.4  theory Predicate_Compile
     3.5  imports Complex_Main RPred
     3.6 -uses "predicate_compile.ML"
     3.7 +uses "../Tools/Predicate_Compile/predicate_compile_core.ML"
     3.8  begin
     3.9  
    3.10  setup {* Predicate_Compile.setup *}
     4.1 --- a/src/HOL/ex/predicate_compile.ML	Wed Sep 23 16:20:12 2009 +0200
     4.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.3 @@ -1,2399 +0,0 @@
     4.4 -(* Author: Lukas Bulwahn, TU Muenchen
     4.5 -
     4.6 -(Prototype of) A compiler from predicates specified by intro/elim rules
     4.7 -to equations.
     4.8 -*)
     4.9 -
    4.10 -signature PREDICATE_COMPILE =
    4.11 -sig
    4.12 -  type smode = (int * int list option) list
    4.13 -  type mode = smode option list * smode
    4.14 -  datatype tmode = Mode of mode * smode * tmode option list;
    4.15 -  (*val add_equations_of: bool -> string list -> theory -> theory *)
    4.16 -  val register_predicate : (thm list * thm * int) -> theory -> theory
    4.17 -  val is_registered : theory -> string -> bool
    4.18 - (* val fetch_pred_data : theory -> string -> (thm list * thm * int)  *)
    4.19 -  val predfun_intro_of: theory -> string -> mode -> thm
    4.20 -  val predfun_elim_of: theory -> string -> mode -> thm
    4.21 -  val strip_intro_concl: int -> term -> term * (term list * term list)
    4.22 -  val predfun_name_of: theory -> string -> mode -> string
    4.23 -  val all_preds_of : theory -> string list
    4.24 -  val modes_of: theory -> string -> mode list
    4.25 -  val string_of_mode : mode -> string
    4.26 -  val intros_of: theory -> string -> thm list
    4.27 -  val nparams_of: theory -> string -> int
    4.28 -  val add_intro: thm -> theory -> theory
    4.29 -  val set_elim: thm -> theory -> theory
    4.30 -  val setup: theory -> theory
    4.31 -  val code_pred: string -> Proof.context -> Proof.state
    4.32 -  val code_pred_cmd: string -> Proof.context -> Proof.state
    4.33 -  val print_stored_rules: theory -> unit
    4.34 -  val print_all_modes: theory -> unit
    4.35 -  val do_proofs: bool ref
    4.36 -  val mk_casesrule : Proof.context -> int -> thm list -> term
    4.37 -  val analyze_compr: theory -> term -> term
    4.38 -  val eval_ref: (unit -> term Predicate.pred) option ref
    4.39 -  val add_equations : string list -> theory -> theory
    4.40 -  val code_pred_intros_attrib : attribute
    4.41 -  (* used by Quickcheck_Generator *) 
    4.42 -  (*val funT_of : mode -> typ -> typ
    4.43 -  val mk_if_pred : term -> term
    4.44 -  val mk_Eval : term * term -> term*)
    4.45 -  val mk_tupleT : typ list -> typ
    4.46 -(*  val mk_predT :  typ -> typ *)
    4.47 -  (* temporary for testing of the compilation *)
    4.48 -  datatype indprem = Prem of term list * term | Negprem of term list * term | Sidecond of term |
    4.49 -    GeneratorPrem of term list * term | Generator of (string * typ);
    4.50 - (* val prepare_intrs: theory -> string list ->
    4.51 -    (string * typ) list * int * string list * string list * (string * mode list) list *
    4.52 -    (string * (term list * indprem list) list) list * (string * (int option list * int)) list*)
    4.53 -  datatype compilation_funs = CompilationFuns of {
    4.54 -    mk_predT : typ -> typ,
    4.55 -    dest_predT : typ -> typ,
    4.56 -    mk_bot : typ -> term,
    4.57 -    mk_single : term -> term,
    4.58 -    mk_bind : term * term -> term,
    4.59 -    mk_sup : term * term -> term,
    4.60 -    mk_if : term -> term,
    4.61 -    mk_not : term -> term,
    4.62 -    mk_map : typ -> typ -> term -> term -> term,
    4.63 -    lift_pred : term -> term
    4.64 -  };  
    4.65 -  type moded_clause = term list * (indprem * tmode) list
    4.66 -  type 'a pred_mode_table = (string * (mode * 'a) list) list
    4.67 -  val infer_modes : theory -> (string * mode list) list
    4.68 -    -> (string * mode list) list
    4.69 -    -> string list
    4.70 -    -> (string * (term list * indprem list) list) list
    4.71 -    -> (moded_clause list) pred_mode_table
    4.72 -  val infer_modes_with_generator : theory -> (string * mode list) list
    4.73 -    -> (string * mode list) list
    4.74 -    -> string list
    4.75 -    -> (string * (term list * indprem list) list) list
    4.76 -    -> (moded_clause list) pred_mode_table  
    4.77 -  (*val compile_preds : theory -> compilation_funs -> string list -> string list
    4.78 -    -> (string * typ) list -> (moded_clause list) pred_mode_table -> term pred_mode_table
    4.79 -  val rpred_create_definitions :(string * typ) list -> string * mode list
    4.80 -    -> theory -> theory 
    4.81 -  val split_smode : int list -> term list -> (term list * term list) *)
    4.82 -  val print_moded_clauses :
    4.83 -    theory -> (moded_clause list) pred_mode_table -> unit
    4.84 -  val print_compiled_terms : theory -> term pred_mode_table -> unit
    4.85 -  (*val rpred_prove_preds : theory -> term pred_mode_table -> thm pred_mode_table*)
    4.86 -  val rpred_compfuns : compilation_funs
    4.87 -  val dest_funT : typ -> typ * typ
    4.88 - (* val depending_preds_of : theory -> thm list -> string list *)
    4.89 -  val add_quickcheck_equations : string list -> theory -> theory
    4.90 -  val add_sizelim_equations : string list -> theory -> theory
    4.91 -  val is_inductive_predicate : theory -> string -> bool
    4.92 -  val terms_vs : term list -> string list
    4.93 -  val subsets : int -> int -> int list list
    4.94 -  val check_mode_clause : bool -> theory -> string list ->
    4.95 -    (string * mode list) list -> (string * mode list) list -> mode -> (term list * indprem list)
    4.96 -      -> (term list * (indprem * tmode) list) option
    4.97 -  val string_of_moded_prem : theory -> (indprem * tmode) -> string
    4.98 -  val all_modes_of : theory -> (string * mode list) list
    4.99 -  val all_generator_modes_of : theory -> (string * mode list) list
   4.100 -  val compile_clause : compilation_funs -> term option -> (term list -> term) ->
   4.101 -    theory -> string list -> string list -> mode -> term -> moded_clause -> term
   4.102 -  val preprocess_intro : theory -> thm -> thm
   4.103 -  val is_constrt : theory -> term -> bool
   4.104 -  val is_predT : typ -> bool
   4.105 -  val guess_nparams : typ -> int
   4.106 -  val cprods_subset : 'a list list -> 'a list list
   4.107 -end;
   4.108 -
   4.109 -structure Predicate_Compile : PREDICATE_COMPILE =
   4.110 -struct
   4.111 -
   4.112 -(** auxiliary **)
   4.113 -
   4.114 -(* debug stuff *)
   4.115 -
   4.116 -fun tracing s = (if ! Toplevel.debug then Output.tracing s else ());
   4.117 -
   4.118 -fun print_tac s = Seq.single; (*Tactical.print_tac s;*) (* (if ! Toplevel.debug then Tactical.print_tac s else Seq.single); *)
   4.119 -fun debug_tac msg = Seq.single; (* (fn st => (Output.tracing msg; Seq.single st)); *)
   4.120 -
   4.121 -val do_proofs = ref true;
   4.122 -
   4.123 -fun mycheat_tac thy i st =
   4.124 -  (Tactic.rtac (SkipProof.make_thm thy (Var (("A", 0), propT))) i) st
   4.125 -
   4.126 -fun remove_last_goal thy st =
   4.127 -  (Tactic.rtac (SkipProof.make_thm thy (Var (("A", 0), propT))) (nprems_of st)) st
   4.128 -
   4.129 -(* reference to preprocessing of InductiveSet package *)
   4.130 -
   4.131 -val ind_set_codegen_preproc = Inductive_Set.codegen_preproc;
   4.132 -
   4.133 -(** fundamentals **)
   4.134 -
   4.135 -(* syntactic operations *)
   4.136 -
   4.137 -fun mk_eq (x, xs) =
   4.138 -  let fun mk_eqs _ [] = []
   4.139 -        | mk_eqs a (b::cs) =
   4.140 -            HOLogic.mk_eq (Free (a, fastype_of b), b) :: mk_eqs a cs
   4.141 -  in mk_eqs x xs end;
   4.142 -
   4.143 -fun mk_tupleT [] = HOLogic.unitT
   4.144 -  | mk_tupleT Ts = foldr1 HOLogic.mk_prodT Ts;
   4.145 -
   4.146 -fun dest_tupleT (Type (@{type_name Product_Type.unit}, [])) = []
   4.147 -  | dest_tupleT (Type (@{type_name "*"}, [T1, T2])) = T1 :: (dest_tupleT T2)
   4.148 -  | dest_tupleT t = [t]
   4.149 -
   4.150 -fun mk_tuple [] = HOLogic.unit
   4.151 -  | mk_tuple ts = foldr1 HOLogic.mk_prod ts;
   4.152 -
   4.153 -fun dest_tuple (Const (@{const_name Product_Type.Unity}, _)) = []
   4.154 -  | dest_tuple (Const (@{const_name Pair}, _) $ t1 $ t2) = t1 :: (dest_tuple t2)
   4.155 -  | dest_tuple t = [t]
   4.156 -
   4.157 -fun mk_scomp (t, u) =
   4.158 -  let
   4.159 -    val T = fastype_of t
   4.160 -    val U = fastype_of u
   4.161 -    val [A] = binder_types T
   4.162 -    val D = body_type U 
   4.163 -  in 
   4.164 -    Const (@{const_name "scomp"}, T --> U --> A --> D) $ t $ u
   4.165 -  end;
   4.166 -
   4.167 -fun dest_funT (Type ("fun",[S, T])) = (S, T)
   4.168 -  | dest_funT T = raise TYPE ("dest_funT", [T], [])
   4.169 - 
   4.170 -fun mk_fun_comp (t, u) =
   4.171 -  let
   4.172 -    val (_, B) = dest_funT (fastype_of t)
   4.173 -    val (C, A) = dest_funT (fastype_of u)
   4.174 -  in
   4.175 -    Const(@{const_name "Fun.comp"}, (A --> B) --> (C --> A) --> C --> B) $ t $ u
   4.176 -  end;
   4.177 -
   4.178 -fun dest_randomT (Type ("fun", [@{typ Random.seed},
   4.179 -  Type ("*", [Type ("*", [T, @{typ "unit => Code_Eval.term"}]) ,@{typ Random.seed}])])) = T
   4.180 -  | dest_randomT T = raise TYPE ("dest_randomT", [T], [])
   4.181 -
   4.182 -(* destruction of intro rules *)
   4.183 -
   4.184 -(* FIXME: look for other place where this functionality was used before *)
   4.185 -fun strip_intro_concl nparams intro = let
   4.186 -  val _ $ u = Logic.strip_imp_concl intro
   4.187 -  val (pred, all_args) = strip_comb u
   4.188 -  val (params, args) = chop nparams all_args
   4.189 -in (pred, (params, args)) end
   4.190 -
   4.191 -(** data structures **)
   4.192 -
   4.193 -type smode = (int * int list option) list;
   4.194 -type mode = smode option list * smode;
   4.195 -datatype tmode = Mode of mode * smode * tmode option list;
   4.196 -
   4.197 -fun gen_split_smode (mk_tuple, strip_tuple) smode ts =
   4.198 -  let
   4.199 -    fun split_tuple' _ _ [] = ([], [])
   4.200 -    | split_tuple' is i (t::ts) =
   4.201 -      (if i mem is then apfst else apsnd) (cons t)
   4.202 -        (split_tuple' is (i+1) ts)
   4.203 -    fun split_tuple is t = split_tuple' is 1 (strip_tuple t)
   4.204 -    fun split_smode' _ _ [] = ([], [])
   4.205 -      | split_smode' smode i (t::ts) =
   4.206 -        (if i mem (map fst smode) then
   4.207 -          case (the (AList.lookup (op =) smode i)) of
   4.208 -            NONE => apfst (cons t)
   4.209 -            | SOME is =>
   4.210 -              let
   4.211 -                val (ts1, ts2) = split_tuple is t
   4.212 -                fun cons_tuple ts = if null ts then I else cons (mk_tuple ts)
   4.213 -                in (apfst (cons_tuple ts1)) o (apsnd (cons_tuple ts2)) end
   4.214 -          else apsnd (cons t))
   4.215 -        (split_smode' smode (i+1) ts)
   4.216 -  in split_smode' smode 1 ts end
   4.217 -
   4.218 -val split_smode = gen_split_smode (HOLogic.mk_tuple, HOLogic.strip_tuple)   
   4.219 -val split_smodeT = gen_split_smode (HOLogic.mk_tupleT, HOLogic.strip_tupleT)
   4.220 -
   4.221 -fun gen_split_mode split_smode (iss, is) ts =
   4.222 -  let
   4.223 -    val (t1, t2) = chop (length iss) ts 
   4.224 -  in (t1, split_smode is t2) end
   4.225 -
   4.226 -val split_mode = gen_split_mode split_smode
   4.227 -val split_modeT = gen_split_mode split_smodeT
   4.228 -
   4.229 -fun string_of_smode js =
   4.230 -    commas (map
   4.231 -      (fn (i, is) =>
   4.232 -        string_of_int i ^ (case is of NONE => ""
   4.233 -    | SOME is => "p" ^ enclose "[" "]" (commas (map string_of_int is)))) js)
   4.234 -
   4.235 -fun string_of_mode (iss, is) = space_implode " -> " (map
   4.236 -  (fn NONE => "X"
   4.237 -    | SOME js => enclose "[" "]" (string_of_smode js))
   4.238 -       (iss @ [SOME is]));
   4.239 -
   4.240 -fun string_of_tmode (Mode (predmode, termmode, param_modes)) =
   4.241 -  "predmode: " ^ (string_of_mode predmode) ^ 
   4.242 -  (if null param_modes then "" else
   4.243 -    "; " ^ "params: " ^ commas (map (the_default "NONE" o Option.map string_of_tmode) param_modes))
   4.244 -    
   4.245 -datatype indprem = Prem of term list * term | Negprem of term list * term | Sidecond of term |
   4.246 -  GeneratorPrem of term list * term | Generator of (string * typ);
   4.247 -
   4.248 -type moded_clause = term list * (indprem * tmode) list
   4.249 -type 'a pred_mode_table = (string * (mode * 'a) list) list
   4.250 -
   4.251 -datatype predfun_data = PredfunData of {
   4.252 -  name : string,
   4.253 -  definition : thm,
   4.254 -  intro : thm,
   4.255 -  elim : thm
   4.256 -};
   4.257 -
   4.258 -fun rep_predfun_data (PredfunData data) = data;
   4.259 -fun mk_predfun_data (name, definition, intro, elim) =
   4.260 -  PredfunData {name = name, definition = definition, intro = intro, elim = elim}
   4.261 -
   4.262 -datatype function_data = FunctionData of {
   4.263 -  name : string,
   4.264 -  equation : thm option (* is not used at all? *)
   4.265 -};
   4.266 -
   4.267 -fun rep_function_data (FunctionData data) = data;
   4.268 -fun mk_function_data (name, equation) =
   4.269 -  FunctionData {name = name, equation = equation}
   4.270 -
   4.271 -datatype pred_data = PredData of {
   4.272 -  intros : thm list,
   4.273 -  elim : thm option,
   4.274 -  nparams : int,
   4.275 -  functions : (mode * predfun_data) list,
   4.276 -  generators : (mode * function_data) list,
   4.277 -  sizelim_functions : (mode * function_data) list 
   4.278 -};
   4.279 -
   4.280 -fun rep_pred_data (PredData data) = data;
   4.281 -fun mk_pred_data ((intros, elim, nparams), (functions, generators, sizelim_functions)) =
   4.282 -  PredData {intros = intros, elim = elim, nparams = nparams,
   4.283 -    functions = functions, generators = generators, sizelim_functions = sizelim_functions}
   4.284 -fun map_pred_data f (PredData {intros, elim, nparams, functions, generators, sizelim_functions}) =
   4.285 -  mk_pred_data (f ((intros, elim, nparams), (functions, generators, sizelim_functions)))
   4.286 -  
   4.287 -fun eq_option eq (NONE, NONE) = true
   4.288 -  | eq_option eq (SOME x, SOME y) = eq (x, y)
   4.289 -  | eq_option eq _ = false
   4.290 -  
   4.291 -fun eq_pred_data (PredData d1, PredData d2) = 
   4.292 -  eq_list (Thm.eq_thm) (#intros d1, #intros d2) andalso
   4.293 -  eq_option (Thm.eq_thm) (#elim d1, #elim d2) andalso
   4.294 -  #nparams d1 = #nparams d2
   4.295 -  
   4.296 -structure PredData = TheoryDataFun
   4.297 -(
   4.298 -  type T = pred_data Graph.T;
   4.299 -  val empty = Graph.empty;
   4.300 -  val copy = I;
   4.301 -  val extend = I;
   4.302 -  fun merge _ = Graph.merge eq_pred_data;
   4.303 -);
   4.304 -
   4.305 -(* queries *)
   4.306 -
   4.307 -fun lookup_pred_data thy name =
   4.308 -  Option.map rep_pred_data (try (Graph.get_node (PredData.get thy)) name)
   4.309 -
   4.310 -fun the_pred_data thy name = case lookup_pred_data thy name
   4.311 - of NONE => error ("No such predicate " ^ quote name)  
   4.312 -  | SOME data => data;
   4.313 -
   4.314 -val is_registered = is_some oo lookup_pred_data 
   4.315 -
   4.316 -val all_preds_of = Graph.keys o PredData.get
   4.317 -
   4.318 -fun intros_of thy = map (Thm.transfer thy) o #intros o the_pred_data thy
   4.319 -
   4.320 -fun the_elim_of thy name = case #elim (the_pred_data thy name)
   4.321 - of NONE => error ("No elimination rule for predicate " ^ quote name)
   4.322 -  | SOME thm => Thm.transfer thy thm 
   4.323 -  
   4.324 -val has_elim = is_some o #elim oo the_pred_data;
   4.325 -
   4.326 -val nparams_of = #nparams oo the_pred_data
   4.327 -
   4.328 -val modes_of = (map fst) o #functions oo the_pred_data
   4.329 -
   4.330 -fun all_modes_of thy = map (fn name => (name, modes_of thy name)) (all_preds_of thy) 
   4.331 -
   4.332 -val is_compiled = not o null o #functions oo the_pred_data
   4.333 -
   4.334 -fun lookup_predfun_data thy name mode =
   4.335 -  Option.map rep_predfun_data (AList.lookup (op =)
   4.336 -  (#functions (the_pred_data thy name)) mode)
   4.337 -
   4.338 -fun the_predfun_data thy name mode = case lookup_predfun_data thy name mode
   4.339 -  of NONE => error ("No function defined for mode " ^ string_of_mode mode ^ " of predicate " ^ name)
   4.340 -   | SOME data => data;
   4.341 -
   4.342 -val predfun_name_of = #name ooo the_predfun_data
   4.343 -
   4.344 -val predfun_definition_of = #definition ooo the_predfun_data
   4.345 -
   4.346 -val predfun_intro_of = #intro ooo the_predfun_data
   4.347 -
   4.348 -val predfun_elim_of = #elim ooo the_predfun_data
   4.349 -
   4.350 -fun lookup_generator_data thy name mode = 
   4.351 -  Option.map rep_function_data (AList.lookup (op =)
   4.352 -  (#generators (the_pred_data thy name)) mode)
   4.353 -  
   4.354 -fun the_generator_data thy name mode = case lookup_generator_data thy name mode
   4.355 -  of NONE => error ("No generator defined for mode " ^ string_of_mode mode ^ " of predicate " ^ name)
   4.356 -   | SOME data => data
   4.357 -
   4.358 -val generator_name_of = #name ooo the_generator_data
   4.359 -
   4.360 -val generator_modes_of = (map fst) o #generators oo the_pred_data
   4.361 -
   4.362 -fun all_generator_modes_of thy =
   4.363 -  map (fn name => (name, generator_modes_of thy name)) (all_preds_of thy) 
   4.364 -
   4.365 -fun lookup_sizelim_function_data thy name mode =
   4.366 -  Option.map rep_function_data (AList.lookup (op =)
   4.367 -  (#sizelim_functions (the_pred_data thy name)) mode)
   4.368 -
   4.369 -fun the_sizelim_function_data thy name mode = case lookup_sizelim_function_data thy name mode
   4.370 -  of NONE => error ("No size-limited function defined for mode " ^ string_of_mode mode
   4.371 -    ^ " of predicate " ^ name)
   4.372 -   | SOME data => data
   4.373 -
   4.374 -val sizelim_function_name_of = #name ooo the_sizelim_function_data
   4.375 -
   4.376 -(*val generator_modes_of = (map fst) o #generators oo the_pred_data*)
   4.377 -     
   4.378 -(* diagnostic display functions *)
   4.379 -
   4.380 -fun print_modes modes = Output.tracing ("Inferred modes:\n" ^
   4.381 -  cat_lines (map (fn (s, ms) => s ^ ": " ^ commas (map
   4.382 -    string_of_mode ms)) modes));
   4.383 -
   4.384 -fun print_pred_mode_table string_of_entry thy pred_mode_table =
   4.385 -  let
   4.386 -    fun print_mode pred (mode, entry) =  "mode : " ^ (string_of_mode mode)
   4.387 -      ^ (string_of_entry pred mode entry)  
   4.388 -    fun print_pred (pred, modes) =
   4.389 -      "predicate " ^ pred ^ ": " ^ cat_lines (map (print_mode pred) modes)
   4.390 -    val _ = Output.tracing (cat_lines (map print_pred pred_mode_table))
   4.391 -  in () end;
   4.392 -
   4.393 -fun string_of_moded_prem thy (Prem (ts, p), tmode) =
   4.394 -    (Syntax.string_of_term_global thy (list_comb (p, ts))) ^
   4.395 -    "(" ^ (string_of_tmode tmode) ^ ")"
   4.396 -  | string_of_moded_prem thy (GeneratorPrem (ts, p), Mode (predmode, is, _)) =
   4.397 -    (Syntax.string_of_term_global thy (list_comb (p, ts))) ^
   4.398 -    "(generator_mode: " ^ (string_of_mode predmode) ^ ")"
   4.399 -  | string_of_moded_prem thy (Generator (v, T), _) =
   4.400 -    "Generator for " ^ v ^ " of Type " ^ (Syntax.string_of_typ_global thy T)
   4.401 -  | string_of_moded_prem thy (Negprem (ts, p), Mode (_, is, _)) =
   4.402 -    (Syntax.string_of_term_global thy (list_comb (p, ts))) ^
   4.403 -    "(negative mode: " ^ string_of_smode is ^ ")"
   4.404 -  | string_of_moded_prem thy (Sidecond t, Mode (_, is, _)) =
   4.405 -    (Syntax.string_of_term_global thy t) ^
   4.406 -    "(sidecond mode: " ^ string_of_smode is ^ ")"    
   4.407 -  | string_of_moded_prem _ _ = error "string_of_moded_prem: unimplemented"
   4.408 -     
   4.409 -fun print_moded_clauses thy =
   4.410 -  let        
   4.411 -    fun string_of_clause pred mode clauses =
   4.412 -      cat_lines (map (fn (ts, prems) => (space_implode " --> "
   4.413 -        (map (string_of_moded_prem thy) prems)) ^ " --> " ^ pred ^ " "
   4.414 -        ^ (space_implode " " (map (Syntax.string_of_term_global thy) ts))) clauses)
   4.415 -  in print_pred_mode_table string_of_clause thy end;
   4.416 -
   4.417 -fun print_compiled_terms thy =
   4.418 -  print_pred_mode_table (fn _ => fn _ => Syntax.string_of_term_global thy) thy
   4.419 -    
   4.420 -fun print_stored_rules thy =
   4.421 -  let
   4.422 -    val preds = (Graph.keys o PredData.get) thy
   4.423 -    fun print pred () = let
   4.424 -      val _ = writeln ("predicate: " ^ pred)
   4.425 -      val _ = writeln ("number of parameters: " ^ string_of_int (nparams_of thy pred))
   4.426 -      val _ = writeln ("introrules: ")
   4.427 -      val _ = fold (fn thm => fn u => writeln (Display.string_of_thm_global thy thm))
   4.428 -        (rev (intros_of thy pred)) ()
   4.429 -    in
   4.430 -      if (has_elim thy pred) then
   4.431 -        writeln ("elimrule: " ^ Display.string_of_thm_global thy (the_elim_of thy pred))
   4.432 -      else
   4.433 -        writeln ("no elimrule defined")
   4.434 -    end
   4.435 -  in
   4.436 -    fold print preds ()
   4.437 -  end;
   4.438 -
   4.439 -fun print_all_modes thy =
   4.440 -  let
   4.441 -    val _ = writeln ("Inferred modes:")
   4.442 -    fun print (pred, modes) u =
   4.443 -      let
   4.444 -        val _ = writeln ("predicate: " ^ pred)
   4.445 -        val _ = writeln ("modes: " ^ (commas (map string_of_mode modes)))
   4.446 -      in u end  
   4.447 -  in
   4.448 -    fold print (all_modes_of thy) ()
   4.449 -  end
   4.450 -  
   4.451 -(** preprocessing rules **)  
   4.452 -
   4.453 -fun imp_prems_conv cv ct =
   4.454 -  case Thm.term_of ct of
   4.455 -    Const ("==>", _) $ _ $ _ => Conv.combination_conv (Conv.arg_conv cv) (imp_prems_conv cv) ct
   4.456 -  | _ => Conv.all_conv ct
   4.457 -
   4.458 -fun Trueprop_conv cv ct =
   4.459 -  case Thm.term_of ct of
   4.460 -    Const ("Trueprop", _) $ _ => Conv.arg_conv cv ct  
   4.461 -  | _ => error "Trueprop_conv"
   4.462 -
   4.463 -fun preprocess_intro thy rule =
   4.464 -  Conv.fconv_rule
   4.465 -    (imp_prems_conv
   4.466 -      (Trueprop_conv (Conv.try_conv (Conv.rewr_conv (Thm.symmetric @{thm Predicate.eq_is_eq})))))
   4.467 -    (Thm.transfer thy rule)
   4.468 -
   4.469 -fun preprocess_elim thy nparams elimrule =
   4.470 -  let
   4.471 -    val _ = Output.tracing ("Preprocessing elimination rule "
   4.472 -      ^ (Display.string_of_thm_global thy elimrule))
   4.473 -    fun replace_eqs (Const ("Trueprop", _) $ (Const ("op =", T) $ lhs $ rhs)) =
   4.474 -       HOLogic.mk_Trueprop (Const (@{const_name Predicate.eq}, T) $ lhs $ rhs)
   4.475 -     | replace_eqs t = t
   4.476 -    val prems = Thm.prems_of elimrule
   4.477 -    val nargs = length (snd (strip_comb (HOLogic.dest_Trueprop (hd prems)))) - nparams
   4.478 -    fun preprocess_case t =
   4.479 -     let
   4.480 -       val params = Logic.strip_params t
   4.481 -       val (assums1, assums2) = chop nargs (Logic.strip_assums_hyp t)
   4.482 -       val assums_hyp' = assums1 @ (map replace_eqs assums2)
   4.483 -     in
   4.484 -       list_all (params, Logic.list_implies (assums_hyp', Logic.strip_assums_concl t))
   4.485 -     end 
   4.486 -    val cases' = map preprocess_case (tl prems)
   4.487 -    val elimrule' = Logic.list_implies ((hd prems) :: cases', Thm.concl_of elimrule)
   4.488 -    (*
   4.489 -    (*val _ =  Output.tracing ("elimrule': "^ (Syntax.string_of_term_global thy elimrule'))*)
   4.490 -    val bigeq = (Thm.symmetric (Conv.implies_concl_conv (MetaSimplifier.rewrite true [@{thm Predicate.eq_is_eq}])
   4.491 -         (cterm_of thy elimrule')))
   4.492 -    val _ = Output.tracing ("bigeq:" ^ (Display.string_of_thm_global thy bigeq))   
   4.493 -    val res = 
   4.494 -    Thm.equal_elim bigeq
   4.495 -      
   4.496 -      elimrule
   4.497 -    *)
   4.498 -    val t = (fn {...} => mycheat_tac thy 1)
   4.499 -    val eq = Goal.prove (ProofContext.init thy) [] [] (Logic.mk_equals ((Thm.prop_of elimrule), elimrule')) t
   4.500 -    val _ = Output.tracing "Preprocessed elimination rule"
   4.501 -  in
   4.502 -    Thm.equal_elim eq elimrule
   4.503 -  end;
   4.504 -
   4.505 -(* special case: predicate with no introduction rule *)
   4.506 -fun noclause thy predname elim = let
   4.507 -  val T = (Logic.unvarifyT o Sign.the_const_type thy) predname
   4.508 -  val Ts = binder_types T
   4.509 -  val names = Name.variant_list []
   4.510 -        (map (fn i => "x" ^ (string_of_int i)) (1 upto (length Ts)))
   4.511 -  val vs = map2 (curry Free) names Ts
   4.512 -  val clausehd = HOLogic.mk_Trueprop (list_comb (Const (predname, T), vs))
   4.513 -  val intro_t = Logic.mk_implies (@{prop False}, clausehd)
   4.514 -  val P = HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT))
   4.515 -  val elim_t = Logic.list_implies ([clausehd, Logic.mk_implies (@{prop False}, P)], P)
   4.516 -  val intro = Goal.prove (ProofContext.init thy) names [] intro_t
   4.517 -        (fn {...} => etac @{thm FalseE} 1)
   4.518 -  val elim = Goal.prove (ProofContext.init thy) ("P" :: names) [] elim_t
   4.519 -        (fn {...} => etac elim 1) 
   4.520 -in
   4.521 -  ([intro], elim)
   4.522 -end
   4.523 -
   4.524 -fun fetch_pred_data thy name =
   4.525 -  case try (Inductive.the_inductive (ProofContext.init thy)) name of
   4.526 -    SOME (info as (_, result)) => 
   4.527 -      let
   4.528 -        fun is_intro_of intro =
   4.529 -          let
   4.530 -            val (const, _) = strip_comb (HOLogic.dest_Trueprop (concl_of intro))
   4.531 -          in (fst (dest_Const const) = name) end;      
   4.532 -        val intros = ind_set_codegen_preproc thy ((map (preprocess_intro thy))
   4.533 -          (filter is_intro_of (#intrs result)))
   4.534 -        val pre_elim = nth (#elims result) (find_index (fn s => s = name) (#names (fst info)))
   4.535 -        val nparams = length (Inductive.params_of (#raw_induct result))
   4.536 -        val elim = singleton (ind_set_codegen_preproc thy) (preprocess_elim thy nparams pre_elim)
   4.537 -        val (intros, elim) = if null intros then noclause thy name elim else (intros, elim)
   4.538 -      in
   4.539 -        mk_pred_data ((intros, SOME elim, nparams), ([], [], []))
   4.540 -      end                                                                    
   4.541 -  | NONE => error ("No such predicate: " ^ quote name)
   4.542 -  
   4.543 -(* updaters *)
   4.544 -
   4.545 -fun apfst3 f (x, y, z) =  (f x, y, z)
   4.546 -fun apsnd3 f (x, y, z) =  (x, f y, z)
   4.547 -fun aptrd3 f (x, y, z) =  (x, y, f z)
   4.548 -
   4.549 -fun add_predfun name mode data =
   4.550 -  let
   4.551 -    val add = (apsnd o apfst3 o cons) (mode, mk_predfun_data data)
   4.552 -  in PredData.map (Graph.map_node name (map_pred_data add)) end
   4.553 -
   4.554 -fun is_inductive_predicate thy name =
   4.555 -  is_some (try (Inductive.the_inductive (ProofContext.init thy)) name)
   4.556 -
   4.557 -fun depending_preds_of thy (key, value) =
   4.558 -  let
   4.559 -    val intros = (#intros o rep_pred_data) value
   4.560 -  in
   4.561 -    fold Term.add_const_names (map Thm.prop_of intros) []
   4.562 -      |> filter (fn c => (not (c = key)) andalso (is_inductive_predicate thy c orelse is_registered thy c))
   4.563 -  end;
   4.564 -    
   4.565 -    
   4.566 -(* code dependency graph *)    
   4.567 -(*
   4.568 -fun dependencies_of thy name =
   4.569 -  let
   4.570 -    val (intros, elim, nparams) = fetch_pred_data thy name 
   4.571 -    val data = mk_pred_data ((intros, SOME elim, nparams), ([], [], []))
   4.572 -    val keys = depending_preds_of thy intros
   4.573 -  in
   4.574 -    (data, keys)
   4.575 -  end;
   4.576 -*)
   4.577 -(* guessing number of parameters *)
   4.578 -fun find_indexes pred xs =
   4.579 -  let
   4.580 -    fun find is n [] = is
   4.581 -      | find is n (x :: xs) = find (if pred x then (n :: is) else is) (n + 1) xs;
   4.582 -  in rev (find [] 0 xs) end;
   4.583 -
   4.584 -fun is_predT (T as Type("fun", [_, _])) = (snd (strip_type T) = HOLogic.boolT)
   4.585 -  | is_predT _ = false
   4.586 -  
   4.587 -fun guess_nparams T =
   4.588 -  let
   4.589 -    val argTs = binder_types T
   4.590 -    val nparams = fold (curry Int.max)
   4.591 -      (map (fn x => x + 1) (find_indexes is_predT argTs)) 0
   4.592 -  in nparams end;
   4.593 -
   4.594 -fun add_intro thm thy = let
   4.595 -   val (name, T) = dest_Const (fst (strip_intro_concl 0 (prop_of thm)))
   4.596 -   fun cons_intro gr =
   4.597 -     case try (Graph.get_node gr) name of
   4.598 -       SOME pred_data => Graph.map_node name (map_pred_data
   4.599 -         (apfst (fn (intro, elim, nparams) => (thm::intro, elim, nparams)))) gr
   4.600 -     | NONE =>
   4.601 -       let
   4.602 -         val nparams = the_default (guess_nparams T)  (try (#nparams o rep_pred_data o (fetch_pred_data thy)) name)
   4.603 -       in Graph.new_node (name, mk_pred_data (([thm], NONE, nparams), ([], [], []))) gr end;
   4.604 -  in PredData.map cons_intro thy end
   4.605 -
   4.606 -fun set_elim thm = let
   4.607 -    val (name, _) = dest_Const (fst 
   4.608 -      (strip_comb (HOLogic.dest_Trueprop (hd (prems_of thm)))))
   4.609 -    fun set (intros, _, nparams) = (intros, SOME thm, nparams)  
   4.610 -  in PredData.map (Graph.map_node name (map_pred_data (apfst set))) end
   4.611 -
   4.612 -fun set_nparams name nparams = let
   4.613 -    fun set (intros, elim, _ ) = (intros, elim, nparams) 
   4.614 -  in PredData.map (Graph.map_node name (map_pred_data (apfst set))) end
   4.615 -    
   4.616 -fun register_predicate (pre_intros, pre_elim, nparams) thy = let
   4.617 -    val (name, _) = dest_Const (fst (strip_intro_concl nparams (prop_of (hd pre_intros))))
   4.618 -    (* preprocessing *)
   4.619 -    val intros = ind_set_codegen_preproc thy (map (preprocess_intro thy) pre_intros)
   4.620 -    val elim = singleton (ind_set_codegen_preproc thy) (preprocess_elim thy nparams pre_elim)
   4.621 -  in
   4.622 -    PredData.map
   4.623 -      (Graph.new_node (name, mk_pred_data ((intros, SOME elim, nparams), ([], [], [])))) thy
   4.624 -  end
   4.625 -
   4.626 -fun set_generator_name pred mode name = 
   4.627 -  let
   4.628 -    val set = (apsnd o apsnd3 o cons) (mode, mk_function_data (name, NONE))
   4.629 -  in
   4.630 -    PredData.map (Graph.map_node pred (map_pred_data set))
   4.631 -  end
   4.632 -
   4.633 -fun set_sizelim_function_name pred mode name = 
   4.634 -  let
   4.635 -    val set = (apsnd o aptrd3 o cons) (mode, mk_function_data (name, NONE))
   4.636 -  in
   4.637 -    PredData.map (Graph.map_node pred (map_pred_data set))
   4.638 -  end
   4.639 -
   4.640 -(** data structures for generic compilation for different monads **)
   4.641 -
   4.642 -(* maybe rename functions more generic:
   4.643 -  mk_predT -> mk_monadT; dest_predT -> dest_monadT
   4.644 -  mk_single -> mk_return (?)
   4.645 -*)
   4.646 -datatype compilation_funs = CompilationFuns of {
   4.647 -  mk_predT : typ -> typ,
   4.648 -  dest_predT : typ -> typ,
   4.649 -  mk_bot : typ -> term,
   4.650 -  mk_single : term -> term,
   4.651 -  mk_bind : term * term -> term,
   4.652 -  mk_sup : term * term -> term,
   4.653 -  mk_if : term -> term,
   4.654 -  mk_not : term -> term,
   4.655 -(*  funT_of : mode -> typ -> typ, *)
   4.656 -(*  mk_fun_of : theory -> (string * typ) -> mode -> term, *) 
   4.657 -  mk_map : typ -> typ -> term -> term -> term,
   4.658 -  lift_pred : term -> term
   4.659 -};
   4.660 -
   4.661 -fun mk_predT (CompilationFuns funs) = #mk_predT funs
   4.662 -fun dest_predT (CompilationFuns funs) = #dest_predT funs
   4.663 -fun mk_bot (CompilationFuns funs) = #mk_bot funs
   4.664 -fun mk_single (CompilationFuns funs) = #mk_single funs
   4.665 -fun mk_bind (CompilationFuns funs) = #mk_bind funs
   4.666 -fun mk_sup (CompilationFuns funs) = #mk_sup funs
   4.667 -fun mk_if (CompilationFuns funs) = #mk_if funs
   4.668 -fun mk_not (CompilationFuns funs) = #mk_not funs
   4.669 -(*fun funT_of (CompilationFuns funs) = #funT_of funs*)
   4.670 -(*fun mk_fun_of (CompilationFuns funs) = #mk_fun_of funs*)
   4.671 -fun mk_map (CompilationFuns funs) = #mk_map funs
   4.672 -fun lift_pred (CompilationFuns funs) = #lift_pred funs
   4.673 -
   4.674 -fun funT_of compfuns (iss, is) T =
   4.675 -  let
   4.676 -    val Ts = binder_types T
   4.677 -    val (paramTs, (inargTs, outargTs)) = split_modeT (iss, is) Ts
   4.678 -    val paramTs' = map2 (fn NONE => I | SOME is => funT_of compfuns ([], is)) iss paramTs
   4.679 -  in
   4.680 -    (paramTs' @ inargTs) ---> (mk_predT compfuns (mk_tupleT outargTs))
   4.681 -  end;
   4.682 -
   4.683 -fun sizelim_funT_of compfuns (iss, is) T =
   4.684 -  let
   4.685 -    val Ts = binder_types T
   4.686 -    val (paramTs, (inargTs, outargTs)) = split_modeT (iss, is) Ts
   4.687 -    val paramTs' = map2 (fn SOME is => sizelim_funT_of compfuns ([], is) | NONE => I) iss paramTs 
   4.688 -  in
   4.689 -    (paramTs' @ inargTs @ [@{typ "code_numeral"}]) ---> (mk_predT compfuns (mk_tupleT outargTs))
   4.690 -  end;  
   4.691 -
   4.692 -fun mk_fun_of compfuns thy (name, T) mode = 
   4.693 -  Const (predfun_name_of thy name mode, funT_of compfuns mode T)
   4.694 -
   4.695 -fun mk_sizelim_fun_of compfuns thy (name, T) mode =
   4.696 -  Const (sizelim_function_name_of thy name mode, sizelim_funT_of compfuns mode T)
   4.697 -  
   4.698 -fun mk_generator_of compfuns thy (name, T) mode = 
   4.699 -  Const (generator_name_of thy name mode, sizelim_funT_of compfuns mode T)
   4.700 -
   4.701 -
   4.702 -structure PredicateCompFuns =
   4.703 -struct
   4.704 -
   4.705 -fun mk_predT T = Type (@{type_name "Predicate.pred"}, [T])
   4.706 -
   4.707 -fun dest_predT (Type (@{type_name "Predicate.pred"}, [T])) = T
   4.708 -  | dest_predT T = raise TYPE ("dest_predT", [T], []);
   4.709 -
   4.710 -fun mk_bot T = Const (@{const_name Orderings.bot}, mk_predT T);
   4.711 -
   4.712 -fun mk_single t =
   4.713 -  let val T = fastype_of t
   4.714 -  in Const(@{const_name Predicate.single}, T --> mk_predT T) $ t end;
   4.715 -
   4.716 -fun mk_bind (x, f) =
   4.717 -  let val T as Type ("fun", [_, U]) = fastype_of f
   4.718 -  in
   4.719 -    Const (@{const_name Predicate.bind}, fastype_of x --> T --> U) $ x $ f
   4.720 -  end;
   4.721 -
   4.722 -val mk_sup = HOLogic.mk_binop @{const_name sup};
   4.723 -
   4.724 -fun mk_if cond = Const (@{const_name Predicate.if_pred},
   4.725 -  HOLogic.boolT --> mk_predT HOLogic.unitT) $ cond;
   4.726 -
   4.727 -fun mk_not t = let val T = mk_predT HOLogic.unitT
   4.728 -  in Const (@{const_name Predicate.not_pred}, T --> T) $ t end
   4.729 -
   4.730 -fun mk_Enum f =
   4.731 -  let val T as Type ("fun", [T', _]) = fastype_of f
   4.732 -  in
   4.733 -    Const (@{const_name Predicate.Pred}, T --> mk_predT T') $ f    
   4.734 -  end;
   4.735 -
   4.736 -fun mk_Eval (f, x) =
   4.737 -  let
   4.738 -    val T = fastype_of x
   4.739 -  in
   4.740 -    Const (@{const_name Predicate.eval}, mk_predT T --> T --> HOLogic.boolT) $ f $ x
   4.741 -  end;
   4.742 -
   4.743 -fun mk_map T1 T2 tf tp = Const (@{const_name Predicate.map},
   4.744 -  (T1 --> T2) --> mk_predT T1 --> mk_predT T2) $ tf $ tp;
   4.745 -
   4.746 -val lift_pred = I
   4.747 -
   4.748 -val compfuns = CompilationFuns {mk_predT = mk_predT, dest_predT = dest_predT, mk_bot = mk_bot,
   4.749 -  mk_single = mk_single, mk_bind = mk_bind, mk_sup = mk_sup, mk_if = mk_if, mk_not = mk_not,
   4.750 -  mk_map = mk_map, lift_pred = lift_pred};
   4.751 -
   4.752 -end;
   4.753 -
   4.754 -(* termify_code:
   4.755 -val termT = Type ("Code_Eval.term", []);
   4.756 -fun termifyT T = HOLogic.mk_prodT (T, HOLogic.unitT --> termT)
   4.757 -*)
   4.758 -(*
   4.759 -fun lift_random random =
   4.760 -  let
   4.761 -    val T = dest_randomT (fastype_of random)
   4.762 -  in
   4.763 -    mk_scomp (random,
   4.764 -      mk_fun_comp (HOLogic.pair_const (PredicateCompFuns.mk_predT T) @{typ Random.seed},
   4.765 -        mk_fun_comp (Const (@{const_name Predicate.single}, T --> (PredicateCompFuns.mk_predT T)),
   4.766 -          Const (@{const_name "fst"}, HOLogic.mk_prodT (T, @{typ "unit => term"}) --> T)))) 
   4.767 -  end;
   4.768 -*)
   4.769 - 
   4.770 -structure RPredCompFuns =
   4.771 -struct
   4.772 -
   4.773 -fun mk_rpredT T =
   4.774 -  @{typ "Random.seed"} --> HOLogic.mk_prodT (PredicateCompFuns.mk_predT T, @{typ "Random.seed"})
   4.775 -
   4.776 -fun dest_rpredT (Type ("fun", [_,
   4.777 -  Type (@{type_name "*"}, [Type (@{type_name "Predicate.pred"}, [T]), _])])) = T
   4.778 -  | dest_rpredT T = raise TYPE ("dest_rpredT", [T], []); 
   4.779 -
   4.780 -fun mk_bot T = Const(@{const_name RPred.bot}, mk_rpredT T)
   4.781 -
   4.782 -fun mk_single t =
   4.783 -  let
   4.784 -    val T = fastype_of t
   4.785 -  in
   4.786 -    Const (@{const_name RPred.return}, T --> mk_rpredT T) $ t
   4.787 -  end;
   4.788 -
   4.789 -fun mk_bind (x, f) =
   4.790 -  let
   4.791 -    val T as (Type ("fun", [_, U])) = fastype_of f
   4.792 -  in
   4.793 -    Const (@{const_name RPred.bind}, fastype_of x --> T --> U) $ x $ f
   4.794 -  end
   4.795 -
   4.796 -val mk_sup = HOLogic.mk_binop @{const_name RPred.supp}
   4.797 -
   4.798 -fun mk_if cond = Const (@{const_name RPred.if_rpred},
   4.799 -  HOLogic.boolT --> mk_rpredT HOLogic.unitT) $ cond;
   4.800 -
   4.801 -fun mk_not t = error "Negation is not defined for RPred"
   4.802 -
   4.803 -fun mk_map t = error "FIXME" (*FIXME*)
   4.804 -
   4.805 -fun lift_pred t =
   4.806 -  let
   4.807 -    val T = PredicateCompFuns.dest_predT (fastype_of t)
   4.808 -    val lift_predT = PredicateCompFuns.mk_predT T --> mk_rpredT T 
   4.809 -  in
   4.810 -    Const (@{const_name "RPred.lift_pred"}, lift_predT) $ t  
   4.811 -  end;
   4.812 -
   4.813 -val compfuns = CompilationFuns {mk_predT = mk_rpredT, dest_predT = dest_rpredT, mk_bot = mk_bot,
   4.814 -    mk_single = mk_single, mk_bind = mk_bind, mk_sup = mk_sup, mk_if = mk_if, mk_not = mk_not,
   4.815 -    mk_map = mk_map, lift_pred = lift_pred};
   4.816 -
   4.817 -end;
   4.818 -(* for external use with interactive mode *)
   4.819 -val rpred_compfuns = RPredCompFuns.compfuns;
   4.820 -
   4.821 -fun lift_random random =
   4.822 -  let
   4.823 -    val T = dest_randomT (fastype_of random)
   4.824 -  in
   4.825 -    Const (@{const_name lift_random}, (@{typ Random.seed} -->
   4.826 -      HOLogic.mk_prodT (HOLogic.mk_prodT (T, @{typ "unit => term"}), @{typ Random.seed})) --> 
   4.827 -      RPredCompFuns.mk_rpredT T) $ random
   4.828 -  end;
   4.829 - 
   4.830 -(* Mode analysis *)
   4.831 -
   4.832 -(*** check if a term contains only constructor functions ***)
   4.833 -fun is_constrt thy =
   4.834 -  let
   4.835 -    val cnstrs = flat (maps
   4.836 -      (map (fn (_, (Tname, _, cs)) => map (apsnd (rpair Tname o length)) cs) o #descr o snd)
   4.837 -      (Symtab.dest (Datatype.get_all thy)));
   4.838 -    fun check t = (case strip_comb t of
   4.839 -        (Free _, []) => true
   4.840 -      | (Const (s, T), ts) => (case (AList.lookup (op =) cnstrs s, body_type T) of
   4.841 -            (SOME (i, Tname), Type (Tname', _)) => length ts = i andalso Tname = Tname' andalso forall check ts
   4.842 -          | _ => false)
   4.843 -      | _ => false)
   4.844 -  in check end;
   4.845 -
   4.846 -(*** check if a type is an equality type (i.e. doesn't contain fun)
   4.847 -  FIXME this is only an approximation ***)
   4.848 -fun is_eqT (Type (s, Ts)) = s <> "fun" andalso forall is_eqT Ts
   4.849 -  | is_eqT _ = true;
   4.850 -
   4.851 -fun term_vs tm = fold_aterms (fn Free (x, T) => cons x | _ => I) tm [];
   4.852 -val terms_vs = distinct (op =) o maps term_vs;
   4.853 -
   4.854 -(** collect all Frees in a term (with duplicates!) **)
   4.855 -fun term_vTs tm =
   4.856 -  fold_aterms (fn Free xT => cons xT | _ => I) tm [];
   4.857 -
   4.858 -(*FIXME this function should not be named merge... make it local instead*)
   4.859 -fun merge xs [] = xs
   4.860 -  | merge [] ys = ys
   4.861 -  | merge (x::xs) (y::ys) = if length x >= length y then x::merge xs (y::ys)
   4.862 -      else y::merge (x::xs) ys;
   4.863 -
   4.864 -fun subsets i j = if i <= j then
   4.865 -       let val is = subsets (i+1) j
   4.866 -       in merge (map (fn ks => i::ks) is) is end
   4.867 -     else [[]];
   4.868 -     
   4.869 -(* FIXME: should be in library - map_prod *)
   4.870 -fun cprod ([], ys) = []
   4.871 -  | cprod (x :: xs, ys) = map (pair x) ys @ cprod (xs, ys);
   4.872 -
   4.873 -fun cprods xss = foldr (map op :: o cprod) [[]] xss;
   4.874 -
   4.875 -fun cprods_subset [] = [[]]
   4.876 -  | cprods_subset (xs :: xss) =
   4.877 -  let
   4.878 -    val yss = (cprods_subset xss)
   4.879 -  in maps (fn ys => map (fn x => cons x ys) xs) yss @ yss end
   4.880 -  
   4.881 -(*TODO: cleanup function and put together with modes_of_term *)
   4.882 -(*
   4.883 -fun modes_of_param default modes t = let
   4.884 -    val (vs, t') = strip_abs t
   4.885 -    val b = length vs
   4.886 -    fun mk_modes name args = Option.map (maps (fn (m as (iss, is)) =>
   4.887 -        let
   4.888 -          val (args1, args2) =
   4.889 -            if length args < length iss then
   4.890 -              error ("Too few arguments for inductive predicate " ^ name)
   4.891 -            else chop (length iss) args;
   4.892 -          val k = length args2;
   4.893 -          val perm = map (fn i => (find_index_eq (Bound (b - i)) args2) + 1)
   4.894 -            (1 upto b)  
   4.895 -          val partial_mode = (1 upto k) \\ perm
   4.896 -        in
   4.897 -          if not (partial_mode subset is) then [] else
   4.898 -          let
   4.899 -            val is' = 
   4.900 -            (fold_index (fn (i, j) => if j mem is then cons (i + 1) else I) perm [])
   4.901 -            |> fold (fn i => if i > k then cons (i - k + b) else I) is
   4.902 -              
   4.903 -           val res = map (fn x => Mode (m, is', x)) (cprods (map
   4.904 -            (fn (NONE, _) => [NONE]
   4.905 -              | (SOME js, arg) => map SOME (filter
   4.906 -                  (fn Mode (_, js', _) => js=js') (modes_of_term modes arg)))
   4.907 -                    (iss ~~ args1)))
   4.908 -          in res end
   4.909 -        end)) (AList.lookup op = modes name)
   4.910 -  in case strip_comb t' of
   4.911 -    (Const (name, _), args) => the_default default (mk_modes name args)
   4.912 -    | (Var ((name, _), _), args) => the (mk_modes name args)
   4.913 -    | (Free (name, _), args) => the (mk_modes name args)
   4.914 -    | _ => default end
   4.915 -  
   4.916 -and
   4.917 -*)
   4.918 -fun modes_of_term modes t =
   4.919 -  let
   4.920 -    val ks = map_index (fn (i, T) => (i, NONE)) (binder_types (fastype_of t));
   4.921 -    val default = [Mode (([], ks), ks, [])];
   4.922 -    fun mk_modes name args = Option.map (maps (fn (m as (iss, is)) =>
   4.923 -        let
   4.924 -          val (args1, args2) =
   4.925 -            if length args < length iss then
   4.926 -              error ("Too few arguments for inductive predicate " ^ name)
   4.927 -            else chop (length iss) args;
   4.928 -          val k = length args2;
   4.929 -          val prfx = map (rpair NONE) (1 upto k)
   4.930 -        in
   4.931 -          if not (is_prefix op = prfx is) then [] else
   4.932 -          let val is' = List.drop (is, k)
   4.933 -          in map (fn x => Mode (m, is', x)) (cprods (map
   4.934 -            (fn (NONE, _) => [NONE]
   4.935 -              | (SOME js, arg) => map SOME (filter
   4.936 -                  (fn Mode (_, js', _) => js=js') (modes_of_term modes arg)))
   4.937 -                    (iss ~~ args1)))
   4.938 -          end
   4.939 -        end)) (AList.lookup op = modes name)
   4.940 -
   4.941 -  in
   4.942 -    case strip_comb (Envir.eta_contract t) of
   4.943 -      (Const (name, _), args) => the_default default (mk_modes name args)
   4.944 -    | (Var ((name, _), _), args) => the (mk_modes name args)
   4.945 -    | (Free (name, _), args) => the (mk_modes name args)
   4.946 -    | (Abs _, []) => error "Abs at param position" (* modes_of_param default modes t *)
   4.947 -    | _ => default
   4.948 -  end
   4.949 -  
   4.950 -fun select_mode_prem thy modes vs ps =
   4.951 -  find_first (is_some o snd) (ps ~~ map
   4.952 -    (fn Prem (us, t) => find_first (fn Mode (_, is, _) =>
   4.953 -          let
   4.954 -            val (in_ts, out_ts) = split_smode is us;
   4.955 -            val (out_ts', in_ts') = List.partition (is_constrt thy) out_ts;
   4.956 -            val vTs = maps term_vTs out_ts';
   4.957 -            val dupTs = map snd (duplicates (op =) vTs) @
   4.958 -              List.mapPartial (AList.lookup (op =) vTs) vs;
   4.959 -          in
   4.960 -            terms_vs (in_ts @ in_ts') subset vs andalso
   4.961 -            forall (is_eqT o fastype_of) in_ts' andalso
   4.962 -            term_vs t subset vs andalso
   4.963 -            forall is_eqT dupTs
   4.964 -          end)
   4.965 -            (modes_of_term modes t handle Option =>
   4.966 -               error ("Bad predicate: " ^ Syntax.string_of_term_global thy t))
   4.967 -      | Negprem (us, t) => find_first (fn Mode (_, is, _) =>
   4.968 -            length us = length is andalso
   4.969 -            terms_vs us subset vs andalso
   4.970 -            term_vs t subset vs)
   4.971 -            (modes_of_term modes t handle Option =>
   4.972 -               error ("Bad predicate: " ^ Syntax.string_of_term_global thy t))
   4.973 -      | Sidecond t => if term_vs t subset vs then SOME (Mode (([], []), [], []))
   4.974 -          else NONE
   4.975 -      ) ps);
   4.976 -
   4.977 -fun fold_prem f (Prem (args, _)) = fold f args
   4.978 -  | fold_prem f (Negprem (args, _)) = fold f args
   4.979 -  | fold_prem f (Sidecond t) = f t
   4.980 -
   4.981 -fun all_subsets [] = [[]]
   4.982 -  | all_subsets (x::xs) = let val xss' = all_subsets xs in xss' @ (map (cons x) xss') end
   4.983 -
   4.984 -fun generator vTs v = 
   4.985 -  let
   4.986 -    val T = the (AList.lookup (op =) vTs v)
   4.987 -  in
   4.988 -    (Generator (v, T), Mode (([], []), [], []))
   4.989 -  end;
   4.990 -
   4.991 -fun gen_prem (Prem (us, t)) = GeneratorPrem (us, t) 
   4.992 -  | gen_prem _ = error "gen_prem : invalid input for gen_prem"
   4.993 -
   4.994 -fun param_gen_prem param_vs (p as Prem (us, t as Free (v, _))) =
   4.995 -  if member (op =) param_vs v then
   4.996 -    GeneratorPrem (us, t)
   4.997 -  else p  
   4.998 -  | param_gen_prem param_vs p = p
   4.999 -  
  4.1000 -fun check_mode_clause with_generator thy param_vs modes gen_modes (iss, is) (ts, ps) =
  4.1001 -  let
  4.1002 -    val modes' = modes @ List.mapPartial
  4.1003 -      (fn (_, NONE) => NONE | (v, SOME js) => SOME (v, [([], js)]))
  4.1004 -        (param_vs ~~ iss);
  4.1005 -    val gen_modes' = gen_modes @ List.mapPartial
  4.1006 -      (fn (_, NONE) => NONE | (v, SOME js) => SOME (v, [([], js)]))
  4.1007 -        (param_vs ~~ iss);  
  4.1008 -    val vTs = distinct (op =) ((fold o fold_prem) Term.add_frees ps (fold Term.add_frees ts []))
  4.1009 -    val prem_vs = distinct (op =) ((fold o fold_prem) Term.add_free_names ps [])
  4.1010 -    fun check_mode_prems acc_ps vs [] = SOME (acc_ps, vs)
  4.1011 -      | check_mode_prems acc_ps vs ps = (case select_mode_prem thy modes' vs ps of
  4.1012 -          NONE =>
  4.1013 -            (if with_generator then
  4.1014 -              (case select_mode_prem thy gen_modes' vs ps of
  4.1015 -                  SOME (p, SOME mode) => check_mode_prems ((gen_prem p, mode) :: acc_ps) 
  4.1016 -                  (case p of Prem (us, _) => vs union terms_vs us | _ => vs)
  4.1017 -                  (filter_out (equal p) ps)
  4.1018 -                | NONE =>
  4.1019 -                  let 
  4.1020 -                    val all_generator_vs = all_subsets (prem_vs \\ vs) |> sort (int_ord o (pairself length))
  4.1021 -                  in
  4.1022 -                    case (find_first (fn generator_vs => is_some
  4.1023 -                      (select_mode_prem thy modes' (vs union generator_vs) ps)) all_generator_vs) of
  4.1024 -                      SOME generator_vs => check_mode_prems ((map (generator vTs) generator_vs) @ acc_ps)
  4.1025 -                        (vs union generator_vs) ps
  4.1026 -                    | NONE => NONE
  4.1027 -                  end)
  4.1028 -            else
  4.1029 -              NONE)
  4.1030 -        | SOME (p, SOME mode) => check_mode_prems ((if with_generator then param_gen_prem param_vs p else p, mode) :: acc_ps) 
  4.1031 -            (case p of Prem (us, _) => vs union terms_vs us | _ => vs)
  4.1032 -            (filter_out (equal p) ps))
  4.1033 -    val (in_ts, in_ts') = List.partition (is_constrt thy) (fst (split_smode is ts));
  4.1034 -    val in_vs = terms_vs in_ts;
  4.1035 -    val concl_vs = terms_vs ts
  4.1036 -  in
  4.1037 -    if forall is_eqT (map snd (duplicates (op =) (maps term_vTs in_ts))) andalso
  4.1038 -    forall (is_eqT o fastype_of) in_ts' then
  4.1039 -      case check_mode_prems [] (param_vs union in_vs) ps of
  4.1040 -         NONE => NONE
  4.1041 -       | SOME (acc_ps, vs) =>
  4.1042 -         if with_generator then
  4.1043 -           SOME (ts, (rev acc_ps) @ (map (generator vTs) (concl_vs \\ vs))) 
  4.1044 -         else
  4.1045 -           if concl_vs subset vs then SOME (ts, rev acc_ps) else NONE
  4.1046 -    else NONE
  4.1047 -  end;
  4.1048 -
  4.1049 -fun check_modes_pred with_generator thy param_vs clauses modes gen_modes (p, ms) =
  4.1050 -  let val SOME rs = AList.lookup (op =) clauses p
  4.1051 -  in (p, List.filter (fn m => case find_index
  4.1052 -    (is_none o check_mode_clause with_generator thy param_vs modes gen_modes m) rs of
  4.1053 -      ~1 => true
  4.1054 -    | i => (Output.tracing ("Clause " ^ string_of_int (i + 1) ^ " of " ^
  4.1055 -      p ^ " violates mode " ^ string_of_mode m);
  4.1056 -        Output.tracing (commas (map (Syntax.string_of_term_global thy) (fst (nth rs i)))); false)) ms)
  4.1057 -  end;
  4.1058 -
  4.1059 -fun get_modes_pred with_generator thy param_vs clauses modes gen_modes (p, ms) =
  4.1060 -  let
  4.1061 -    val SOME rs = AList.lookup (op =) clauses p 
  4.1062 -  in
  4.1063 -    (p, map (fn m =>
  4.1064 -      (m, map (the o check_mode_clause with_generator thy param_vs modes gen_modes m) rs)) ms)
  4.1065 -  end;
  4.1066 -  
  4.1067 -fun fixp f (x : (string * mode list) list) =
  4.1068 -  let val y = f x
  4.1069 -  in if x = y then x else fixp f y end;
  4.1070 -
  4.1071 -fun infer_modes thy extra_modes all_modes param_vs clauses =
  4.1072 -  let
  4.1073 -    val modes =
  4.1074 -      fixp (fn modes =>
  4.1075 -        map (check_modes_pred false thy param_vs clauses (modes @ extra_modes) []) modes)
  4.1076 -          all_modes
  4.1077 -  in
  4.1078 -    map (get_modes_pred false thy param_vs clauses (modes @ extra_modes) []) modes
  4.1079 -  end;
  4.1080 -
  4.1081 -fun remove_from rem [] = []
  4.1082 -  | remove_from rem ((k, vs) :: xs) =
  4.1083 -    (case AList.lookup (op =) rem k of
  4.1084 -      NONE => (k, vs)
  4.1085 -    | SOME vs' => (k, vs \\ vs'))
  4.1086 -    :: remove_from rem xs
  4.1087 -    
  4.1088 -fun infer_modes_with_generator thy extra_modes all_modes param_vs clauses =
  4.1089 -  let
  4.1090 -    val prednames = map fst clauses
  4.1091 -    val extra_modes = all_modes_of thy
  4.1092 -    val gen_modes = all_generator_modes_of thy
  4.1093 -      |> filter_out (fn (name, _) => member (op =) prednames name)
  4.1094 -    val starting_modes = remove_from extra_modes all_modes 
  4.1095 -    val modes =
  4.1096 -      fixp (fn modes =>
  4.1097 -        map (check_modes_pred true thy param_vs clauses extra_modes (gen_modes @ modes)) modes)
  4.1098 -         starting_modes 
  4.1099 -  in
  4.1100 -    map (get_modes_pred true thy param_vs clauses extra_modes (gen_modes @ modes)) modes
  4.1101 -  end;
  4.1102 -
  4.1103 -(* term construction *)
  4.1104 -
  4.1105 -fun mk_v (names, vs) s T = (case AList.lookup (op =) vs s of
  4.1106 -      NONE => (Free (s, T), (names, (s, [])::vs))
  4.1107 -    | SOME xs =>
  4.1108 -        let
  4.1109 -          val s' = Name.variant names s;
  4.1110 -          val v = Free (s', T)
  4.1111 -        in
  4.1112 -          (v, (s'::names, AList.update (op =) (s, v::xs) vs))
  4.1113 -        end);
  4.1114 -
  4.1115 -fun distinct_v (Free (s, T)) nvs = mk_v nvs s T
  4.1116 -  | distinct_v (t $ u) nvs =
  4.1117 -      let
  4.1118 -        val (t', nvs') = distinct_v t nvs;
  4.1119 -        val (u', nvs'') = distinct_v u nvs';
  4.1120 -      in (t' $ u', nvs'') end
  4.1121 -  | distinct_v x nvs = (x, nvs);
  4.1122 -
  4.1123 -fun compile_match thy compfuns eqs eqs' out_ts success_t =
  4.1124 -  let
  4.1125 -    val eqs'' = maps mk_eq eqs @ eqs'
  4.1126 -    val names = fold Term.add_free_names (success_t :: eqs'' @ out_ts) [];
  4.1127 -    val name = Name.variant names "x";
  4.1128 -    val name' = Name.variant (name :: names) "y";
  4.1129 -    val T = mk_tupleT (map fastype_of out_ts);
  4.1130 -    val U = fastype_of success_t;
  4.1131 -    val U' = dest_predT compfuns U;
  4.1132 -    val v = Free (name, T);
  4.1133 -    val v' = Free (name', T);
  4.1134 -  in
  4.1135 -    lambda v (fst (Datatype.make_case
  4.1136 -      (ProofContext.init thy) false [] v
  4.1137 -      [(mk_tuple out_ts,
  4.1138 -        if null eqs'' then success_t
  4.1139 -        else Const (@{const_name HOL.If}, HOLogic.boolT --> U --> U --> U) $
  4.1140 -          foldr1 HOLogic.mk_conj eqs'' $ success_t $
  4.1141 -            mk_bot compfuns U'),
  4.1142 -       (v', mk_bot compfuns U')]))
  4.1143 -  end;
  4.1144 -
  4.1145 -(*FIXME function can be removed*)
  4.1146 -fun mk_funcomp f t =
  4.1147 -  let
  4.1148 -    val names = Term.add_free_names t [];
  4.1149 -    val Ts = binder_types (fastype_of t);
  4.1150 -    val vs = map Free
  4.1151 -      (Name.variant_list names (replicate (length Ts) "x") ~~ Ts)
  4.1152 -  in
  4.1153 -    fold_rev lambda vs (f (list_comb (t, vs)))
  4.1154 -  end;
  4.1155 -(*
  4.1156 -fun compile_param_ext thy compfuns modes (NONE, t) = t
  4.1157 -  | compile_param_ext thy compfuns modes (m as SOME (Mode ((iss, is'), is, ms)), t) =
  4.1158 -      let
  4.1159 -        val (vs, u) = strip_abs t
  4.1160 -        val (ivs, ovs) = split_mode is vs    
  4.1161 -        val (f, args) = strip_comb u
  4.1162 -        val (params, args') = chop (length ms) args
  4.1163 -        val (inargs, outargs) = split_mode is' args'
  4.1164 -        val b = length vs
  4.1165 -        val perm = map (fn i => (find_index_eq (Bound (b - i)) args') + 1) (1 upto b)
  4.1166 -        val outp_perm =
  4.1167 -          snd (split_mode is perm)
  4.1168 -          |> map (fn i => i - length (filter (fn x => x < i) is'))
  4.1169 -        val names = [] -- TODO
  4.1170 -        val out_names = Name.variant_list names (replicate (length outargs) "x")
  4.1171 -        val f' = case f of
  4.1172 -            Const (name, T) =>
  4.1173 -              if AList.defined op = modes name then
  4.1174 -                mk_predfun_of thy compfuns (name, T) (iss, is')
  4.1175 -              else error "compile param: Not an inductive predicate with correct mode"
  4.1176 -          | Free (name, T) => Free (name, param_funT_of compfuns T (SOME is'))
  4.1177 -        val outTs = dest_tupleT (dest_predT compfuns (body_type (fastype_of f')))
  4.1178 -        val out_vs = map Free (out_names ~~ outTs)
  4.1179 -        val params' = map (compile_param thy modes) (ms ~~ params)
  4.1180 -        val f_app = list_comb (f', params' @ inargs)
  4.1181 -        val single_t = (mk_single compfuns (mk_tuple (map (fn i => nth out_vs (i - 1)) outp_perm)))
  4.1182 -        val match_t = compile_match thy compfuns [] [] out_vs single_t
  4.1183 -      in list_abs (ivs,
  4.1184 -        mk_bind compfuns (f_app, match_t))
  4.1185 -      end
  4.1186 -  | compile_param_ext _ _ _ _ = error "compile params"
  4.1187 -*)
  4.1188 -
  4.1189 -fun compile_param size thy compfuns (NONE, t) = t
  4.1190 -  | compile_param size thy compfuns (m as SOME (Mode ((iss, is'), is, ms)), t) =
  4.1191 -   let
  4.1192 -     val (f, args) = strip_comb (Envir.eta_contract t)
  4.1193 -     val (params, args') = chop (length ms) args
  4.1194 -     val params' = map (compile_param size thy compfuns) (ms ~~ params)
  4.1195 -     val mk_fun_of = case size of NONE => mk_fun_of | SOME _ => mk_sizelim_fun_of
  4.1196 -     val funT_of = case size of NONE => funT_of | SOME _ => sizelim_funT_of
  4.1197 -     val f' =
  4.1198 -       case f of
  4.1199 -         Const (name, T) =>
  4.1200 -           mk_fun_of compfuns thy (name, T) (iss, is')
  4.1201 -       | Free (name, T) => Free (name, funT_of compfuns (iss, is') T)
  4.1202 -       | _ => error ("PredicateCompiler: illegal parameter term")
  4.1203 -   in list_comb (f', params' @ args') end
  4.1204 -   
  4.1205 -fun compile_expr size thy ((Mode (mode, is, ms)), t) =
  4.1206 -  case strip_comb t of
  4.1207 -    (Const (name, T), params) =>
  4.1208 -       let
  4.1209 -         val params' = map (compile_param size thy PredicateCompFuns.compfuns) (ms ~~ params)
  4.1210 -         val mk_fun_of = case size of NONE => mk_fun_of | SOME _ => mk_sizelim_fun_of
  4.1211 -       in
  4.1212 -         list_comb (mk_fun_of PredicateCompFuns.compfuns thy (name, T) mode, params')
  4.1213 -       end
  4.1214 -  | (Free (name, T), args) =>
  4.1215 -       let 
  4.1216 -         val funT_of = case size of NONE => funT_of | SOME _ => sizelim_funT_of 
  4.1217 -       in
  4.1218 -         list_comb (Free (name, funT_of PredicateCompFuns.compfuns ([], is) T), args)
  4.1219 -       end;
  4.1220 -       
  4.1221 -fun compile_gen_expr size thy compfuns ((Mode (mode, is, ms)), t) =
  4.1222 -  case strip_comb t of
  4.1223 -    (Const (name, T), params) =>
  4.1224 -      let
  4.1225 -        val params' = map (compile_param size thy compfuns) (ms ~~ params)
  4.1226 -      in
  4.1227 -        list_comb (mk_generator_of compfuns thy (name, T) mode, params')
  4.1228 -      end
  4.1229 -    | (Free (name, T), args) =>
  4.1230 -      list_comb (Free (name, sizelim_funT_of RPredCompFuns.compfuns ([], is) T), args)
  4.1231 -          
  4.1232 -(** specific rpred functions -- move them to the correct place in this file *)
  4.1233 -
  4.1234 -(* uncommented termify code; causes more trouble than expected at first *) 
  4.1235 -(*
  4.1236 -fun mk_valtermify_term (t as Const (c, T)) = HOLogic.mk_prod (t, Abs ("u", HOLogic.unitT, HOLogic.reflect_term t))
  4.1237 -  | mk_valtermify_term (Free (x, T)) = Free (x, termifyT T) 
  4.1238 -  | mk_valtermify_term (t1 $ t2) =
  4.1239 -    let
  4.1240 -      val T = fastype_of t1
  4.1241 -      val (T1, T2) = dest_funT T
  4.1242 -      val t1' = mk_valtermify_term t1
  4.1243 -      val t2' = mk_valtermify_term t2
  4.1244 -    in
  4.1245 -      Const ("Code_Eval.valapp", termifyT T --> termifyT T1 --> termifyT T2) $ t1' $ t2'
  4.1246 -    end
  4.1247 -  | mk_valtermify_term _ = error "Not a valid term for mk_valtermify_term"
  4.1248 -*)
  4.1249 -
  4.1250 -fun compile_clause compfuns size final_term thy all_vs param_vs (iss, is) inp (ts, moded_ps) =
  4.1251 -  let
  4.1252 -    fun check_constrt t (names, eqs) =
  4.1253 -      if is_constrt thy t then (t, (names, eqs)) else
  4.1254 -        let
  4.1255 -          val s = Name.variant names "x";
  4.1256 -          val v = Free (s, fastype_of t)
  4.1257 -        in (v, (s::names, HOLogic.mk_eq (v, t)::eqs)) end;
  4.1258 -
  4.1259 -    val (in_ts, out_ts) = split_smode is ts;
  4.1260 -    val (in_ts', (all_vs', eqs)) =
  4.1261 -      fold_map check_constrt in_ts (all_vs, []);
  4.1262 -
  4.1263 -    fun compile_prems out_ts' vs names [] =
  4.1264 -          let
  4.1265 -            val (out_ts'', (names', eqs')) =
  4.1266 -              fold_map check_constrt out_ts' (names, []);
  4.1267 -            val (out_ts''', (names'', constr_vs)) = fold_map distinct_v
  4.1268 -              out_ts'' (names', map (rpair []) vs);
  4.1269 -          in
  4.1270 -          (* termify code:
  4.1271 -            compile_match thy compfuns constr_vs (eqs @ eqs') out_ts'''
  4.1272 -              (mk_single compfuns (mk_tuple (map mk_valtermify_term out_ts)))
  4.1273 -           *)
  4.1274 -            compile_match thy compfuns constr_vs (eqs @ eqs') out_ts'''
  4.1275 -              (final_term out_ts)
  4.1276 -          end
  4.1277 -      | compile_prems out_ts vs names ((p, mode as Mode ((_, is), _, _)) :: ps) =
  4.1278 -          let
  4.1279 -            val vs' = distinct (op =) (flat (vs :: map term_vs out_ts));
  4.1280 -            val (out_ts', (names', eqs)) =
  4.1281 -              fold_map check_constrt out_ts (names, [])
  4.1282 -            val (out_ts'', (names'', constr_vs')) = fold_map distinct_v
  4.1283 -              out_ts' ((names', map (rpair []) vs))
  4.1284 -            val (compiled_clause, rest) = case p of
  4.1285 -               Prem (us, t) =>
  4.1286 -                 let
  4.1287 -                   val (in_ts, out_ts''') = split_smode is us;
  4.1288 -                   val args = case size of
  4.1289 -                     NONE => in_ts
  4.1290 -                   | SOME size_t => in_ts @ [size_t]
  4.1291 -                   val u = lift_pred compfuns
  4.1292 -                     (list_comb (compile_expr size thy (mode, t), args))                     
  4.1293 -                   val rest = compile_prems out_ts''' vs' names'' ps
  4.1294 -                 in
  4.1295 -                   (u, rest)
  4.1296 -                 end
  4.1297 -             | Negprem (us, t) =>
  4.1298 -                 let
  4.1299 -                   val (in_ts, out_ts''') = split_smode is us
  4.1300 -                   val u = lift_pred compfuns
  4.1301 -                     (mk_not PredicateCompFuns.compfuns (list_comb (compile_expr NONE thy (mode, t), in_ts)))
  4.1302 -                   val rest = compile_prems out_ts''' vs' names'' ps
  4.1303 -                 in
  4.1304 -                   (u, rest)
  4.1305 -                 end
  4.1306 -             | Sidecond t =>
  4.1307 -                 let
  4.1308 -                   val rest = compile_prems [] vs' names'' ps;
  4.1309 -                 in
  4.1310 -                   (mk_if compfuns t, rest)
  4.1311 -                 end
  4.1312 -             | GeneratorPrem (us, t) =>
  4.1313 -                 let
  4.1314 -                   val (in_ts, out_ts''') = split_smode is us;
  4.1315 -                   val args = case size of
  4.1316 -                     NONE => in_ts
  4.1317 -                   | SOME size_t => in_ts @ [size_t]
  4.1318 -                   val u = list_comb (compile_gen_expr size thy compfuns (mode, t), args)
  4.1319 -                   val rest = compile_prems out_ts''' vs' names'' ps
  4.1320 -                 in
  4.1321 -                   (u, rest)
  4.1322 -                 end
  4.1323 -             | Generator (v, T) =>
  4.1324 -                 let
  4.1325 -                   val u = lift_random (HOLogic.mk_random T @{term "1::code_numeral"})
  4.1326 -                   val rest = compile_prems [Free (v, T)]  vs' names'' ps;
  4.1327 -                 in
  4.1328 -                   (u, rest)
  4.1329 -                 end
  4.1330 -          in
  4.1331 -            compile_match thy compfuns constr_vs' eqs out_ts'' 
  4.1332 -              (mk_bind compfuns (compiled_clause, rest))
  4.1333 -          end
  4.1334 -    val prem_t = compile_prems in_ts' param_vs all_vs' moded_ps;
  4.1335 -  in
  4.1336 -    mk_bind compfuns (mk_single compfuns inp, prem_t)
  4.1337 -  end
  4.1338 -
  4.1339 -fun compile_pred compfuns mk_fun_of use_size thy all_vs param_vs s T mode moded_cls =
  4.1340 -  let
  4.1341 -	  val (Ts1, Ts2) = chop (length (fst mode)) (binder_types T)
  4.1342 -    val (Us1, Us2) = split_smodeT (snd mode) Ts2
  4.1343 -    val funT_of = if use_size then sizelim_funT_of else funT_of
  4.1344 -    val Ts1' = map2 (fn NONE => I | SOME is => funT_of compfuns ([], is)) (fst mode) Ts1
  4.1345 -    val size_name = Name.variant (all_vs @ param_vs) "size"
  4.1346 -  	fun mk_input_term (i, NONE) =
  4.1347 -		    [Free (Name.variant (all_vs @ param_vs) ("x" ^ string_of_int i), nth Ts2 (i - 1))]
  4.1348 -		  | mk_input_term (i, SOME pis) = case HOLogic.strip_tupleT (nth Ts2 (i - 1)) of
  4.1349 -						   [] => error "strange unit input"
  4.1350 -					   | [T] => [Free (Name.variant (all_vs @ param_vs) ("x" ^ string_of_int i), nth Ts2 (i - 1))]
  4.1351 -						 | Ts => let
  4.1352 -							 val vnames = Name.variant_list (all_vs @ param_vs)
  4.1353 -								(map (fn j => "x" ^ string_of_int i ^ "p" ^ string_of_int j)
  4.1354 -									pis)
  4.1355 -						 in if null pis then []
  4.1356 -						   else [HOLogic.mk_tuple (map Free (vnames ~~ map (fn j => nth Ts (j - 1)) pis))] end
  4.1357 -		val in_ts = maps mk_input_term (snd mode)
  4.1358 -    val params = map2 (fn s => fn T => Free (s, T)) param_vs Ts1'
  4.1359 -    val size = Free (size_name, @{typ "code_numeral"})
  4.1360 -    val decr_size =
  4.1361 -      if use_size then
  4.1362 -        SOME (Const ("HOL.minus_class.minus", @{typ "code_numeral => code_numeral => code_numeral"})
  4.1363 -          $ size $ Const ("HOL.one_class.one", @{typ "Code_Numeral.code_numeral"}))
  4.1364 -      else
  4.1365 -        NONE
  4.1366 -    val cl_ts =
  4.1367 -      map (compile_clause compfuns decr_size (fn out_ts => mk_single compfuns (mk_tuple out_ts))
  4.1368 -        thy all_vs param_vs mode (mk_tuple in_ts)) moded_cls;
  4.1369 -    val t = foldr1 (mk_sup compfuns) cl_ts
  4.1370 -    val T' = mk_predT compfuns (mk_tupleT Us2)
  4.1371 -    val size_t = Const (@{const_name "If"}, @{typ bool} --> T' --> T' --> T')
  4.1372 -      $ HOLogic.mk_eq (size, @{term "0 :: code_numeral"})
  4.1373 -      $ mk_bot compfuns (dest_predT compfuns T') $ t
  4.1374 -    val fun_const = mk_fun_of compfuns thy (s, T) mode
  4.1375 -    val eq = if use_size then
  4.1376 -      (list_comb (fun_const, params @ in_ts @ [size]), size_t)
  4.1377 -    else
  4.1378 -      (list_comb (fun_const, params @ in_ts), t)
  4.1379 -  in
  4.1380 -    HOLogic.mk_Trueprop (HOLogic.mk_eq eq)
  4.1381 -  end;
  4.1382 -  
  4.1383 -(* special setup for simpset *)                  
  4.1384 -val HOL_basic_ss' = HOL_basic_ss addsimps (@{thms "HOL.simp_thms"} @ [@{thm Pair_eq}])
  4.1385 -  setSolver (mk_solver "all_tac_solver" (fn _ => fn _ => all_tac))
  4.1386 -	setSolver (mk_solver "True_solver" (fn _ => rtac @{thm TrueI}))
  4.1387 -
  4.1388 -(* Definition of executable functions and their intro and elim rules *)
  4.1389 -
  4.1390 -fun print_arities arities = tracing ("Arities:\n" ^
  4.1391 -  cat_lines (map (fn (s, (ks, k)) => s ^ ": " ^
  4.1392 -    space_implode " -> " (map
  4.1393 -      (fn NONE => "X" | SOME k' => string_of_int k')
  4.1394 -        (ks @ [SOME k]))) arities));
  4.1395 -
  4.1396 -fun mk_Eval_of ((x, T), NONE) names = (x, names)
  4.1397 -  | mk_Eval_of ((x, T), SOME mode) names =
  4.1398 -	let
  4.1399 -    val Ts = binder_types T
  4.1400 -    (*val argnames = Name.variant_list names
  4.1401 -        (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts)));
  4.1402 -    val args = map Free (argnames ~~ Ts)
  4.1403 -    val (inargs, outargs) = split_smode mode args*)
  4.1404 -		fun mk_split_lambda [] t = lambda (Free (Name.variant names "x", HOLogic.unitT)) t
  4.1405 -			| mk_split_lambda [x] t = lambda x t
  4.1406 -			| mk_split_lambda xs t =
  4.1407 -			let
  4.1408 -				fun mk_split_lambda' (x::y::[]) t = HOLogic.mk_split (lambda x (lambda y t))
  4.1409 -					| mk_split_lambda' (x::xs) t = HOLogic.mk_split (lambda x (mk_split_lambda' xs t))
  4.1410 -			in
  4.1411 -				mk_split_lambda' xs t
  4.1412 -			end;
  4.1413 -  	fun mk_arg (i, T) =
  4.1414 -		  let
  4.1415 -	  	  val vname = Name.variant names ("x" ^ string_of_int i)
  4.1416 -		    val default = Free (vname, T)
  4.1417 -		  in 
  4.1418 -		    case AList.lookup (op =) mode i of
  4.1419 -		      NONE => (([], [default]), [default])
  4.1420 -			  | SOME NONE => (([default], []), [default])
  4.1421 -			  | SOME (SOME pis) =>
  4.1422 -				  case HOLogic.strip_tupleT T of
  4.1423 -						[] => error "pair mode but unit tuple" (*(([default], []), [default])*)
  4.1424 -					| [_] => error "pair mode but not a tuple" (*(([default], []), [default])*)
  4.1425 -					| Ts =>
  4.1426 -					  let
  4.1427 -							val vnames = Name.variant_list names
  4.1428 -								(map (fn j => "x" ^ string_of_int i ^ "p" ^ string_of_int j)
  4.1429 -									(1 upto length Ts))
  4.1430 -							val args = map Free (vnames ~~ Ts)
  4.1431 -							fun split_args (i, arg) (ins, outs) =
  4.1432 -							  if member (op =) pis i then
  4.1433 -							    (arg::ins, outs)
  4.1434 -								else
  4.1435 -								  (ins, arg::outs)
  4.1436 -							val (inargs, outargs) = fold_rev split_args ((1 upto length Ts) ~~ args) ([], [])
  4.1437 -							fun tuple args = if null args then [] else [HOLogic.mk_tuple args]
  4.1438 -						in ((tuple inargs, tuple outargs), args) end
  4.1439 -			end
  4.1440 -		val (inoutargs, args) = split_list (map mk_arg (1 upto (length Ts) ~~ Ts))
  4.1441 -    val (inargs, outargs) = pairself flat (split_list inoutargs)
  4.1442 -		val r = PredicateCompFuns.mk_Eval (list_comb (x, inargs), mk_tuple outargs)
  4.1443 -    val t = fold_rev mk_split_lambda args r
  4.1444 -  in
  4.1445 -    (t, names)
  4.1446 -  end;
  4.1447 -
  4.1448 -fun create_intro_elim_rule (mode as (iss, is)) defthm mode_id funT pred thy =
  4.1449 -let
  4.1450 -  val Ts = binder_types (fastype_of pred)
  4.1451 -  val funtrm = Const (mode_id, funT)
  4.1452 -  val (Ts1, Ts2) = chop (length iss) Ts;
  4.1453 -  val Ts1' = map2 (fn NONE => I | SOME is => funT_of (PredicateCompFuns.compfuns) ([], is)) iss Ts1
  4.1454 -	val param_names = Name.variant_list []
  4.1455 -    (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts1)));
  4.1456 -  val params = map Free (param_names ~~ Ts1')
  4.1457 -	fun mk_args (i, T) argnames =
  4.1458 -    let
  4.1459 -		  val vname = Name.variant (param_names @ argnames) ("x" ^ string_of_int (length Ts1' + i))
  4.1460 -		  val default = (Free (vname, T), vname :: argnames)
  4.1461 -	  in
  4.1462 -  	  case AList.lookup (op =) is i of
  4.1463 -						 NONE => default
  4.1464 -					 | SOME NONE => default
  4.1465 -        	 | SOME (SOME pis) =>
  4.1466 -					   case HOLogic.strip_tupleT T of
  4.1467 -						   [] => default
  4.1468 -					   | [_] => default
  4.1469 -						 | Ts => 
  4.1470 -						let
  4.1471 -							val vnames = Name.variant_list (param_names @ argnames)
  4.1472 -								(map (fn j => "x" ^ string_of_int (length Ts1' + i) ^ "p" ^ string_of_int j)
  4.1473 -									(1 upto (length Ts)))
  4.1474 -						 in (HOLogic.mk_tuple (map Free (vnames ~~ Ts)), vnames  @ argnames) end
  4.1475 -		end
  4.1476 -	val (args, argnames) = fold_map mk_args (1 upto (length Ts2) ~~ Ts2) []
  4.1477 -  val (inargs, outargs) = split_smode is args
  4.1478 -  val param_names' = Name.variant_list (param_names @ argnames)
  4.1479 -    (map (fn i => "p" ^ string_of_int i) (1 upto (length iss)))
  4.1480 -  val param_vs = map Free (param_names' ~~ Ts1)
  4.1481 -  val (params', names) = fold_map mk_Eval_of ((params ~~ Ts1) ~~ iss) []
  4.1482 -  val predpropI = HOLogic.mk_Trueprop (list_comb (pred, param_vs @ args))
  4.1483 -  val predpropE = HOLogic.mk_Trueprop (list_comb (pred, params' @ args))
  4.1484 -  val param_eqs = map (HOLogic.mk_Trueprop o HOLogic.mk_eq) (param_vs ~~ params')
  4.1485 -  val funargs = params @ inargs
  4.1486 -  val funpropE = HOLogic.mk_Trueprop (PredicateCompFuns.mk_Eval (list_comb (funtrm, funargs),
  4.1487 -                  if null outargs then Free("y", HOLogic.unitT) else mk_tuple outargs))
  4.1488 -  val funpropI = HOLogic.mk_Trueprop (PredicateCompFuns.mk_Eval (list_comb (funtrm, funargs),
  4.1489 -                   mk_tuple outargs))
  4.1490 -  val introtrm = Logic.list_implies (predpropI :: param_eqs, funpropI)
  4.1491 -  val simprules = [defthm, @{thm eval_pred},
  4.1492 -	  @{thm "split_beta"}, @{thm "fst_conv"}, @{thm "snd_conv"}, @{thm pair_collapse}]
  4.1493 -  val unfolddef_tac = Simplifier.asm_full_simp_tac (HOL_basic_ss addsimps simprules) 1
  4.1494 -  val introthm = Goal.prove (ProofContext.init thy) (argnames @ param_names @ param_names' @ ["y"]) [] introtrm (fn {...} => unfolddef_tac)
  4.1495 -  val P = HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT));
  4.1496 -  val elimtrm = Logic.list_implies ([funpropE, Logic.mk_implies (predpropE, P)], P)
  4.1497 -  val elimthm = Goal.prove (ProofContext.init thy) (argnames @ param_names @ param_names' @ ["y", "P"]) [] elimtrm (fn {...} => unfolddef_tac)
  4.1498 -	val _ = Output.tracing (Display.string_of_thm_global thy elimthm)
  4.1499 -	val _ = Output.tracing (Display.string_of_thm_global thy introthm)
  4.1500 -
  4.1501 -in
  4.1502 -  (introthm, elimthm)
  4.1503 -end;
  4.1504 -
  4.1505 -fun create_constname_of_mode thy prefix name mode = 
  4.1506 -  let
  4.1507 -    fun string_of_mode mode = if null mode then "0"
  4.1508 -      else space_implode "_" (map (fn (i, NONE) => string_of_int i | (i, SOME pis) => string_of_int i ^ "p"
  4.1509 -        ^ space_implode "p" (map string_of_int pis)) mode)
  4.1510 -    val HOmode = space_implode "_and_"
  4.1511 -      (fold (fn NONE => I | SOME mode => cons (string_of_mode mode)) (fst mode) [])
  4.1512 -  in
  4.1513 -    (Sign.full_bname thy (prefix ^ (Long_Name.base_name name))) ^
  4.1514 -      (if HOmode = "" then "_" else "_for_" ^ HOmode ^ "_yields_") ^ (string_of_mode (snd mode))
  4.1515 -  end;
  4.1516 -
  4.1517 -fun split_tupleT is T =
  4.1518 -	let
  4.1519 -		fun split_tuple' _ _ [] = ([], [])
  4.1520 -			| split_tuple' is i (T::Ts) =
  4.1521 -			(if i mem is then apfst else apsnd) (cons T)
  4.1522 -				(split_tuple' is (i+1) Ts)
  4.1523 -	in
  4.1524 -	  split_tuple' is 1 (HOLogic.strip_tupleT T)
  4.1525 -  end
  4.1526 -	
  4.1527 -fun mk_arg xin xout pis T =
  4.1528 -  let
  4.1529 -	  val n = length (HOLogic.strip_tupleT T)
  4.1530 -		val ni = length pis
  4.1531 -	  fun mk_proj i j t =
  4.1532 -		  (if i = j then I else HOLogic.mk_fst)
  4.1533 -			  (funpow (i - 1) HOLogic.mk_snd t)
  4.1534 -	  fun mk_arg' i (si, so) = if i mem pis then
  4.1535 -		    (mk_proj si ni xin, (si+1, so))
  4.1536 -		  else
  4.1537 -			  (mk_proj so (n - ni) xout, (si, so+1))
  4.1538 -	  val (args, _) = fold_map mk_arg' (1 upto n) (1, 1)
  4.1539 -	in
  4.1540 -	  HOLogic.mk_tuple args
  4.1541 -	end
  4.1542 -
  4.1543 -fun create_definitions preds (name, modes) thy =
  4.1544 -  let
  4.1545 -    val compfuns = PredicateCompFuns.compfuns
  4.1546 -    val T = AList.lookup (op =) preds name |> the
  4.1547 -    fun create_definition (mode as (iss, is)) thy = let
  4.1548 -      val mode_cname = create_constname_of_mode thy "" name mode
  4.1549 -      val mode_cbasename = Long_Name.base_name mode_cname
  4.1550 -      val Ts = binder_types T
  4.1551 -      val (Ts1, Ts2) = chop (length iss) Ts
  4.1552 -      val (Us1, Us2) =  split_smodeT is Ts2
  4.1553 -      val Ts1' = map2 (fn NONE => I | SOME is => funT_of compfuns ([], is)) iss Ts1
  4.1554 -      val funT = (Ts1' @ Us1) ---> (mk_predT compfuns (mk_tupleT Us2))
  4.1555 -      val names = Name.variant_list []
  4.1556 -        (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts)));
  4.1557 -			(* old *)
  4.1558 -			(*
  4.1559 -		  val xs = map Free (names ~~ (Ts1' @ Ts2))
  4.1560 -      val (xparams, xargs) = chop (length iss) xs
  4.1561 -      val (xins, xouts) = split_smode is xargs
  4.1562 -			*)
  4.1563 -			(* new *)
  4.1564 -			val param_names = Name.variant_list []
  4.1565 -			  (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts1')))
  4.1566 -		  val xparams = map Free (param_names ~~ Ts1')
  4.1567 -      fun mk_vars (i, T) names =
  4.1568 -			  let
  4.1569 -				  val vname = Name.variant names ("x" ^ string_of_int (length Ts1' + i))
  4.1570 -				in
  4.1571 -					case AList.lookup (op =) is i of
  4.1572 -						 NONE => ((([], [Free (vname, T)]), Free (vname, T)), vname :: names)
  4.1573 -					 | SOME NONE => ((([Free (vname, T)], []), Free (vname, T)), vname :: names)
  4.1574 -        	 | SOME (SOME pis) =>
  4.1575 -					   let
  4.1576 -						   val (Tins, Touts) = split_tupleT pis T
  4.1577 -							 val name_in = Name.variant names ("x" ^ string_of_int (length Ts1' + i) ^ "in")
  4.1578 -							 val name_out = Name.variant names ("x" ^ string_of_int (length Ts1' + i) ^ "out")
  4.1579 -						   val xin = Free (name_in, HOLogic.mk_tupleT Tins)
  4.1580 -							 val xout = Free (name_out, HOLogic.mk_tupleT Touts)
  4.1581 -							 val xarg = mk_arg xin xout pis T
  4.1582 -						 in (((if null Tins then [] else [xin], if null Touts then [] else [xout]), xarg), name_in :: name_out :: names) end
  4.1583 -						(* HOLogic.strip_tupleT T of
  4.1584 -						[] => 
  4.1585 -							in (Free (vname, T), vname :: names) end
  4.1586 -					| [_] => let val vname = Name.variant names ("x" ^ string_of_int (length Ts1' + i))
  4.1587 -							in (Free (vname, T), vname :: names) end
  4.1588 -					| Ts =>
  4.1589 -						let
  4.1590 -							val vnames = Name.variant_list names
  4.1591 -								(map (fn j => "x" ^ string_of_int (length Ts1' + i) ^ "p" ^ string_of_int j)
  4.1592 -									(1 upto (length Ts)))
  4.1593 -						 in (HOLogic.mk_tuple (map Free (vnames ~~ Ts)), vnames @ names) end *)
  4.1594 -				end
  4.1595 -   	  val (xinoutargs, names) = fold_map mk_vars ((1 upto (length Ts2)) ~~ Ts2) param_names
  4.1596 -      val (xinout, xargs) = split_list xinoutargs
  4.1597 -			val (xins, xouts) = pairself flat (split_list xinout)
  4.1598 -			(*val (xins, xouts) = split_smode is xargs*)
  4.1599 -			val (xparams', names') = fold_map mk_Eval_of ((xparams ~~ Ts1) ~~ iss) names
  4.1600 -			val _ = Output.tracing ("xargs:" ^ commas (map (Syntax.string_of_term_global thy) xargs))
  4.1601 -      fun mk_split_lambda [] t = lambda (Free (Name.variant names' "x", HOLogic.unitT)) t
  4.1602 -        | mk_split_lambda [x] t = lambda x t
  4.1603 -        | mk_split_lambda xs t =
  4.1604 -        let
  4.1605 -          fun mk_split_lambda' (x::y::[]) t = HOLogic.mk_split (lambda x (lambda y t))
  4.1606 -            | mk_split_lambda' (x::xs) t = HOLogic.mk_split (lambda x (mk_split_lambda' xs t))
  4.1607 -        in
  4.1608 -          mk_split_lambda' xs t
  4.1609 -        end;
  4.1610 -      val predterm = PredicateCompFuns.mk_Enum (mk_split_lambda xouts
  4.1611 -        (list_comb (Const (name, T), xparams' @ xargs)))
  4.1612 -      val lhs = list_comb (Const (mode_cname, funT), xparams @ xins)
  4.1613 -      val def = Logic.mk_equals (lhs, predterm)
  4.1614 -			val _ = Output.tracing ("def:" ^ (Syntax.string_of_term_global thy def))
  4.1615 -      val ([definition], thy') = thy |>
  4.1616 -        Sign.add_consts_i [(Binding.name mode_cbasename, funT, NoSyn)] |>
  4.1617 -        PureThy.add_defs false [((Binding.name (mode_cbasename ^ "_def"), def), [])]
  4.1618 -      val (intro, elim) =
  4.1619 -        create_intro_elim_rule mode definition mode_cname funT (Const (name, T)) thy'
  4.1620 -			val _ = Output.tracing (Display.string_of_thm_global thy' definition)
  4.1621 -      in thy'
  4.1622 -			  |> add_predfun name mode (mode_cname, definition, intro, elim)
  4.1623 -        |> PureThy.store_thm (Binding.name (mode_cbasename ^ "I"), intro) |> snd
  4.1624 -        |> PureThy.store_thm (Binding.name (mode_cbasename ^ "E"), elim)  |> snd
  4.1625 -        |> Theory.checkpoint
  4.1626 -      end;
  4.1627 -  in
  4.1628 -    fold create_definition modes thy
  4.1629 -  end;
  4.1630 -
  4.1631 -fun sizelim_create_definitions preds (name, modes) thy =
  4.1632 -  let
  4.1633 -    val T = AList.lookup (op =) preds name |> the
  4.1634 -    fun create_definition mode thy =
  4.1635 -      let
  4.1636 -        val mode_cname = create_constname_of_mode thy "sizelim_" name mode
  4.1637 -        val funT = sizelim_funT_of PredicateCompFuns.compfuns mode T
  4.1638 -      in
  4.1639 -        thy |> Sign.add_consts_i [(Binding.name (Long_Name.base_name mode_cname), funT, NoSyn)]
  4.1640 -        |> set_sizelim_function_name name mode mode_cname 
  4.1641 -      end;
  4.1642 -  in
  4.1643 -    fold create_definition modes thy
  4.1644 -  end;
  4.1645 -    
  4.1646 -fun rpred_create_definitions preds (name, modes) thy =
  4.1647 -  let
  4.1648 -    val T = AList.lookup (op =) preds name |> the
  4.1649 -    fun create_definition mode thy =
  4.1650 -      let
  4.1651 -        val mode_cname = create_constname_of_mode thy "gen_" name mode
  4.1652 -        val funT = sizelim_funT_of RPredCompFuns.compfuns mode T
  4.1653 -      in
  4.1654 -        thy |> Sign.add_consts_i [(Binding.name (Long_Name.base_name mode_cname), funT, NoSyn)]
  4.1655 -        |> set_generator_name name mode mode_cname 
  4.1656 -      end;
  4.1657 -  in
  4.1658 -    fold create_definition modes thy
  4.1659 -  end;
  4.1660 -  
  4.1661 -(* Proving equivalence of term *)
  4.1662 -
  4.1663 -fun is_Type (Type _) = true
  4.1664 -  | is_Type _ = false
  4.1665 -
  4.1666 -(* returns true if t is an application of an datatype constructor *)
  4.1667 -(* which then consequently would be splitted *)
  4.1668 -(* else false *)
  4.1669 -fun is_constructor thy t =
  4.1670 -  if (is_Type (fastype_of t)) then
  4.1671 -    (case Datatype.get_info thy ((fst o dest_Type o fastype_of) t) of
  4.1672 -      NONE => false
  4.1673 -    | SOME info => (let
  4.1674 -      val constr_consts = maps (fn (_, (_, _, constrs)) => map fst constrs) (#descr info)
  4.1675 -      val (c, _) = strip_comb t
  4.1676 -      in (case c of
  4.1677 -        Const (name, _) => name mem_string constr_consts
  4.1678 -        | _ => false) end))
  4.1679 -  else false
  4.1680 -
  4.1681 -(* MAJOR FIXME:  prove_params should be simple
  4.1682 - - different form of introrule for parameters ? *)
  4.1683 -fun prove_param thy (NONE, t) = TRY (rtac @{thm refl} 1)
  4.1684 -  | prove_param thy (m as SOME (Mode (mode, is, ms)), t) =
  4.1685 -  let
  4.1686 -    val  (f, args) = strip_comb (Envir.eta_contract t)
  4.1687 -    val (params, _) = chop (length ms) args
  4.1688 -    val f_tac = case f of
  4.1689 -      Const (name, T) => simp_tac (HOL_basic_ss addsimps 
  4.1690 -         ([@{thm eval_pred}, (predfun_definition_of thy name mode),
  4.1691 -         @{thm "split_eta"}, @{thm "split_beta"}, @{thm "fst_conv"},
  4.1692 -				 @{thm "snd_conv"}, @{thm pair_collapse}, @{thm "Product_Type.split_conv"}])) 1
  4.1693 -    | Free _ => TRY (rtac @{thm refl} 1)
  4.1694 -    | Abs _ => error "prove_param: No valid parameter term"
  4.1695 -  in
  4.1696 -    REPEAT_DETERM (etac @{thm thin_rl} 1)
  4.1697 -    THEN REPEAT_DETERM (rtac @{thm ext} 1)
  4.1698 -    THEN print_tac "prove_param"
  4.1699 -    THEN f_tac
  4.1700 -    THEN print_tac "after simplification in prove_args"
  4.1701 -    THEN (EVERY (map (prove_param thy) (ms ~~ params)))
  4.1702 -    THEN (REPEAT_DETERM (atac 1))
  4.1703 -  end
  4.1704 -
  4.1705 -fun prove_expr thy (Mode (mode, is, ms), t, us) (premposition : int) =
  4.1706 -  case strip_comb t of
  4.1707 -    (Const (name, T), args) =>  
  4.1708 -      let
  4.1709 -        val introrule = predfun_intro_of thy name mode
  4.1710 -        val (args1, args2) = chop (length ms) args
  4.1711 -      in
  4.1712 -        rtac @{thm bindI} 1
  4.1713 -        THEN print_tac "before intro rule:"
  4.1714 -        (* for the right assumption in first position *)
  4.1715 -        THEN rotate_tac premposition 1
  4.1716 -        THEN debug_tac (Display.string_of_thm (ProofContext.init thy) introrule)
  4.1717 -        THEN rtac introrule 1
  4.1718 -        THEN print_tac "after intro rule"
  4.1719 -        (* work with parameter arguments *)
  4.1720 -        THEN (atac 1)
  4.1721 -        THEN (print_tac "parameter goal")
  4.1722 -        THEN (EVERY (map (prove_param thy) (ms ~~ args1)))
  4.1723 -        THEN (REPEAT_DETERM (atac 1))
  4.1724 -      end
  4.1725 -  | _ => rtac @{thm bindI} 1
  4.1726 -	  THEN asm_full_simp_tac
  4.1727 -		  (HOL_basic_ss' addsimps [@{thm "split_eta"}, @{thm "split_beta"}, @{thm "fst_conv"},
  4.1728 -				 @{thm "snd_conv"}, @{thm pair_collapse}]) 1
  4.1729 -	  THEN (atac 1)
  4.1730 -	  THEN print_tac "after prove parameter call"
  4.1731 -		
  4.1732 -
  4.1733 -fun SOLVED tac st = FILTER (fn st' => nprems_of st' = nprems_of st - 1) tac st; 
  4.1734 -
  4.1735 -fun SOLVEDALL tac st = FILTER (fn st' => nprems_of st' = 0) tac st
  4.1736 -
  4.1737 -fun prove_match thy (out_ts : term list) = let
  4.1738 -  fun get_case_rewrite t =
  4.1739 -    if (is_constructor thy t) then let
  4.1740 -      val case_rewrites = (#case_rewrites (Datatype.the_info thy
  4.1741 -        ((fst o dest_Type o fastype_of) t)))
  4.1742 -      in case_rewrites @ (flat (map get_case_rewrite (snd (strip_comb t)))) end
  4.1743 -    else []
  4.1744 -  val simprules = @{thm "unit.cases"} :: @{thm "prod.cases"} :: (flat (map get_case_rewrite out_ts))
  4.1745 -(* replace TRY by determining if it necessary - are there equations when calling compile match? *)
  4.1746 -in
  4.1747 -   (* make this simpset better! *)
  4.1748 -  asm_full_simp_tac (HOL_basic_ss' addsimps simprules) 1
  4.1749 -  THEN print_tac "after prove_match:"
  4.1750 -  THEN (DETERM (TRY (EqSubst.eqsubst_tac (ProofContext.init thy) [0] [@{thm "HOL.if_P"}] 1
  4.1751 -         THEN (REPEAT_DETERM (rtac @{thm conjI} 1 THEN (SOLVED (asm_simp_tac HOL_basic_ss 1))))
  4.1752 -         THEN (SOLVED (asm_simp_tac HOL_basic_ss 1)))))
  4.1753 -  THEN print_tac "after if simplification"
  4.1754 -end;
  4.1755 -
  4.1756 -(* corresponds to compile_fun -- maybe call that also compile_sidecond? *)
  4.1757 -
  4.1758 -fun prove_sidecond thy modes t =
  4.1759 -  let
  4.1760 -    fun preds_of t nameTs = case strip_comb t of 
  4.1761 -      (f as Const (name, T), args) =>
  4.1762 -        if AList.defined (op =) modes name then (name, T) :: nameTs
  4.1763 -          else fold preds_of args nameTs
  4.1764 -      | _ => nameTs
  4.1765 -    val preds = preds_of t []
  4.1766 -    val defs = map
  4.1767 -      (fn (pred, T) => predfun_definition_of thy pred
  4.1768 -        ([], map (rpair NONE) (1 upto (length (binder_types T)))))
  4.1769 -        preds
  4.1770 -  in 
  4.1771 -    (* remove not_False_eq_True when simpset in prove_match is better *)
  4.1772 -    simp_tac (HOL_basic_ss addsimps
  4.1773 -      (@{thms "HOL.simp_thms"} @ (@{thm not_False_eq_True} :: @{thm eval_pred} :: defs))) 1 
  4.1774 -    (* need better control here! *)
  4.1775 -  end
  4.1776 -
  4.1777 -fun prove_clause thy nargs modes (iss, is) (_, clauses) (ts, moded_ps) =
  4.1778 -  let
  4.1779 -    val (in_ts, clause_out_ts) = split_smode is ts;
  4.1780 -    fun prove_prems out_ts [] =
  4.1781 -      (prove_match thy out_ts)
  4.1782 -			THEN print_tac "before simplifying assumptions"
  4.1783 -      THEN asm_full_simp_tac HOL_basic_ss' 1
  4.1784 -			THEN print_tac "before single intro rule"
  4.1785 -      THEN (rtac (if null clause_out_ts then @{thm singleI_unit} else @{thm singleI}) 1)
  4.1786 -    | prove_prems out_ts ((p, mode as Mode ((iss, is), _, param_modes)) :: ps) =
  4.1787 -      let
  4.1788 -        val premposition = (find_index (equal p) clauses) + nargs
  4.1789 -        val rest_tac = (case p of Prem (us, t) =>
  4.1790 -            let
  4.1791 -              val (_, out_ts''') = split_smode is us
  4.1792 -              val rec_tac = prove_prems out_ts''' ps
  4.1793 -            in
  4.1794 -              print_tac "before clause:"
  4.1795 -              THEN asm_simp_tac HOL_basic_ss 1
  4.1796 -              THEN print_tac "before prove_expr:"
  4.1797 -              THEN prove_expr thy (mode, t, us) premposition
  4.1798 -              THEN print_tac "after prove_expr:"
  4.1799 -              THEN rec_tac
  4.1800 -            end
  4.1801 -          | Negprem (us, t) =>
  4.1802 -            let
  4.1803 -              val (_, out_ts''') = split_smode is us
  4.1804 -              val rec_tac = prove_prems out_ts''' ps
  4.1805 -              val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE)
  4.1806 -              val (_, params) = strip_comb t
  4.1807 -            in
  4.1808 -              rtac @{thm bindI} 1
  4.1809 -              THEN (if (is_some name) then
  4.1810 -                  simp_tac (HOL_basic_ss addsimps [predfun_definition_of thy (the name) (iss, is)]) 1
  4.1811 -                  THEN rtac @{thm not_predI} 1
  4.1812 -                  THEN simp_tac (HOL_basic_ss addsimps [@{thm not_False_eq_True}]) 1
  4.1813 -                  THEN (REPEAT_DETERM (atac 1))
  4.1814 -                  (* FIXME: work with parameter arguments *)
  4.1815 -                  THEN (EVERY (map (prove_param thy) (param_modes ~~ params)))
  4.1816 -                else
  4.1817 -                  rtac @{thm not_predI'} 1)
  4.1818 -                  THEN simp_tac (HOL_basic_ss addsimps [@{thm not_False_eq_True}]) 1
  4.1819 -              THEN rec_tac
  4.1820 -            end
  4.1821 -          | Sidecond t =>
  4.1822 -           rtac @{thm bindI} 1
  4.1823 -           THEN rtac @{thm if_predI} 1
  4.1824 -           THEN print_tac "before sidecond:"
  4.1825 -           THEN prove_sidecond thy modes t
  4.1826 -           THEN print_tac "after sidecond:"
  4.1827 -           THEN prove_prems [] ps)
  4.1828 -      in (prove_match thy out_ts)
  4.1829 -          THEN rest_tac
  4.1830 -      end;
  4.1831 -    val prems_tac = prove_prems in_ts moded_ps
  4.1832 -  in
  4.1833 -    rtac @{thm bindI} 1
  4.1834 -    THEN rtac @{thm singleI} 1
  4.1835 -    THEN prems_tac
  4.1836 -  end;
  4.1837 -
  4.1838 -fun select_sup 1 1 = []
  4.1839 -  | select_sup _ 1 = [rtac @{thm supI1}]
  4.1840 -  | select_sup n i = (rtac @{thm supI2})::(select_sup (n - 1) (i - 1));
  4.1841 -
  4.1842 -fun prove_one_direction thy clauses preds modes pred mode moded_clauses =
  4.1843 -  let
  4.1844 -    val T = the (AList.lookup (op =) preds pred)
  4.1845 -    val nargs = length (binder_types T) - nparams_of thy pred
  4.1846 -    val pred_case_rule = the_elim_of thy pred
  4.1847 -  in
  4.1848 -    REPEAT_DETERM (CHANGED (rewtac @{thm "split_paired_all"}))
  4.1849 -		THEN print_tac "before applying elim rule"
  4.1850 -    THEN etac (predfun_elim_of thy pred mode) 1
  4.1851 -    THEN etac pred_case_rule 1
  4.1852 -    THEN (EVERY (map
  4.1853 -           (fn i => EVERY' (select_sup (length moded_clauses) i) i) 
  4.1854 -             (1 upto (length moded_clauses))))
  4.1855 -    THEN (EVERY (map2 (prove_clause thy nargs modes mode) clauses moded_clauses))
  4.1856 -    THEN print_tac "proved one direction"
  4.1857 -  end;
  4.1858 -
  4.1859 -(** Proof in the other direction **)
  4.1860 -
  4.1861 -fun prove_match2 thy out_ts = let
  4.1862 -  fun split_term_tac (Free _) = all_tac
  4.1863 -    | split_term_tac t =
  4.1864 -      if (is_constructor thy t) then let
  4.1865 -        val info = Datatype.the_info thy ((fst o dest_Type o fastype_of) t)
  4.1866 -        val num_of_constrs = length (#case_rewrites info)
  4.1867 -        (* special treatment of pairs -- because of fishing *)
  4.1868 -        val split_rules = case (fst o dest_Type o fastype_of) t of
  4.1869 -          "*" => [@{thm prod.split_asm}] 
  4.1870 -          | _ => PureThy.get_thms thy (((fst o dest_Type o fastype_of) t) ^ ".split_asm")
  4.1871 -        val (_, ts) = strip_comb t
  4.1872 -      in
  4.1873 -        (Splitter.split_asm_tac split_rules 1)
  4.1874 -(*        THEN (Simplifier.asm_full_simp_tac HOL_basic_ss 1)
  4.1875 -          THEN (DETERM (TRY (etac @{thm Pair_inject} 1))) *)
  4.1876 -        THEN (REPEAT_DETERM_N (num_of_constrs - 1) (etac @{thm botE} 1 ORELSE etac @{thm botE} 2))
  4.1877 -        THEN (EVERY (map split_term_tac ts))
  4.1878 -      end
  4.1879 -    else all_tac
  4.1880 -  in
  4.1881 -    split_term_tac (mk_tuple out_ts)
  4.1882 -    THEN (DETERM (TRY ((Splitter.split_asm_tac [@{thm "split_if_asm"}] 1) THEN (etac @{thm botE} 2))))
  4.1883 -  end
  4.1884 -
  4.1885 -(* VERY LARGE SIMILIRATIY to function prove_param 
  4.1886 --- join both functions
  4.1887 -*)
  4.1888 -(* TODO: remove function *)
  4.1889 -
  4.1890 -fun prove_param2 thy (NONE, t) = all_tac 
  4.1891 -  | prove_param2 thy (m as SOME (Mode (mode, is, ms)), t) = let
  4.1892 -    val  (f, args) = strip_comb (Envir.eta_contract t)
  4.1893 -    val (params, _) = chop (length ms) args
  4.1894 -    val f_tac = case f of
  4.1895 -        Const (name, T) => full_simp_tac (HOL_basic_ss addsimps 
  4.1896 -           (@{thm eval_pred}::(predfun_definition_of thy name mode)
  4.1897 -           :: @{thm "Product_Type.split_conv"}::[])) 1
  4.1898 -      | Free _ => all_tac
  4.1899 -      | _ => error "prove_param2: illegal parameter term"
  4.1900 -  in  
  4.1901 -    print_tac "before simplification in prove_args:"
  4.1902 -    THEN f_tac
  4.1903 -    THEN print_tac "after simplification in prove_args"
  4.1904 -    THEN (EVERY (map (prove_param2 thy) (ms ~~ params)))
  4.1905 -  end
  4.1906 -
  4.1907 -
  4.1908 -fun prove_expr2 thy (Mode (mode, is, ms), t) = 
  4.1909 -  (case strip_comb t of
  4.1910 -    (Const (name, T), args) =>
  4.1911 -      etac @{thm bindE} 1
  4.1912 -      THEN (REPEAT_DETERM (CHANGED (rewtac @{thm "split_paired_all"})))
  4.1913 -      THEN print_tac "prove_expr2-before"
  4.1914 -      THEN (debug_tac (Syntax.string_of_term_global thy
  4.1915 -        (prop_of (predfun_elim_of thy name mode))))
  4.1916 -      THEN (etac (predfun_elim_of thy name mode) 1)
  4.1917 -      THEN print_tac "prove_expr2"
  4.1918 -      THEN (EVERY (map (prove_param2 thy) (ms ~~ args)))
  4.1919 -      THEN print_tac "finished prove_expr2"      
  4.1920 -    | _ => etac @{thm bindE} 1)
  4.1921 -    
  4.1922 -(* FIXME: what is this for? *)
  4.1923 -(* replace defined by has_mode thy pred *)
  4.1924 -(* TODO: rewrite function *)
  4.1925 -fun prove_sidecond2 thy modes t = let
  4.1926 -  fun preds_of t nameTs = case strip_comb t of 
  4.1927 -    (f as Const (name, T), args) =>
  4.1928 -      if AList.defined (op =) modes name then (name, T) :: nameTs
  4.1929 -        else fold preds_of args nameTs
  4.1930 -    | _ => nameTs
  4.1931 -  val preds = preds_of t []
  4.1932 -  val defs = map
  4.1933 -    (fn (pred, T) => predfun_definition_of thy pred 
  4.1934 -      ([], map (rpair NONE) (1 upto (length (binder_types T)))))
  4.1935 -      preds
  4.1936 -  in
  4.1937 -   (* only simplify the one assumption *)
  4.1938 -   full_simp_tac (HOL_basic_ss' addsimps @{thm eval_pred} :: defs) 1 
  4.1939 -   (* need better control here! *)
  4.1940 -   THEN print_tac "after sidecond2 simplification"
  4.1941 -   end
  4.1942 -  
  4.1943 -fun prove_clause2 thy modes pred (iss, is) (ts, ps) i =
  4.1944 -  let
  4.1945 -    val pred_intro_rule = nth (intros_of thy pred) (i - 1)
  4.1946 -    val (in_ts, clause_out_ts) = split_smode is ts;
  4.1947 -    fun prove_prems2 out_ts [] =
  4.1948 -      print_tac "before prove_match2 - last call:"
  4.1949 -      THEN prove_match2 thy out_ts
  4.1950 -      THEN print_tac "after prove_match2 - last call:"
  4.1951 -      THEN (etac @{thm singleE} 1)
  4.1952 -      THEN (REPEAT_DETERM (etac @{thm Pair_inject} 1))
  4.1953 -      THEN (asm_full_simp_tac HOL_basic_ss' 1)
  4.1954 -      THEN (REPEAT_DETERM (etac @{thm Pair_inject} 1))
  4.1955 -      THEN (asm_full_simp_tac HOL_basic_ss' 1)
  4.1956 -      THEN SOLVED (print_tac "state before applying intro rule:"
  4.1957 -      THEN (rtac pred_intro_rule 1)
  4.1958 -      (* How to handle equality correctly? *)
  4.1959 -      THEN (print_tac "state before assumption matching")
  4.1960 -      THEN (REPEAT (atac 1 ORELSE 
  4.1961 -         (CHANGED (asm_full_simp_tac (HOL_basic_ss' addsimps
  4.1962 -					 [@{thm split_eta}, @{thm "split_beta"}, @{thm "fst_conv"}, @{thm "snd_conv"}, @{thm pair_collapse}]) 1)
  4.1963 -          THEN print_tac "state after simp_tac:"))))
  4.1964 -    | prove_prems2 out_ts ((p, mode as Mode ((iss, is), _, param_modes)) :: ps) =
  4.1965 -      let
  4.1966 -        val rest_tac = (case p of
  4.1967 -          Prem (us, t) =>
  4.1968 -          let
  4.1969 -            val (_, out_ts''') = split_smode is us
  4.1970 -            val rec_tac = prove_prems2 out_ts''' ps
  4.1971 -          in
  4.1972 -            (prove_expr2 thy (mode, t)) THEN rec_tac
  4.1973 -          end
  4.1974 -        | Negprem (us, t) =>
  4.1975 -          let
  4.1976 -            val (_, out_ts''') = split_smode is us
  4.1977 -            val rec_tac = prove_prems2 out_ts''' ps
  4.1978 -            val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE)
  4.1979 -            val (_, params) = strip_comb t
  4.1980 -          in
  4.1981 -            print_tac "before neg prem 2"
  4.1982 -            THEN etac @{thm bindE} 1
  4.1983 -            THEN (if is_some name then
  4.1984 -                full_simp_tac (HOL_basic_ss addsimps [predfun_definition_of thy (the name) (iss, is)]) 1 
  4.1985 -                THEN etac @{thm not_predE} 1
  4.1986 -                THEN simp_tac (HOL_basic_ss addsimps [@{thm not_False_eq_True}]) 1
  4.1987 -                THEN (EVERY (map (prove_param2 thy) (param_modes ~~ params)))
  4.1988 -              else
  4.1989 -                etac @{thm not_predE'} 1)
  4.1990 -            THEN rec_tac
  4.1991 -          end 
  4.1992 -        | Sidecond t =>
  4.1993 -          etac @{thm bindE} 1
  4.1994 -          THEN etac @{thm if_predE} 1
  4.1995 -          THEN prove_sidecond2 thy modes t 
  4.1996 -          THEN prove_prems2 [] ps)
  4.1997 -      in print_tac "before prove_match2:"
  4.1998 -         THEN prove_match2 thy out_ts
  4.1999 -         THEN print_tac "after prove_match2:"
  4.2000 -         THEN rest_tac
  4.2001 -      end;
  4.2002 -    val prems_tac = prove_prems2 in_ts ps 
  4.2003 -  in
  4.2004 -    print_tac "starting prove_clause2"
  4.2005 -    THEN etac @{thm bindE} 1
  4.2006 -    THEN (etac @{thm singleE'} 1)
  4.2007 -    THEN (TRY (etac @{thm Pair_inject} 1))
  4.2008 -    THEN print_tac "after singleE':"
  4.2009 -    THEN prems_tac
  4.2010 -  end;
  4.2011 - 
  4.2012 -fun prove_other_direction thy modes pred mode moded_clauses =
  4.2013 -  let
  4.2014 -    fun prove_clause clause i =
  4.2015 -      (if i < length moded_clauses then etac @{thm supE} 1 else all_tac)
  4.2016 -      THEN (prove_clause2 thy modes pred mode clause i)
  4.2017 -  in
  4.2018 -    (DETERM (TRY (rtac @{thm unit.induct} 1)))
  4.2019 -     THEN (REPEAT_DETERM (CHANGED (rewtac @{thm split_paired_all})))
  4.2020 -     THEN (rtac (predfun_intro_of thy pred mode) 1)
  4.2021 -     THEN (REPEAT_DETERM (rtac @{thm refl} 2))
  4.2022 -     THEN (EVERY (map2 prove_clause moded_clauses (1 upto (length moded_clauses))))
  4.2023 -  end;
  4.2024 -
  4.2025 -(** proof procedure **)
  4.2026 -
  4.2027 -fun prove_pred thy clauses preds modes pred mode (moded_clauses, compiled_term) =
  4.2028 -  let
  4.2029 -    val ctxt = ProofContext.init thy
  4.2030 -    val clauses = the (AList.lookup (op =) clauses pred)
  4.2031 -  in
  4.2032 -    Goal.prove ctxt (Term.add_free_names compiled_term []) [] compiled_term
  4.2033 -      (if !do_proofs then
  4.2034 -        (fn _ =>
  4.2035 -        rtac @{thm pred_iffI} 1
  4.2036 -				THEN print_tac "after pred_iffI"
  4.2037 -        THEN prove_one_direction thy clauses preds modes pred mode moded_clauses
  4.2038 -        THEN print_tac "proved one direction"
  4.2039 -        THEN prove_other_direction thy modes pred mode moded_clauses
  4.2040 -        THEN print_tac "proved other direction")
  4.2041 -       else (fn _ => mycheat_tac thy 1))
  4.2042 -  end;
  4.2043 -
  4.2044 -(* composition of mode inference, definition, compilation and proof *)
  4.2045 -
  4.2046 -(** auxillary combinators for table of preds and modes **)
  4.2047 -
  4.2048 -fun map_preds_modes f preds_modes_table =
  4.2049 -  map (fn (pred, modes) =>
  4.2050 -    (pred, map (fn (mode, value) => (mode, f pred mode value)) modes)) preds_modes_table
  4.2051 -
  4.2052 -fun join_preds_modes table1 table2 =
  4.2053 -  map_preds_modes (fn pred => fn mode => fn value =>
  4.2054 -    (value, the (AList.lookup (op =) (the (AList.lookup (op =) table2 pred)) mode))) table1
  4.2055 -    
  4.2056 -fun maps_modes preds_modes_table =
  4.2057 -  map (fn (pred, modes) =>
  4.2058 -    (pred, map (fn (mode, value) => value) modes)) preds_modes_table  
  4.2059 -    
  4.2060 -fun compile_preds compfuns mk_fun_of use_size thy all_vs param_vs preds moded_clauses =
  4.2061 -  map_preds_modes (fn pred => compile_pred compfuns mk_fun_of use_size thy all_vs param_vs pred
  4.2062 -      (the (AList.lookup (op =) preds pred))) moded_clauses  
  4.2063 -  
  4.2064 -fun prove thy clauses preds modes moded_clauses compiled_terms =
  4.2065 -  map_preds_modes (prove_pred thy clauses preds modes)
  4.2066 -    (join_preds_modes moded_clauses compiled_terms)
  4.2067 -
  4.2068 -fun prove_by_skip thy _ _ _ _ compiled_terms =
  4.2069 -  map_preds_modes (fn pred => fn mode => fn t => Drule.standard (SkipProof.make_thm thy t))
  4.2070 -    compiled_terms
  4.2071 -    
  4.2072 -fun prepare_intrs thy prednames =
  4.2073 -  let
  4.2074 -    val intrs = maps (intros_of thy) prednames
  4.2075 -      |> map (Logic.unvarify o prop_of)
  4.2076 -    val nparams = nparams_of thy (hd prednames)
  4.2077 -    val extra_modes = all_modes_of thy |> filter_out (fn (name, _) => member (op =) prednames name)
  4.2078 -    val preds = distinct (op =) (map (dest_Const o fst o (strip_intro_concl nparams)) intrs)
  4.2079 -    val _ $ u = Logic.strip_imp_concl (hd intrs);
  4.2080 -    val params = List.take (snd (strip_comb u), nparams);
  4.2081 -    val param_vs = maps term_vs params
  4.2082 -    val all_vs = terms_vs intrs
  4.2083 -    fun dest_prem t =
  4.2084 -      (case strip_comb t of
  4.2085 -        (v as Free _, ts) => if v mem params then Prem (ts, v) else Sidecond t
  4.2086 -      | (c as Const (@{const_name Not}, _), [t]) => (case dest_prem t of          
  4.2087 -          Prem (ts, t) => Negprem (ts, t)
  4.2088 -        | Negprem _ => error ("Double negation not allowed in premise: " ^ (Syntax.string_of_term_global thy (c $ t))) 
  4.2089 -        | Sidecond t => Sidecond (c $ t))
  4.2090 -      | (c as Const (s, _), ts) =>
  4.2091 -        if is_registered thy s then
  4.2092 -          let val (ts1, ts2) = chop (nparams_of thy s) ts
  4.2093 -          in Prem (ts2, list_comb (c, ts1)) end
  4.2094 -        else Sidecond t
  4.2095 -      | _ => Sidecond t)
  4.2096 -    fun add_clause intr (clauses, arities) =
  4.2097 -    let
  4.2098 -      val _ $ t = Logic.strip_imp_concl intr;
  4.2099 -      val (Const (name, T), ts) = strip_comb t;
  4.2100 -      val (ts1, ts2) = chop nparams ts;
  4.2101 -      val prems = map (dest_prem o HOLogic.dest_Trueprop) (Logic.strip_imp_prems intr);
  4.2102 -      val (Ts, Us) = chop nparams (binder_types T)
  4.2103 -    in
  4.2104 -      (AList.update op = (name, these (AList.lookup op = clauses name) @
  4.2105 -        [(ts2, prems)]) clauses,
  4.2106 -       AList.update op = (name, (map (fn U => (case strip_type U of
  4.2107 -                 (Rs as _ :: _, Type ("bool", [])) => SOME (length Rs)
  4.2108 -               | _ => NONE)) Ts,
  4.2109 -             length Us)) arities)
  4.2110 -    end;
  4.2111 -    val (clauses, arities) = fold add_clause intrs ([], []);
  4.2112 -    fun modes_of_arities arities =
  4.2113 -      (map (fn (s, (ks, k)) => (s, cprod (cprods (map
  4.2114 -            (fn NONE => [NONE]
  4.2115 -              | SOME k' => map SOME (map (map (rpair NONE)) (subsets 1 k'))) ks),
  4.2116 -       map (map (rpair NONE)) (subsets 1 k)))) arities)
  4.2117 -    fun modes_of_typ T =
  4.2118 -      let
  4.2119 -        val (Ts, Us) = chop nparams (binder_types T)
  4.2120 -        fun all_smodes_of_typs Ts = cprods_subset (
  4.2121 -          map_index (fn (i, U) =>
  4.2122 -            case HOLogic.strip_tupleT U of
  4.2123 -              [] => [(i + 1, NONE)]
  4.2124 -            | [U] => [(i + 1, NONE)]
  4.2125 -	    | Us =>  map (pair (i + 1) o SOME) ((subsets 1 (length Us)) \\ [[], 1 upto (length Us)]))
  4.2126 -          Ts)
  4.2127 -      in
  4.2128 -        cprod (cprods (map (fn T => case strip_type T of
  4.2129 -          (Rs as _ :: _, Type ("bool", [])) => map SOME (all_smodes_of_typs Rs) | _ => [NONE]) Ts),
  4.2130 -           all_smodes_of_typs Us)
  4.2131 -      end
  4.2132 -    val all_modes = map (fn (s, T) => (s, modes_of_typ T)) preds
  4.2133 -  in (preds, nparams, all_vs, param_vs, extra_modes, clauses, all_modes) end;
  4.2134 -
  4.2135 -(** main function of predicate compiler **)
  4.2136 -
  4.2137 -fun add_equations_of steps prednames thy =
  4.2138 -  let
  4.2139 -    val _ = Output.tracing ("Starting predicate compiler for predicates " ^ commas prednames ^ "...")
  4.2140 -    val (preds, nparams, all_vs, param_vs, extra_modes, clauses, all_modes) =
  4.2141 -      prepare_intrs thy prednames
  4.2142 -    val _ = Output.tracing "Infering modes..."
  4.2143 -    val moded_clauses = #infer_modes steps thy extra_modes all_modes param_vs clauses 
  4.2144 -    val modes = map (fn (p, mps) => (p, map fst mps)) moded_clauses
  4.2145 -    val _ = print_modes modes
  4.2146 -    val _ = print_moded_clauses thy moded_clauses
  4.2147 -    val _ = Output.tracing "Defining executable functions..."
  4.2148 -    val thy' = fold (#create_definitions steps preds) modes thy
  4.2149 -      |> Theory.checkpoint
  4.2150 -    val _ = Output.tracing "Compiling equations..."
  4.2151 -    val compiled_terms =
  4.2152 -      (#compile_preds steps) thy' all_vs param_vs preds moded_clauses
  4.2153 -    val _ = print_compiled_terms thy' compiled_terms
  4.2154 -    val _ = Output.tracing "Proving equations..."
  4.2155 -    val result_thms = #prove steps thy' clauses preds (extra_modes @ modes)
  4.2156 -      moded_clauses compiled_terms
  4.2157 -    val qname = #qname steps
  4.2158 -    (* val attrib = gn thy => Attrib.attribute_i thy Code.add_eqn_attrib *)
  4.2159 -    val attrib = fn thy => Attrib.attribute_i thy (Attrib.internal (K (Thm.declaration_attribute
  4.2160 -      (fn thm => Context.mapping (Code.add_eqn thm) I))))
  4.2161 -    val thy'' = fold (fn (name, result_thms) => fn thy => snd (PureThy.add_thmss
  4.2162 -      [((Binding.qualify true (Long_Name.base_name name) (Binding.name qname), result_thms),
  4.2163 -        [attrib thy ])] thy))
  4.2164 -      (maps_modes result_thms) thy'
  4.2165 -      |> Theory.checkpoint
  4.2166 -  in
  4.2167 -    thy''
  4.2168 -  end
  4.2169 -
  4.2170 -fun extend' value_of edges_of key (G, visited) =
  4.2171 -  let
  4.2172 -    val (G', v) = case try (Graph.get_node G) key of
  4.2173 -        SOME v => (G, v)
  4.2174 -      | NONE => (Graph.new_node (key, value_of key) G, value_of key)
  4.2175 -    val (G'', visited') = fold (extend' value_of edges_of) (edges_of (key, v) \\ visited)
  4.2176 -      (G', key :: visited) 
  4.2177 -  in
  4.2178 -    (fold (Graph.add_edge o (pair key)) (edges_of (key, v)) G'', visited')
  4.2179 -  end;
  4.2180 -
  4.2181 -fun extend value_of edges_of key G = fst (extend' value_of edges_of key (G, [])) 
  4.2182 -  
  4.2183 -fun gen_add_equations steps names thy =
  4.2184 -  let
  4.2185 -    val thy' = PredData.map (fold (extend (fetch_pred_data thy) (depending_preds_of thy)) names) thy
  4.2186 -      |> Theory.checkpoint;
  4.2187 -    fun strong_conn_of gr keys =
  4.2188 -      Graph.strong_conn (Graph.subgraph (member (op =) (Graph.all_succs gr keys)) gr)
  4.2189 -    val scc = strong_conn_of (PredData.get thy') names
  4.2190 -    val thy'' = fold_rev
  4.2191 -      (fn preds => fn thy =>
  4.2192 -        if #are_not_defined steps thy preds then add_equations_of steps preds thy else thy)
  4.2193 -      scc thy' |> Theory.checkpoint
  4.2194 -  in thy'' end
  4.2195 -
  4.2196 -(* different instantiantions of the predicate compiler *)
  4.2197 -
  4.2198 -val add_equations = gen_add_equations
  4.2199 -  {infer_modes = infer_modes,
  4.2200 -  create_definitions = create_definitions,
  4.2201 -  compile_preds = compile_preds PredicateCompFuns.compfuns mk_fun_of false,
  4.2202 -  prove = prove,
  4.2203 -  are_not_defined = (fn thy => forall (null o modes_of thy)),
  4.2204 -  qname = "equation"}
  4.2205 -
  4.2206 -val add_sizelim_equations = gen_add_equations
  4.2207 -  {infer_modes = infer_modes,
  4.2208 -  create_definitions = sizelim_create_definitions,
  4.2209 -  compile_preds = compile_preds PredicateCompFuns.compfuns mk_sizelim_fun_of true,
  4.2210 -  prove = prove_by_skip,
  4.2211 -  are_not_defined = (fn thy => fn preds => true), (* TODO *)
  4.2212 -  qname = "sizelim_equation"
  4.2213 -  }
  4.2214 -
  4.2215 -val add_quickcheck_equations = gen_add_equations
  4.2216 -  {infer_modes = infer_modes_with_generator,
  4.2217 -  create_definitions = rpred_create_definitions,
  4.2218 -  compile_preds = compile_preds RPredCompFuns.compfuns mk_generator_of true,
  4.2219 -  prove = prove_by_skip,
  4.2220 -  are_not_defined = (fn thy => fn preds => true), (* TODO *)
  4.2221 -  qname = "rpred_equation"}
  4.2222 -
  4.2223 -(** user interface **)
  4.2224 -
  4.2225 -(* generation of case rules from user-given introduction rules *)
  4.2226 -
  4.2227 -fun mk_casesrule ctxt nparams introrules =
  4.2228 -  let
  4.2229 -    val intros = map (Logic.unvarify o prop_of) introrules
  4.2230 -    val (pred, (params, args)) = strip_intro_concl nparams (hd intros)
  4.2231 -    val ([propname], ctxt1) = Variable.variant_fixes ["thesis"] ctxt
  4.2232 -    val prop = HOLogic.mk_Trueprop (Free (propname, HOLogic.boolT))
  4.2233 -    val (argnames, ctxt2) = Variable.variant_fixes
  4.2234 -      (map (fn i => "a" ^ string_of_int i) (1 upto (length args))) ctxt1
  4.2235 -    val argvs = map2 (curry Free) argnames (map fastype_of args)
  4.2236 -    fun mk_case intro =
  4.2237 -      let
  4.2238 -        val (_, (_, args)) = strip_intro_concl nparams intro
  4.2239 -        val prems = Logic.strip_imp_prems intro
  4.2240 -        val eqprems = map (HOLogic.mk_Trueprop o HOLogic.mk_eq) (argvs ~~ args)
  4.2241 -        val frees = (fold o fold_aterms)
  4.2242 -          (fn t as Free _ =>
  4.2243 -              if member (op aconv) params t then I else insert (op aconv) t
  4.2244 -           | _ => I) (args @ prems) []
  4.2245 -      in fold Logic.all frees (Logic.list_implies (eqprems @ prems, prop)) end
  4.2246 -    val assm = HOLogic.mk_Trueprop (list_comb (pred, params @ argvs))
  4.2247 -    val cases = map mk_case intros
  4.2248 -  in Logic.list_implies (assm :: cases, prop) end;
  4.2249 -
  4.2250 -(* code_pred_intro attribute *)
  4.2251 -
  4.2252 -fun attrib f = Thm.declaration_attribute (fn thm => Context.mapping (f thm) I);
  4.2253 -
  4.2254 -val code_pred_intros_attrib = attrib add_intro;
  4.2255 -
  4.2256 -local
  4.2257 -
  4.2258 -(* TODO: make TheoryDataFun to GenericDataFun & remove duplication of local theory and theory *)
  4.2259 -fun generic_code_pred prep_const raw_const lthy =
  4.2260 -  let
  4.2261 -    val thy = ProofContext.theory_of lthy
  4.2262 -    val const = prep_const thy raw_const
  4.2263 -    val lthy' = LocalTheory.theory (PredData.map
  4.2264 -        (extend (fetch_pred_data thy) (depending_preds_of thy) const)) lthy
  4.2265 -      |> LocalTheory.checkpoint
  4.2266 -    val thy' = ProofContext.theory_of lthy'
  4.2267 -    val preds = Graph.all_preds (PredData.get thy') [const] |> filter_out (has_elim thy')
  4.2268 -    fun mk_cases const =
  4.2269 -      let
  4.2270 -        val nparams = nparams_of thy' const
  4.2271 -        val intros = intros_of thy' const
  4.2272 -      in mk_casesrule lthy' nparams intros end  
  4.2273 -    val cases_rules = map mk_cases preds
  4.2274 -    val cases =
  4.2275 -      map (fn case_rule => RuleCases.Case {fixes = [],
  4.2276 -        assumes = [("", Logic.strip_imp_prems case_rule)],
  4.2277 -        binds = [], cases = []}) cases_rules
  4.2278 -    val case_env = map2 (fn p => fn c => (Long_Name.base_name p, SOME c)) preds cases
  4.2279 -    val lthy'' = lthy'
  4.2280 -      |> fold Variable.auto_fixes cases_rules 
  4.2281 -      |> ProofContext.add_cases true case_env
  4.2282 -    fun after_qed thms goal_ctxt =
  4.2283 -      let
  4.2284 -        val global_thms = ProofContext.export goal_ctxt
  4.2285 -          (ProofContext.init (ProofContext.theory_of goal_ctxt)) (map the_single thms)
  4.2286 -      in
  4.2287 -        goal_ctxt |> LocalTheory.theory (fold set_elim global_thms #> add_equations [const])
  4.2288 -      end  
  4.2289 -  in
  4.2290 -    Proof.theorem_i NONE after_qed (map (single o (rpair [])) cases_rules) lthy''
  4.2291 -  end;
  4.2292 -
  4.2293 -structure P = OuterParse
  4.2294 -
  4.2295 -in
  4.2296 -
  4.2297 -val code_pred = generic_code_pred (K I);
  4.2298 -val code_pred_cmd = generic_code_pred Code.read_const
  4.2299 -
  4.2300 -val setup = PredData.put (Graph.empty) #>
  4.2301 -  Attrib.setup @{binding code_pred_intros} (Scan.succeed (attrib add_intro))
  4.2302 -    "adding alternative introduction rules for code generation of inductive predicates"
  4.2303 -(*  Attrib.setup @{binding code_ind_cases} (Scan.succeed add_elim_attrib)
  4.2304 -    "adding alternative elimination rules for code generation of inductive predicates";
  4.2305 -    *)
  4.2306 -  (*FIXME name discrepancy in attribs and ML code*)
  4.2307 -  (*FIXME intros should be better named intro*)
  4.2308 -  (*FIXME why distinguished attribute for cases?*)
  4.2309 -
  4.2310 -val _ = OuterSyntax.local_theory_to_proof "code_pred"
  4.2311 -  "prove equations for predicate specified by intro/elim rules"
  4.2312 -  OuterKeyword.thy_goal (P.term_group >> code_pred_cmd)
  4.2313 -
  4.2314 -end
  4.2315 -
  4.2316 -(*FIXME
  4.2317 -- Naming of auxiliary rules necessary?
  4.2318 -- add default code equations P x y z = P_i_i_i x y z
  4.2319 -*)
  4.2320 -
  4.2321 -(* transformation for code generation *)
  4.2322 -
  4.2323 -val eval_ref = ref (NONE : (unit -> term Predicate.pred) option);
  4.2324 -
  4.2325 -(*FIXME turn this into an LCF-guarded preprocessor for comprehensions*)
  4.2326 -fun analyze_compr thy t_compr =
  4.2327 -  let
  4.2328 -    val split = case t_compr of (Const (@{const_name Collect}, _) $ t) => t
  4.2329 -      | _ => error ("Not a set comprehension: " ^ Syntax.string_of_term_global thy t_compr);
  4.2330 -    val (body, Ts, fp) = HOLogic.strip_psplits split;
  4.2331 -    val (pred as Const (name, T), all_args) = strip_comb body;
  4.2332 -    val (params, args) = chop (nparams_of thy name) all_args;
  4.2333 -    val user_mode = map_filter I (map_index
  4.2334 -      (fn (i, t) => case t of Bound j => if j < length Ts then NONE
  4.2335 -        else SOME (i+1) | _ => SOME (i+1)) args); (*FIXME dangling bounds should not occur*)
  4.2336 -    val user_mode' = map (rpair NONE) user_mode
  4.2337 -    val modes = filter (fn Mode (_, is, _) => is = user_mode')
  4.2338 -      (modes_of_term (all_modes_of thy) (list_comb (pred, params)));
  4.2339 -    val m = case modes
  4.2340 -     of [] => error ("No mode possible for comprehension "
  4.2341 -                ^ Syntax.string_of_term_global thy t_compr)
  4.2342 -      | [m] => m
  4.2343 -      | m :: _ :: _ => (warning ("Multiple modes possible for comprehension "
  4.2344 -                ^ Syntax.string_of_term_global thy t_compr); m);
  4.2345 -    val (inargs, outargs) = split_smode user_mode' args;
  4.2346 -    val t_pred = list_comb (compile_expr NONE thy (m, list_comb (pred, params)), inargs);
  4.2347 -    val t_eval = if null outargs then t_pred else let
  4.2348 -        val outargs_bounds = map (fn Bound i => i) outargs;
  4.2349 -        val outargsTs = map (nth Ts) outargs_bounds;
  4.2350 -        val T_pred = HOLogic.mk_tupleT outargsTs;
  4.2351 -        val T_compr = HOLogic.mk_ptupleT fp Ts;
  4.2352 -        val arrange_bounds = map_index I outargs_bounds
  4.2353 -          |> sort (prod_ord (K EQUAL) int_ord)
  4.2354 -          |> map fst;
  4.2355 -        val arrange = funpow (length outargs_bounds - 1) HOLogic.mk_split
  4.2356 -          (Term.list_abs (map (pair "") outargsTs,
  4.2357 -            HOLogic.mk_ptuple fp T_compr (map Bound arrange_bounds)))
  4.2358 -      in mk_map PredicateCompFuns.compfuns T_pred T_compr arrange t_pred end
  4.2359 -  in t_eval end;
  4.2360 -
  4.2361 -fun eval thy t_compr =
  4.2362 -  let
  4.2363 -    val t = analyze_compr thy t_compr;
  4.2364 -    val T = dest_predT PredicateCompFuns.compfuns (fastype_of t);
  4.2365 -    val t' = mk_map PredicateCompFuns.compfuns T HOLogic.termT (HOLogic.term_of_const T) t;
  4.2366 -  in (T, Code_ML.eval NONE ("Predicate_Compile.eval_ref", eval_ref) Predicate.map thy t' []) end;
  4.2367 -
  4.2368 -fun values ctxt k t_compr =
  4.2369 -  let
  4.2370 -    val thy = ProofContext.theory_of ctxt;
  4.2371 -    val (T, t) = eval thy t_compr;
  4.2372 -    val setT = HOLogic.mk_setT T;
  4.2373 -    val (ts, _) = Predicate.yieldn k t;
  4.2374 -    val elemsT = HOLogic.mk_set T ts;
  4.2375 -  in if k = ~1 orelse length ts < k then elemsT
  4.2376 -    else Const (@{const_name Set.union}, setT --> setT --> setT) $ elemsT $ t_compr
  4.2377 -  end;
  4.2378 -
  4.2379 -fun values_cmd modes k raw_t state =
  4.2380 -  let
  4.2381 -    val ctxt = Toplevel.context_of state;
  4.2382 -    val t = Syntax.read_term ctxt raw_t;
  4.2383 -    val t' = values ctxt k t;
  4.2384 -    val ty' = Term.type_of t';
  4.2385 -    val ctxt' = Variable.auto_fixes t' ctxt;
  4.2386 -    val p = PrintMode.with_modes modes (fn () =>
  4.2387 -      Pretty.block [Pretty.quote (Syntax.pretty_term ctxt' t'), Pretty.fbrk,
  4.2388 -        Pretty.str "::", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt' ty')]) ();
  4.2389 -  in Pretty.writeln p end;
  4.2390 -
  4.2391 -local structure P = OuterParse in
  4.2392 -
  4.2393 -val opt_modes = Scan.optional (P.$$$ "(" |-- P.!!! (Scan.repeat1 P.xname --| P.$$$ ")")) [];
  4.2394 -
  4.2395 -val _ = OuterSyntax.improper_command "values" "enumerate and print comprehensions" OuterKeyword.diag
  4.2396 -  (opt_modes -- Scan.optional P.nat ~1 -- P.term
  4.2397 -    >> (fn ((modes, k), t) => Toplevel.no_timing o Toplevel.keep
  4.2398 -        (values_cmd modes k t)));
  4.2399 -
  4.2400 -end;
  4.2401 -
  4.2402 -end;