src/HOL/Tools/Quickcheck/random_generators.ML
changeset 45723 75691bcc2c0f
parent 45721 d1fb55c2ed65
child 45726 8eee4a2d93cd
equal deleted inserted replaced
45722:63b42a7db003 45723:75691bcc2c0f
    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;
    28 val size = @{term "i::code_numeral"};
    28 val size = @{term "i::code_numeral"};
    29 val size_pred = @{term "(i::code_numeral) - 1"};
    29 val size_pred = @{term "(i::code_numeral) - 1"};
    30 val size' = @{term "j::code_numeral"};
    30 val size' = @{term "j::code_numeral"};
    31 val seed = @{term "s::Random.seed"};
    31 val seed = @{term "s::Random.seed"};
    32 
    32 
    33 
    33 val resultT =  @{typ "(bool * term list) option"};
    34 
    34 
    35 (** typ "'a => 'b" **)
    35 (** typ "'a => 'b" **)
    36 
    36 
    37 type seed = Random_Engine.seed;
    37 type seed = Random_Engine.seed;
    38 
    38 
   270 
   270 
   271 (* FIXME just one data slot (record) per program unit *)
   271 (* FIXME just one data slot (record) per program unit *)
   272 
   272 
   273 structure Counterexample = Proof_Data
   273 structure Counterexample = Proof_Data
   274 (
   274 (
   275   type T = unit -> int -> int -> int * int -> term list option * (int * int)
   275   type T = unit -> int -> int -> int * int -> (bool * term list) option * (int * int)
   276   (* FIXME avoid user error with non-user text *)
   276   (* FIXME avoid user error with non-user text *)
   277   fun init _ () = error "Counterexample"
   277   fun init _ () = error "Counterexample"
   278 );
   278 );
   279 val put_counterexample = Counterexample.put;
   279 val put_counterexample = Counterexample.put;
   280 
   280 
   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))