10 val random_fun: typ -> typ -> ('a -> 'a -> bool) -> ('a -> term) |
10 val random_fun: typ -> typ -> ('a -> 'a -> bool) -> ('a -> term) |
11 -> (seed -> ('b * (unit -> term)) * seed) -> (seed -> seed * seed) |
11 -> (seed -> ('b * (unit -> term)) * seed) -> (seed -> seed * seed) |
12 -> seed -> (('a -> 'b) * (unit -> term)) * seed |
12 -> seed -> (('a -> 'b) * (unit -> term)) * seed |
13 val compile_generator_expr: |
13 val compile_generator_expr: |
14 Proof.context -> (term * term list) list -> int list -> term list option * Quickcheck.report option |
14 Proof.context -> (term * term list) list -> int list -> term list option * Quickcheck.report option |
15 val put_counterexample: (unit -> int -> int -> seed -> term list option * seed) |
15 val put_counterexample: (unit -> int -> int -> seed -> (bool * term list) option * seed) |
16 -> Proof.context -> Proof.context |
16 -> Proof.context -> Proof.context |
17 val put_counterexample_report: (unit -> int -> int -> seed -> (term list option * (bool list * bool)) * seed) |
17 val put_counterexample_report: (unit -> int -> int -> seed -> (term list option * (bool list * bool)) * seed) |
18 -> Proof.context -> Proof.context |
18 -> Proof.context -> Proof.context |
19 val setup: theory -> theory |
19 val setup: theory -> theory |
20 end; |
20 end; |
296 val bound_max = length Ts - 1; |
296 val bound_max = length Ts - 1; |
297 val bounds = map_index (fn (i, ty) => |
297 val bounds = map_index (fn (i, ty) => |
298 (2 * (bound_max - i) + 1, 2 * (bound_max - i), 2 * i, ty)) Ts; |
298 (2 * (bound_max - i) + 1, 2 * (bound_max - i), 2 * i, ty)) Ts; |
299 val result = list_comb (prop, map (fn (i, _, _, _) => Bound i) bounds); |
299 val result = list_comb (prop, map (fn (i, _, _, _) => Bound i) bounds); |
300 val terms = HOLogic.mk_list @{typ term} (map (fn (_, i, _, _) => Bound i $ @{term "()"}) bounds); |
300 val terms = HOLogic.mk_list @{typ term} (map (fn (_, i, _, _) => Bound i $ @{term "()"}) bounds); |
301 val check = Quickcheck_Common.mk_safe_if ctxt (result, @{term "None :: term list option"}, |
301 val check = Quickcheck_Common.mk_safe_if ctxt (result, Const (@{const_name "None"}, resultT), |
302 fn genuine => @{term "Some :: bool * term list => (bool * term list) option"} $ |
302 fn genuine => @{term "Some :: bool * term list => (bool * term list) option"} $ |
303 HOLogic.mk_prod (Quickcheck_Common.reflect_bool genuine, terms)) |
303 HOLogic.mk_prod (Quickcheck_Common.reflect_bool genuine, terms)) |
304 val return = @{term "Pair :: term list option => Random.seed => term list option * Random.seed"}; |
304 val return = HOLogic.pair_const resultT @{typ Random.seed}; |
305 fun liftT T sT = sT --> HOLogic.mk_prodT (T, sT); |
305 fun liftT T sT = sT --> HOLogic.mk_prodT (T, sT); |
306 fun mk_termtyp T = HOLogic.mk_prodT (T, @{typ "unit => term"}); |
306 fun mk_termtyp T = HOLogic.mk_prodT (T, @{typ "unit => term"}); |
307 fun mk_scomp T1 T2 sT f g = Const (@{const_name scomp}, |
307 fun mk_scomp T1 T2 sT f g = Const (@{const_name scomp}, |
308 liftT T1 sT --> (T1 --> liftT T2 sT) --> liftT T2 sT) $ f $ g; |
308 liftT T1 sT --> (T1 --> liftT T2 sT) --> liftT T2 sT) $ f $ g; |
309 fun mk_split T = Sign.mk_const thy |
309 fun mk_split T = Sign.mk_const thy |
310 (@{const_name prod_case}, [T, @{typ "unit => term"}, liftT @{typ "term list option"} @{typ Random.seed}]); |
310 (@{const_name prod_case}, [T, @{typ "unit => term"}, liftT resultT @{typ Random.seed}]); |
311 fun mk_scomp_split T t t' = |
311 fun mk_scomp_split T t t' = |
312 mk_scomp (mk_termtyp T) @{typ "term list option"} @{typ Random.seed} t |
312 mk_scomp (mk_termtyp T) resultT @{typ Random.seed} t |
313 (mk_split T $ Abs ("", T, Abs ("", @{typ "unit => term"}, t'))); |
313 (mk_split T $ Abs ("", T, Abs ("", @{typ "unit => term"}, t'))); |
314 fun mk_bindclause (_, _, i, T) = mk_scomp_split T |
314 fun mk_bindclause (_, _, i, T) = mk_scomp_split T |
315 (Sign.mk_const thy (@{const_name Quickcheck.random}, [T]) $ Bound i); |
315 (Sign.mk_const thy (@{const_name Quickcheck.random}, [T]) $ Bound i); |
316 in Abs ("n", @{typ code_numeral}, fold_rev mk_bindclause bounds (return $ check)) end; |
316 in Abs ("n", @{typ code_numeral}, fold_rev mk_bindclause bounds (return $ check)) end; |
317 |
317 |
359 Abs ("n", @{typ code_numeral}, fold_rev mk_bindclause bounds (return $ check)) |
359 Abs ("n", @{typ code_numeral}, fold_rev mk_bindclause bounds (return $ check)) |
360 end |
360 end |
361 |
361 |
362 val mk_parametric_generator_expr = Quickcheck_Common.gen_mk_parametric_generator_expr |
362 val mk_parametric_generator_expr = Quickcheck_Common.gen_mk_parametric_generator_expr |
363 ((mk_generator_expr, |
363 ((mk_generator_expr, |
364 absdummy @{typ code_numeral} @{term "Pair None :: Random.seed => term list option * Random.seed"}), |
364 absdummy @{typ code_numeral} @{term "Pair None :: Random.seed => (bool * term list) option * Random.seed"}), |
365 @{typ "code_numeral => Random.seed => term list option * Random.seed"}) |
365 @{typ "code_numeral => Random.seed => (bool * term list) option * Random.seed"}) |
366 |
366 |
367 val mk_parametric_reporting_generator_expr = Quickcheck_Common.gen_mk_parametric_generator_expr |
367 val mk_parametric_reporting_generator_expr = Quickcheck_Common.gen_mk_parametric_generator_expr |
368 ((mk_reporting_generator_expr, |
368 ((mk_reporting_generator_expr, |
369 absdummy @{typ code_numeral} |
369 absdummy @{typ code_numeral} |
370 @{term "Pair (None, ([], False)) :: Random.seed => (term list option * (bool list * bool)) * Random.seed"}), |
370 @{term "Pair (None, ([], False)) :: Random.seed => (term list option * (bool list * bool)) * Random.seed"}), |
419 else |
419 else |
420 let |
420 let |
421 val t' = mk_parametric_generator_expr ctxt ts; |
421 val t' = mk_parametric_generator_expr ctxt ts; |
422 val compile = Code_Runtime.dynamic_value_strict |
422 val compile = Code_Runtime.dynamic_value_strict |
423 (Counterexample.get, put_counterexample, "Random_Generators.put_counterexample") |
423 (Counterexample.get, put_counterexample, "Random_Generators.put_counterexample") |
424 thy (SOME target) (fn proc => fn g => fn c => fn s => g c s #>> (Option.map o map) proc) t' []; |
424 thy (SOME target) |
425 fun single_tester c s = compile c s |> Random_Engine.run |
425 (fn proc => fn g => fn c => fn s =>g c s #>> (Option.map o apsnd o map) proc) t' []; |
|
426 fun single_tester c s = compile c s |> Random_Engine.run |> Option.map snd |
426 fun iterate (card, size) 0 = NONE |
427 fun iterate (card, size) 0 = NONE |
427 | iterate (card, size) j = |
428 | iterate (card, size) j = |
428 case single_tester card size of NONE => iterate (card, size) (j - 1) | SOME q => SOME q |
429 case single_tester card size of NONE => iterate (card, size) (j - 1) | SOME q => SOME q |
429 in |
430 in |
430 fn [card, size] => (rpair NONE (iterate (card, size) iterations)) |
431 fn [card, size] => (rpair NONE (iterate (card, size) iterations)) |