219 val t' = fold_rev absfree (Term.add_frees t []) t |
219 val t' = fold_rev absfree (Term.add_frees t []) t |
220 val thy = Proof_Context.theory_of ctxt |
220 val thy = Proof_Context.theory_of ctxt |
221 val ((((full_constname, constT), vs'), intro), thy1) = |
221 val ((((full_constname, constT), vs'), intro), thy1) = |
222 Predicate_Compile_Aux.define_quickcheck_predicate t' thy |
222 Predicate_Compile_Aux.define_quickcheck_predicate t' thy |
223 val thy2 = |
223 val thy2 = |
224 Context.theory_map (Named_Theorems.add_thm @{named_theorems code_pred_def} intro) thy1 |
224 Context.theory_map (Named_Theorems.add_thm \<^named_theorems>\<open>code_pred_def\<close> intro) thy1 |
225 val (thy3, _) = cpu_time "predicate preprocessing" |
225 val (thy3, _) = cpu_time "predicate preprocessing" |
226 (fn () => Predicate_Compile.preprocess options (Const (full_constname, constT)) thy2) |
226 (fn () => Predicate_Compile.preprocess options (Const (full_constname, constT)) thy2) |
227 val (thy4, _) = cpu_time "random_dseq core compilation" |
227 val (thy4, _) = cpu_time "random_dseq core compilation" |
228 (fn () => |
228 (fn () => |
229 case compilation of |
229 case compilation of |
249 (case compilation of |
249 (case compilation of |
250 Pos_Random_DSeq => mk_randompredT (HOLogic.mk_tupleT (map snd vs')) |
250 Pos_Random_DSeq => mk_randompredT (HOLogic.mk_tupleT (map snd vs')) |
251 | New_Pos_Random_DSeq => mk_new_randompredT (HOLogic.mk_tupleT (map snd vs')) |
251 | New_Pos_Random_DSeq => mk_new_randompredT (HOLogic.mk_tupleT (map snd vs')) |
252 | Pos_Generator_DSeq => mk_new_dseqT (HOLogic.mk_tupleT (map snd vs')) |
252 | Pos_Generator_DSeq => mk_new_dseqT (HOLogic.mk_tupleT (map snd vs')) |
253 | Depth_Limited_Random => |
253 | Depth_Limited_Random => |
254 [@{typ natural}, @{typ natural}, @{typ natural}, |
254 [\<^typ>\<open>natural\<close>, \<^typ>\<open>natural\<close>, \<^typ>\<open>natural\<close>, |
255 @{typ Random.seed}] ---> mk_predT (HOLogic.mk_tupleT (map snd vs')) |
255 \<^typ>\<open>Random.seed\<close>] ---> mk_predT (HOLogic.mk_tupleT (map snd vs')) |
256 | Pos_Generator_CPS => mk_cpsT (HOLogic.mk_tupleT (map snd vs'))) |
256 | Pos_Generator_CPS => mk_cpsT (HOLogic.mk_tupleT (map snd vs'))) |
257 in |
257 in |
258 Const (name, T) |
258 Const (name, T) |
259 end |
259 end |
260 else error ("Predicate Compile Quickcheck failed: " ^ commas (map string_of_mode modes)) |
260 else error ("Predicate Compile Quickcheck failed: " ^ commas (map string_of_mode modes)) |
261 fun mk_Some T = Const (@{const_name "Option.Some"}, T --> Type (@{type_name "Option.option"}, [T])) |
261 fun mk_Some T = Const (\<^const_name>\<open>Option.Some\<close>, T --> Type (\<^type_name>\<open>Option.option\<close>, [T])) |
262 val qc_term = |
262 val qc_term = |
263 (case compilation of |
263 (case compilation of |
264 Pos_Random_DSeq => mk_bind (prog, |
264 Pos_Random_DSeq => mk_bind (prog, |
265 mk_split_lambda (map Free vs') (mk_return (HOLogic.mk_list @{typ term} |
265 mk_split_lambda (map Free vs') (mk_return (HOLogic.mk_list \<^typ>\<open>term\<close> |
266 (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))) |
266 (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))) |
267 | New_Pos_Random_DSeq => mk_new_bind (prog, |
267 | New_Pos_Random_DSeq => mk_new_bind (prog, |
268 mk_split_lambda (map Free vs') (mk_new_return (HOLogic.mk_list @{typ term} |
268 mk_split_lambda (map Free vs') (mk_new_return (HOLogic.mk_list \<^typ>\<open>term\<close> |
269 (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))) |
269 (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))) |
270 | Pos_Generator_DSeq => mk_gen_bind (prog, |
270 | Pos_Generator_DSeq => mk_gen_bind (prog, |
271 mk_split_lambda (map Free vs') (mk_gen_return (HOLogic.mk_list @{typ term} |
271 mk_split_lambda (map Free vs') (mk_gen_return (HOLogic.mk_list \<^typ>\<open>term\<close> |
272 (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))) |
272 (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))) |
273 | Pos_Generator_CPS => prog $ |
273 | Pos_Generator_CPS => prog $ |
274 mk_split_lambda (map Free vs') (mk_Some @{typ "bool * term list"} $ |
274 mk_split_lambda (map Free vs') (mk_Some \<^typ>\<open>bool * term list\<close> $ |
275 HOLogic.mk_prod (@{term "True"}, HOLogic.mk_list @{typ term} |
275 HOLogic.mk_prod (\<^term>\<open>True\<close>, HOLogic.mk_list \<^typ>\<open>term\<close> |
276 (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))) |
276 (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))) |
277 | Depth_Limited_Random => fold_rev absdummy |
277 | Depth_Limited_Random => fold_rev absdummy |
278 [@{typ natural}, @{typ natural}, @{typ natural}, |
278 [\<^typ>\<open>natural\<close>, \<^typ>\<open>natural\<close>, \<^typ>\<open>natural\<close>, |
279 @{typ Random.seed}] |
279 \<^typ>\<open>Random.seed\<close>] |
280 (mk_bind' (list_comb (prog, map Bound (3 downto 0)), |
280 (mk_bind' (list_comb (prog, map Bound (3 downto 0)), |
281 mk_split_lambda (map Free vs') (mk_return' (HOLogic.mk_list @{typ term} |
281 mk_split_lambda (map Free vs') (mk_return' (HOLogic.mk_list \<^typ>\<open>term\<close> |
282 (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))))) |
282 (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))))) |
283 val prog = |
283 val prog = |
284 case compilation of |
284 case compilation of |
285 Pos_Random_DSeq => |
285 Pos_Random_DSeq => |
286 let |
286 let |
411 Quickcheck_Common.collect_results (test_term ctxt) |
411 Quickcheck_Common.collect_results (test_term ctxt) |
412 (maps (map snd) correct_inst_goals) [] |
412 (maps (map snd) correct_inst_goals) [] |
413 end |
413 end |
414 |
414 |
415 val smart_exhaustive_active = |
415 val smart_exhaustive_active = |
416 Attrib.setup_config_bool @{binding quickcheck_smart_exhaustive_active} (K true) |
416 Attrib.setup_config_bool \<^binding>\<open>quickcheck_smart_exhaustive_active\<close> (K true) |
417 val smart_slow_exhaustive_active = |
417 val smart_slow_exhaustive_active = |
418 Attrib.setup_config_bool @{binding quickcheck_slow_smart_exhaustive_active} (K false) |
418 Attrib.setup_config_bool \<^binding>\<open>quickcheck_slow_smart_exhaustive_active\<close> (K false) |
419 |
419 |
420 val _ = |
420 val _ = |
421 Theory.setup |
421 Theory.setup |
422 (Exhaustive_Generators.setup_exhaustive_datatype_interpretation #> |
422 (Exhaustive_Generators.setup_exhaustive_datatype_interpretation #> |
423 Context.theory_map (Quickcheck.add_tester ("smart_exhaustive", |
423 Context.theory_map (Quickcheck.add_tester ("smart_exhaustive", |