src/HOL/Tools/Quickcheck/random_generators.ML
author haftmann
Tue Oct 13 09:21:15 2015 +0200 (2015-10-13)
changeset 61424 c3658c18b7bc
parent 61125 4c68426800de
child 62979 1e527c40ae40
permissions -rw-r--r--
prod_case as canonical name for product type eliminator
     1 (*  Title:      HOL/Tools/Quickcheck/random_generators.ML
     2     Author:     Florian Haftmann, TU Muenchen
     3 
     4 Random generators for various types.
     5 *)
     6 
     7 signature RANDOM_GENERATORS =
     8 sig
     9   type seed = Random_Engine.seed
    10   val random_fun: typ -> typ -> ('a -> 'a -> bool) -> ('a -> term)
    11     -> (seed -> ('b * (unit -> term)) * seed) -> (seed -> seed * seed)
    12     -> seed -> (('a -> 'b) * (unit -> term)) * seed
    13   val compile_generator_expr:
    14     Proof.context -> (term * term list) list -> bool -> int list -> (bool * term list) option * Quickcheck.report option
    15   val put_counterexample: (unit -> Code_Numeral.natural -> bool -> Code_Numeral.natural -> seed -> (bool * term list) option * seed)
    16     -> Proof.context -> Proof.context
    17   val put_counterexample_report: (unit -> Code_Numeral.natural -> bool -> Code_Numeral.natural -> seed -> ((bool * term list) option * (bool list * bool)) * seed)
    18     -> Proof.context -> Proof.context
    19   val instantiate_random_datatype : Old_Datatype_Aux.config -> Old_Datatype_Aux.descr ->
    20     (string * sort) list -> string list -> string -> string list * string list -> typ list * typ list -> theory -> theory
    21 end;
    22 
    23 structure Random_Generators : RANDOM_GENERATORS =
    24 struct
    25 
    26 (** abstract syntax **)
    27 
    28 fun termifyT T = HOLogic.mk_prodT (T, @{typ "unit => term"})
    29 val size = @{term "i::natural"};
    30 val size_pred = @{term "(i::natural) - 1"};
    31 val size' = @{term "j::natural"};
    32 val seed = @{term "s::Random.seed"};
    33 
    34 val resultT =  @{typ "(bool * term list) option"};
    35 
    36 (** typ "'a => 'b" **)
    37 
    38 type seed = Random_Engine.seed;
    39 
    40 fun random_fun T1 T2 eq term_of random random_split seed =
    41   let
    42     val fun_upd = Const (@{const_name fun_upd},
    43       (T1 --> T2) --> T1 --> T2 --> T1 --> T2);
    44     val ((_, t2), seed') = random seed;
    45     val (seed'', seed''') = random_split seed';
    46 
    47     val state = Unsynchronized.ref (seed'', [], fn () => Abs ("x", T1, t2 ()));
    48     fun random_fun' x =
    49       let
    50         val (seed, fun_map, f_t) = ! state;
    51       in case AList.lookup (uncurry eq) fun_map x
    52        of SOME y => y
    53         | NONE => let
    54               val t1 = term_of x;
    55               val ((y, t2), seed') = random seed;
    56               val fun_map' = (x, y) :: fun_map;
    57               val f_t' = fn () => fun_upd $ f_t () $ t1 $ t2 ();
    58               val _ = state := (seed', fun_map', f_t');
    59             in y end
    60       end;
    61     fun term_fun' () = #3 (! state) ();
    62   in ((random_fun', term_fun'), seed''') end;
    63 
    64   
    65 (** datatypes **)
    66 
    67 (* definitional scheme for random instances on datatypes *)
    68 
    69 local
    70 
    71 fun dest_ctyp_nth k cT = nth (Thm.dest_ctyp cT) k;
    72 val eq = Thm.cprop_of @{thm random_aux_rec} |> Thm.dest_arg |> Thm.dest_arg |> Thm.dest_arg;
    73 val lhs = eq |> Thm.dest_arg1;
    74 val pt_random_aux = lhs |> Thm.dest_fun;
    75 val pt_rhs = eq |> Thm.dest_arg |> Thm.dest_fun;
    76 val a_v =
    77   pt_random_aux |> Thm.ctyp_of_cterm |> dest_ctyp_nth 1
    78   |> Thm.typ_of |> dest_TVar;
    79 
    80 val rew_thms = map mk_meta_eq [@{thm natural_zero_minus_one},
    81   @{thm Suc_natural_minus_one}, @{thm select_weight_cons_zero}, @{thm beyond_zero}];
    82 val rew_ts = map (Logic.dest_equals o Thm.prop_of) rew_thms;
    83 val rew_ss = simpset_of (put_simpset HOL_ss @{context} addsimps rew_thms);
    84 
    85 in
    86 
    87 fun random_aux_primrec eq lthy =
    88   let
    89     val thy = Proof_Context.theory_of lthy;
    90     val ((t_random_aux as Free (random_aux, T)) $ (t_k as Free (v, _)), proto_t_rhs) =
    91       (HOLogic.dest_eq o HOLogic.dest_Trueprop) eq;
    92     val Type (_, [_, iT]) = T;
    93     val icT = Thm.ctyp_of lthy iT;
    94     val inst = Thm.instantiate_cterm ([(a_v, icT)], []);
    95     fun subst_v t' = map_aterms (fn t as Free (w, _) => if v = w then t' else t | t => t);
    96     val t_rhs = lambda t_k proto_t_rhs;
    97     val eqs0 = [subst_v @{term "0::natural"} eq,
    98       subst_v (@{const Code_Numeral.Suc} $ t_k) eq];
    99     val eqs1 = map (Pattern.rewrite_term thy rew_ts []) eqs0;
   100     val ((_, (_, eqs2)), lthy') = lthy
   101       |> BNF_LFP_Compat.primrec_simple
   102         [((Binding.concealed (Binding.name random_aux), T), NoSyn)] eqs1;
   103     val cT_random_aux = inst pt_random_aux |> Thm.term_of |> dest_Var;
   104     val cT_rhs = inst pt_rhs |> Thm.term_of |> dest_Var;
   105     val rule = @{thm random_aux_rec}
   106       |> Drule.instantiate_normalize
   107         ([(a_v, icT)],
   108           [(cT_random_aux, Thm.cterm_of lthy' t_random_aux),
   109            (cT_rhs, Thm.cterm_of lthy' t_rhs)]);
   110     fun tac ctxt =
   111       ALLGOALS (resolve_tac ctxt [rule])
   112       THEN ALLGOALS (simp_tac (put_simpset rew_ss ctxt))
   113       THEN (ALLGOALS (Proof_Context.fact_tac ctxt eqs2));
   114     val simp = Goal.prove_sorry lthy' [v] [] eq (tac o #context);
   115   in (simp, lthy') end;
   116 
   117 end;
   118 
   119 fun random_aux_primrec_multi auxname [eq] lthy =
   120       lthy
   121       |> random_aux_primrec eq
   122       |>> single
   123   | random_aux_primrec_multi auxname (eqs as _ :: _ :: _) lthy =
   124       let
   125         val thy = Proof_Context.theory_of lthy;
   126         val (lhss, rhss) = map_split (HOLogic.dest_eq o HOLogic.dest_Trueprop) eqs;
   127         val (vs, (arg as Free (v, _)) :: _) = map_split (fn (t1 $ t2) => (t1, t2)) lhss;
   128         val Ts = map fastype_of lhss;
   129         val tupleT = foldr1 HOLogic.mk_prodT Ts;
   130         val aux_lhs = Free ("mutual_" ^ auxname, fastype_of arg --> tupleT) $ arg;
   131         val aux_eq = (HOLogic.mk_Trueprop o HOLogic.mk_eq)
   132           (aux_lhs, foldr1 HOLogic.mk_prod rhss);
   133         fun mk_proj t [T] = [t]
   134           | mk_proj t (Ts as T :: (Ts' as _ :: _)) =
   135               Const (@{const_name fst}, foldr1 HOLogic.mk_prodT Ts --> T) $ t
   136                 :: mk_proj (Const (@{const_name snd},
   137                   foldr1 HOLogic.mk_prodT Ts --> foldr1 HOLogic.mk_prodT Ts') $ t) Ts';
   138         val projs = mk_proj (aux_lhs) Ts;
   139         val proj_eqs = map2 (fn v => fn proj => (v, lambda arg proj)) vs projs;
   140         val proj_defs = map2 (fn Free (name, _) => fn (_, rhs) =>
   141           ((Binding.concealed (Binding.name name), NoSyn),
   142             (apfst Binding.concealed Attrib.empty_binding, rhs))) vs proj_eqs;
   143         val aux_eq' = Pattern.rewrite_term thy proj_eqs [] aux_eq;
   144         fun prove_eqs aux_simp proj_defs lthy = 
   145           let
   146             val proj_simps = map (snd o snd) proj_defs;
   147             fun tac { context = ctxt, prems = _ } =
   148               ALLGOALS (simp_tac (put_simpset HOL_ss ctxt addsimps proj_simps))
   149               THEN ALLGOALS (EqSubst.eqsubst_tac ctxt [0] [aux_simp])
   150               THEN ALLGOALS (simp_tac (put_simpset HOL_ss ctxt addsimps @{thms fst_conv snd_conv}));
   151           in (map (fn prop => Goal.prove_sorry lthy [v] [] prop tac) eqs, lthy) end;
   152       in
   153         lthy
   154         |> random_aux_primrec aux_eq'
   155         ||>> fold_map Local_Theory.define proj_defs
   156         |-> uncurry prove_eqs
   157       end;
   158 
   159 fun random_aux_specification prfx name eqs lthy =
   160   let
   161     val vs = fold Term.add_free_names ((snd o strip_comb o fst o HOLogic.dest_eq
   162       o HOLogic.dest_Trueprop o hd) eqs) [];
   163     fun mk_proto_eq eq =
   164       let
   165         val (head $ t $ u, rhs) = (HOLogic.dest_eq o HOLogic.dest_Trueprop) eq;
   166       in ((HOLogic.mk_Trueprop o HOLogic.mk_eq) (head, lambda t (lambda u rhs))) end;
   167     val proto_eqs = map mk_proto_eq eqs;
   168     fun prove_simps proto_simps lthy =
   169       let
   170         val ext_simps = map (fn thm => fun_cong OF [fun_cong OF [thm]]) proto_simps;
   171         val tac = ALLGOALS (Proof_Context.fact_tac lthy ext_simps);
   172       in (map (fn prop => Goal.prove_sorry lthy vs [] prop (K tac)) eqs, lthy) end;
   173     val b = Binding.concealed (Binding.qualify true prfx
   174       (Binding.qualify true name (Binding.name "simps")));
   175   in
   176     lthy
   177     |> random_aux_primrec_multi (name ^ prfx) proto_eqs
   178     |-> prove_simps
   179     |-> (fn simps => Local_Theory.note
   180       ((b, Code.add_default_eqn_attrib :: @{attributes [simp, nitpick_simp]}), simps))
   181     |> snd
   182   end
   183 
   184 
   185 (* constructing random instances on datatypes *)
   186 
   187 val random_auxN = "random_aux";
   188 
   189 fun mk_random_aux_eqs thy descr vs (names, auxnames) (Ts, Us) =
   190   let
   191     val mk_const = curry (Sign.mk_const thy);
   192     val random_auxsN = map (prefix (random_auxN ^ "_")) (names @ auxnames);
   193     val rTs = Ts @ Us;
   194     fun random_resultT T = @{typ Random.seed}
   195       --> HOLogic.mk_prodT (termifyT T,@{typ Random.seed});
   196     fun sizeT T = @{typ natural} --> @{typ natural} --> T;
   197     val random_auxT = sizeT o random_resultT;
   198     val random_auxs = map2 (fn s => fn rT => Free (s, random_auxT rT))
   199       random_auxsN rTs;
   200     fun mk_random_call T = (NONE, (HOLogic.mk_random T size', T));
   201     fun mk_random_aux_call fTs (k, _) (tyco, Ts) =
   202       let
   203         val T = Type (tyco, Ts);
   204         fun mk_random_fun_lift [] t = t
   205           | mk_random_fun_lift (fT :: fTs) t =
   206               mk_const @{const_name random_fun_lift} [fTs ---> T, fT] $
   207                 mk_random_fun_lift fTs t;
   208         val t = mk_random_fun_lift fTs (nth random_auxs k $ size_pred $ size');
   209         val size = Option.map snd (Old_Datatype_Aux.find_shortest_path descr k)
   210           |> the_default 0;
   211       in (SOME size, (t, fTs ---> T)) end;
   212     val tss = Old_Datatype_Aux.interpret_construction descr vs
   213       { atyp = mk_random_call, dtyp = mk_random_aux_call };
   214     fun mk_consexpr simpleT (c, xs) =
   215       let
   216         val (ks, simple_tTs) = split_list xs;
   217         val T = termifyT simpleT;
   218         val tTs = (map o apsnd) termifyT simple_tTs;
   219         val is_rec = exists is_some ks;
   220         val k = fold (fn NONE => I | SOME k => Integer.max k) ks 0;
   221         val vs = Name.invent_names Name.context "x" (map snd simple_tTs);
   222         val tc = HOLogic.mk_return T @{typ Random.seed}
   223           (HOLogic.mk_valtermify_app c vs simpleT);
   224         val t = HOLogic.mk_ST
   225           (map2 (fn (t, _) => fn (v, T') => ((t, @{typ Random.seed}), SOME ((v, termifyT T')))) tTs vs)
   226             tc @{typ Random.seed} (SOME T, @{typ Random.seed});
   227         val tk = if is_rec
   228           then if k = 0 then size
   229             else @{term "Quickcheck_Random.beyond :: natural \<Rightarrow> natural \<Rightarrow> natural"}
   230              $ HOLogic.mk_number @{typ natural} k $ size
   231           else @{term "1::natural"}
   232       in (is_rec, HOLogic.mk_prod (tk, t)) end;
   233     fun sort_rec xs =
   234       map_filter (fn (true, t) => SOME t | _ =>  NONE) xs
   235       @ map_filter (fn (false, t) => SOME t | _ =>  NONE) xs;
   236     val gen_exprss = tss
   237       |> (map o apfst) Type
   238       |> map (fn (T, cs) => (T, (sort_rec o map (mk_consexpr T)) cs));
   239     fun mk_select (rT, xs) =
   240       mk_const @{const_name Quickcheck_Random.collapse} [@{typ Random.seed}, termifyT rT]
   241       $ (mk_const @{const_name Random.select_weight} [random_resultT rT]
   242         $ HOLogic.mk_list (HOLogic.mk_prodT (@{typ natural}, random_resultT rT)) xs)
   243           $ seed;
   244     val auxs_lhss = map (fn t => t $ size $ size' $ seed) random_auxs;
   245     val auxs_rhss = map mk_select gen_exprss;
   246   in (random_auxs, auxs_lhss ~~ auxs_rhss) end;
   247 
   248 fun instantiate_random_datatype config descr vs tycos prfx (names, auxnames) (Ts, Us) thy =
   249   let
   250     val _ = Old_Datatype_Aux.message config "Creating quickcheck generators ...";
   251     val mk_prop_eq = HOLogic.mk_Trueprop o HOLogic.mk_eq;
   252     fun mk_size_arg k = case Old_Datatype_Aux.find_shortest_path descr k
   253      of SOME (_, l) => if l = 0 then size
   254           else @{term "max :: natural \<Rightarrow> natural \<Rightarrow> natural"}
   255             $ HOLogic.mk_number @{typ natural} l $ size
   256       | NONE => size;
   257     val (random_auxs, auxs_eqs) = (apsnd o map) mk_prop_eq
   258       (mk_random_aux_eqs thy descr vs (names, auxnames) (Ts, Us));
   259     val random_defs = map_index (fn (k, T) => mk_prop_eq
   260       (HOLogic.mk_random T size, nth random_auxs k $ mk_size_arg k $ size)) Ts;
   261   in
   262     thy
   263     |> Class.instantiation (tycos, vs, @{sort random})
   264     |> random_aux_specification prfx random_auxN auxs_eqs
   265     |> `(fn lthy => map (Syntax.check_term lthy) random_defs)
   266     |-> (fn random_defs' => fold_map (fn random_def =>
   267           Specification.definition (NONE, (apfst Binding.concealed
   268             Attrib.empty_binding, random_def))) random_defs')
   269     |> snd
   270     |> Class.prove_instantiation_exit (fn ctxt => Class.intro_classes_tac ctxt [])
   271   end;
   272 
   273 
   274 (** building and compiling generator expressions **)
   275 
   276 structure Data = Proof_Data
   277 (
   278   type T =
   279     (unit -> Code_Numeral.natural -> bool -> Code_Numeral.natural -> seed ->
   280       (bool * term list) option * seed) *
   281     (unit -> Code_Numeral.natural -> bool -> Code_Numeral.natural -> seed ->
   282       ((bool * term list) option * (bool list * bool)) * seed);
   283   val empty: T =
   284    (fn () => raise Fail "counterexample",
   285     fn () => raise Fail "counterexample_report");
   286   fun init _ = empty;
   287 );
   288 
   289 val get_counterexample = #1 o Data.get;
   290 val get_counterexample_report = #2 o Data.get;
   291 
   292 val put_counterexample = Data.map o @{apply 2(1)} o K;
   293 val put_counterexample_report = Data.map o @{apply 2(2)} o K;
   294 
   295 val target = "Quickcheck";
   296 
   297 fun mk_generator_expr ctxt (t, _) =
   298   let  
   299     val thy = Proof_Context.theory_of ctxt
   300     val prop = fold_rev absfree (Term.add_frees t []) t
   301     val Ts = (map snd o fst o strip_abs) prop
   302     val bound_max = length Ts - 1;
   303     val bounds = map_index (fn (i, ty) =>
   304       (2 * (bound_max - i) + 1, 2 * (bound_max - i), 2 * i, ty)) Ts;
   305     val result = list_comb (prop, map (fn (i, _, _, _) => Bound i) bounds);
   306     val terms = HOLogic.mk_list @{typ term} (map (fn (_, i, _, _) => Bound i $ @{term "()"}) bounds);
   307     val ([genuine_only_name], _) = Variable.variant_fixes ["genuine_only"] ctxt
   308     val genuine_only = Free (genuine_only_name, @{typ bool})
   309     val none_t = Const (@{const_name "None"}, resultT)
   310     val check = Quickcheck_Common.mk_safe_if genuine_only none_t (result, none_t,
   311       fn genuine => @{term "Some :: bool * term list => (bool * term list) option"} $
   312         HOLogic.mk_prod (Quickcheck_Common.reflect_bool genuine, terms))
   313     val return = HOLogic.pair_const resultT @{typ Random.seed};
   314     fun liftT T sT = sT --> HOLogic.mk_prodT (T, sT);
   315     fun mk_termtyp T = HOLogic.mk_prodT (T, @{typ "unit => term"});
   316     fun mk_scomp T1 T2 sT f g = Const (@{const_name scomp},
   317       liftT T1 sT --> (T1 --> liftT T2 sT) --> liftT T2 sT) $ f $ g;
   318     fun mk_case_prod T = Sign.mk_const thy
   319       (@{const_name case_prod}, [T, @{typ "unit => term"}, liftT resultT @{typ Random.seed}]);
   320     fun mk_scomp_split T t t' =
   321       mk_scomp (mk_termtyp T) resultT @{typ Random.seed} t
   322         (mk_case_prod T $ Abs ("", T, Abs ("", @{typ "unit => term"}, t')));
   323     fun mk_bindclause (_, _, i, T) = mk_scomp_split T
   324       (Sign.mk_const thy (@{const_name Quickcheck_Random.random}, [T]) $ Bound i);
   325   in
   326     lambda genuine_only
   327       (Abs ("n", @{typ natural}, fold_rev mk_bindclause bounds (return $ check true)))
   328   end;
   329 
   330 fun mk_reporting_generator_expr ctxt (t, _) =
   331   let
   332     val thy = Proof_Context.theory_of ctxt
   333     val resultT = @{typ "(bool * term list) option * (bool list * bool)"}
   334     val prop = fold_rev absfree (Term.add_frees t []) t
   335     val Ts = (map snd o fst o strip_abs) prop
   336     val bound_max = length Ts - 1
   337     val bounds = map_index (fn (i, ty) =>
   338       (2 * (bound_max - i) + 1, 2 * (bound_max - i), 2 * i, ty)) Ts;
   339     val prop' = betapplys (prop, map (fn (i, _, _, _) => Bound i) bounds);
   340     val terms = HOLogic.mk_list @{typ term} (map (fn (_, i, _, _) => Bound i $ @{term "()"}) bounds)
   341     val (assms, concl) = Quickcheck_Common.strip_imp prop'
   342     val return = HOLogic.pair_const resultT @{typ Random.seed};
   343     fun mk_assms_report i =
   344       HOLogic.mk_prod (@{term "None :: (bool * term list) option"},
   345         HOLogic.mk_prod (HOLogic.mk_list HOLogic.boolT
   346           (replicate i @{term True} @ replicate (length assms - i) @{term False}),
   347         @{term False}))
   348     fun mk_concl_report b =
   349       HOLogic.mk_prod (HOLogic.mk_list HOLogic.boolT (replicate (length assms) @{term True}),
   350         Quickcheck_Common.reflect_bool b)
   351     val ([genuine_only_name], _) = Variable.variant_fixes ["genuine_only"] ctxt
   352     val genuine_only = Free (genuine_only_name, @{typ bool})
   353     val none_t = HOLogic.mk_prod (@{term "None :: (bool * term list) option"}, mk_concl_report true)
   354     val concl_check = Quickcheck_Common.mk_safe_if genuine_only none_t (concl, none_t,
   355       fn genuine => HOLogic.mk_prod (@{term "Some :: bool * term list => (bool * term list) option"} $
   356         HOLogic.mk_prod (Quickcheck_Common.reflect_bool genuine, terms), mk_concl_report false))
   357     val check = fold_rev (fn (i, assm) => fn t => Quickcheck_Common.mk_safe_if genuine_only
   358       (mk_assms_report i) (HOLogic.mk_not assm, mk_assms_report i, t))
   359       (map_index I assms) concl_check
   360     fun liftT T sT = sT --> HOLogic.mk_prodT (T, sT);
   361     fun mk_termtyp T = HOLogic.mk_prodT (T, @{typ "unit => term"});
   362     fun mk_scomp T1 T2 sT f g = Const (@{const_name scomp},
   363       liftT T1 sT --> (T1 --> liftT T2 sT) --> liftT T2 sT) $ f $ g;
   364     fun mk_case_prod T = Sign.mk_const thy
   365       (@{const_name case_prod}, [T, @{typ "unit => term"}, liftT resultT @{typ Random.seed}]);
   366     fun mk_scomp_split T t t' =
   367       mk_scomp (mk_termtyp T) resultT @{typ Random.seed} t
   368         (mk_case_prod T $ Abs ("", T, Abs ("", @{typ "unit => term"}, t')));
   369     fun mk_bindclause (_, _, i, T) = mk_scomp_split T
   370       (Sign.mk_const thy (@{const_name Quickcheck_Random.random}, [T]) $ Bound i);
   371   in
   372     lambda genuine_only
   373       (Abs ("n", @{typ natural}, fold_rev mk_bindclause bounds (return $ check true)))
   374   end
   375 
   376 val mk_parametric_generator_expr = Quickcheck_Common.gen_mk_parametric_generator_expr 
   377   ((mk_generator_expr, 
   378     absdummy @{typ bool} (absdummy @{typ natural}
   379       @{term "Pair None :: Random.seed => (bool * term list) option * Random.seed"})),
   380     @{typ "bool => natural => Random.seed => (bool * term list) option * Random.seed"})
   381 
   382 val mk_parametric_reporting_generator_expr = Quickcheck_Common.gen_mk_parametric_generator_expr 
   383   ((mk_reporting_generator_expr,
   384     absdummy @{typ bool} (absdummy @{typ natural}
   385       @{term "Pair (None, ([], False)) :: Random.seed =>
   386         ((bool * term list) option * (bool list * bool)) * Random.seed"})),
   387     @{typ "bool => natural => Random.seed => ((bool * term list) option * (bool list * bool)) * Random.seed"})
   388     
   389     
   390 (* single quickcheck report *)
   391 
   392 datatype single_report = Run of bool list * bool | MatchExc
   393 
   394 fun collect_single_report single_report
   395     (Quickcheck.Report {iterations = iterations, raised_match_errors = raised_match_errors,
   396     satisfied_assms = satisfied_assms, positive_concl_tests = positive_concl_tests}) =
   397   case single_report
   398   of MatchExc =>
   399     Quickcheck.Report {iterations = iterations + 1, raised_match_errors = raised_match_errors + 1,
   400       satisfied_assms = satisfied_assms, positive_concl_tests = positive_concl_tests}
   401    | Run (assms, concl) =>
   402     Quickcheck.Report {iterations = iterations + 1, raised_match_errors = raised_match_errors,
   403       satisfied_assms =
   404         map2 (fn b => fn s => if b then s + 1 else s) assms
   405          (if null satisfied_assms then replicate (length assms) 0 else satisfied_assms),
   406       positive_concl_tests = if concl then positive_concl_tests + 1 else positive_concl_tests}
   407 
   408 val empty_report = Quickcheck.Report { iterations = 0, raised_match_errors = 0,
   409   satisfied_assms = [], positive_concl_tests = 0 }
   410     
   411 fun compile_generator_expr_raw ctxt ts =
   412   let
   413     val iterations = Config.get ctxt Quickcheck.iterations
   414   in
   415     if Config.get ctxt Quickcheck.report then
   416       let
   417         val t' = mk_parametric_reporting_generator_expr ctxt ts;
   418         val compile =
   419           Code_Runtime.dynamic_value_strict
   420             (get_counterexample_report, put_counterexample_report,
   421               "Random_Generators.put_counterexample_report")
   422             ctxt (SOME target)
   423             (fn proc => fn g => fn c => fn b => fn s =>
   424               g c b s #>> (apfst o Option.map o apsnd o map) proc)
   425             t' [];
   426         fun single_tester c b s = compile c b s |> Random_Engine.run
   427         fun iterate_and_collect _ _ 0 report = (NONE, report)
   428           | iterate_and_collect genuine_only (card, size) j report =
   429             let
   430               val (test_result, single_report) = apsnd Run (single_tester card genuine_only size)
   431               val report = collect_single_report single_report report
   432             in
   433               case test_result of NONE => iterate_and_collect genuine_only (card, size) (j - 1) report
   434                 | SOME q => (SOME q, report)
   435             end
   436       in
   437         fn genuine_only => fn [card, size] =>
   438           apsnd SOME (iterate_and_collect genuine_only (card, size) iterations empty_report)
   439       end
   440     else
   441       let
   442         val t' = mk_parametric_generator_expr ctxt ts;
   443         val compile =
   444           Code_Runtime.dynamic_value_strict
   445             (get_counterexample, put_counterexample, "Random_Generators.put_counterexample")
   446             ctxt (SOME target)
   447             (fn proc => fn g => fn c => fn b => fn s =>
   448               g c b s #>> (Option.map o apsnd o map) proc)
   449             t' [];
   450         fun single_tester c b s = compile c b s |> Random_Engine.run
   451         fun iterate _ _ 0 = NONE
   452           | iterate genuine_only (card, size) j =
   453             case single_tester card genuine_only size of
   454               NONE => iterate genuine_only (card, size) (j - 1)
   455             | SOME q => SOME q
   456       in
   457         fn genuine_only => fn [card, size] =>
   458           (rpair NONE (iterate genuine_only (card, size) iterations))
   459       end
   460   end;
   461 
   462 fun compile_generator_expr ctxt ts =
   463   let
   464     val compiled = compile_generator_expr_raw ctxt ts
   465   in fn genuine_only => fn [card, size] =>
   466     compiled genuine_only [Code_Numeral.natural_of_integer card, Code_Numeral.natural_of_integer size]
   467   end;
   468 
   469 val size_types = [@{type_name Enum.finite_1}, @{type_name Enum.finite_2},
   470   @{type_name Enum.finite_3}, @{type_name Enum.finite_4}, @{type_name Enum.finite_5}];
   471 
   472 fun size_matters_for _ Ts =
   473   not (forall (fn Type (tyco, []) => member (op =) size_types tyco | _ => false) Ts);
   474 
   475 val test_goals =
   476   Quickcheck_Common.generator_test_goal_terms ("random", (size_matters_for, compile_generator_expr));
   477   
   478 (** setup **)
   479 
   480 val active = Attrib.setup_config_bool @{binding quickcheck_random_active} (K false);
   481 
   482 val _ =
   483   Theory.setup
   484    (Quickcheck_Common.datatype_interpretation @{plugin quickcheck_random}
   485       (@{sort random}, instantiate_random_datatype) #>
   486     Context.theory_map (Quickcheck.add_tester ("random", (active, test_goals))));
   487 
   488 end;