haftmann@37743
|
1 |
(* Title: HOL/Mutabelle/mutabelle_extra.ML
|
bulwahn@34952
|
2 |
Author: Stefan Berghofer, Jasmin Blanchette, Lukas Bulwahn, TU Muenchen
|
bulwahn@34952
|
3 |
|
wenzelm@41656
|
4 |
Invokation of Counterexample generators.
|
bulwahn@34952
|
5 |
*)
|
wenzelm@41656
|
6 |
|
bulwahn@34952
|
7 |
signature MUTABELLE_EXTRA =
|
bulwahn@34952
|
8 |
sig
|
bulwahn@34952
|
9 |
|
bulwahn@34952
|
10 |
val take_random : int -> 'a list -> 'a list
|
bulwahn@34952
|
11 |
|
bulwahn@40901
|
12 |
datatype outcome = GenuineCex | PotentialCex | NoCex | Donno | Timeout | Error | Solved | Unsolved
|
bulwahn@42953
|
13 |
type timings = (string * int) list
|
bulwahn@34952
|
14 |
|
bulwahn@42953
|
15 |
type mtd = string * (theory -> term -> outcome * timings)
|
bulwahn@35324
|
16 |
|
bulwahn@42953
|
17 |
type mutant_subentry = term * (string * (outcome * timings)) list
|
bulwahn@34952
|
18 |
type detailed_entry = string * bool * term * mutant_subentry list
|
bulwahn@34952
|
19 |
|
bulwahn@34952
|
20 |
type subentry = string * int * int * int * int * int * int
|
bulwahn@34952
|
21 |
type entry = string * bool * subentry list
|
bulwahn@34952
|
22 |
type report = entry list
|
bulwahn@34952
|
23 |
|
bulwahn@40901
|
24 |
val quickcheck_mtd : (Proof.context -> Proof.context) -> string -> mtd
|
bulwahn@40901
|
25 |
|
bulwahn@40901
|
26 |
val solve_direct_mtd : mtd
|
bulwahn@40901
|
27 |
val try_mtd : mtd
|
bulwahn@41220
|
28 |
(*
|
bulwahn@41217
|
29 |
val sledgehammer_mtd : mtd
|
bulwahn@41220
|
30 |
*)
|
bulwahn@41438
|
31 |
val nitpick_mtd : mtd
|
bulwahn@41438
|
32 |
|
bulwahn@34952
|
33 |
(*
|
bulwahn@34952
|
34 |
val refute_mtd : mtd
|
bulwahn@34952
|
35 |
*)
|
bulwahn@34952
|
36 |
|
bulwahn@34952
|
37 |
val freezeT : term -> term
|
bulwahn@34952
|
38 |
val thms_of : bool -> theory -> thm list
|
bulwahn@34952
|
39 |
|
bulwahn@34952
|
40 |
val string_for_report : report -> string
|
bulwahn@34952
|
41 |
val write_report : string -> report -> unit
|
bulwahn@34952
|
42 |
val mutate_theorems_and_write_report :
|
bulwahn@34952
|
43 |
theory -> mtd list -> thm list -> string -> unit
|
bulwahn@34952
|
44 |
|
bulwahn@34952
|
45 |
val random_seed : real Unsynchronized.ref
|
bulwahn@34952
|
46 |
end;
|
bulwahn@34952
|
47 |
|
bulwahn@34952
|
48 |
structure MutabelleExtra : MUTABELLE_EXTRA =
|
bulwahn@34952
|
49 |
struct
|
bulwahn@34952
|
50 |
|
bulwahn@34952
|
51 |
(* Own seed; can't rely on the Isabelle one to stay the same *)
|
bulwahn@34952
|
52 |
val random_seed = Unsynchronized.ref 1.0;
|
bulwahn@34952
|
53 |
|
bulwahn@34952
|
54 |
|
bulwahn@34952
|
55 |
(* mutation options *)
|
bulwahn@40901
|
56 |
(*val max_mutants = 4
|
bulwahn@40901
|
57 |
val num_mutations = 1*)
|
bulwahn@40901
|
58 |
(* soundness check: *)
|
bulwahn@40901
|
59 |
val max_mutants = 10
|
bulwahn@34952
|
60 |
val num_mutations = 1
|
bulwahn@34952
|
61 |
|
bulwahn@34952
|
62 |
(* quickcheck options *)
|
bulwahn@34952
|
63 |
(*val quickcheck_generator = "SML"*)
|
bulwahn@34952
|
64 |
|
bulwahn@40901
|
65 |
(* Another Random engine *)
|
bulwahn@40901
|
66 |
|
bulwahn@34952
|
67 |
exception RANDOM;
|
bulwahn@34952
|
68 |
|
bulwahn@34952
|
69 |
fun rmod x y = x - y * Real.realFloor (x / y);
|
bulwahn@34952
|
70 |
|
bulwahn@34952
|
71 |
local
|
bulwahn@34952
|
72 |
val a = 16807.0;
|
bulwahn@34952
|
73 |
val m = 2147483647.0;
|
bulwahn@34952
|
74 |
in
|
bulwahn@34952
|
75 |
|
bulwahn@34952
|
76 |
fun random () = CRITICAL (fn () =>
|
bulwahn@34952
|
77 |
let val r = rmod (a * ! random_seed) m
|
bulwahn@34952
|
78 |
in (random_seed := r; r) end);
|
bulwahn@34952
|
79 |
|
bulwahn@34952
|
80 |
end;
|
bulwahn@34952
|
81 |
|
bulwahn@34952
|
82 |
fun random_range l h =
|
bulwahn@34952
|
83 |
if h < l orelse l < 0 then raise RANDOM
|
bulwahn@34952
|
84 |
else l + Real.floor (rmod (random ()) (real (h - l + 1)));
|
bulwahn@34952
|
85 |
|
bulwahn@40901
|
86 |
fun take_random 0 _ = []
|
bulwahn@40901
|
87 |
| take_random _ [] = []
|
bulwahn@40901
|
88 |
| take_random n xs =
|
bulwahn@40901
|
89 |
let val j = random_range 0 (length xs - 1) in
|
bulwahn@40901
|
90 |
Library.nth xs j :: take_random (n - 1) (nth_drop j xs)
|
bulwahn@40901
|
91 |
end
|
bulwahn@40901
|
92 |
|
bulwahn@40901
|
93 |
(* possible outcomes *)
|
bulwahn@40901
|
94 |
|
bulwahn@40901
|
95 |
datatype outcome = GenuineCex | PotentialCex | NoCex | Donno | Timeout | Error | Solved | Unsolved
|
bulwahn@40901
|
96 |
|
bulwahn@40901
|
97 |
fun string_of_outcome GenuineCex = "GenuineCex"
|
bulwahn@40901
|
98 |
| string_of_outcome PotentialCex = "PotentialCex"
|
bulwahn@40901
|
99 |
| string_of_outcome NoCex = "NoCex"
|
bulwahn@40901
|
100 |
| string_of_outcome Donno = "Donno"
|
bulwahn@40901
|
101 |
| string_of_outcome Timeout = "Timeout"
|
bulwahn@40901
|
102 |
| string_of_outcome Error = "Error"
|
bulwahn@40901
|
103 |
| string_of_outcome Solved = "Solved"
|
bulwahn@40901
|
104 |
| string_of_outcome Unsolved = "Unsolved"
|
bulwahn@40901
|
105 |
|
bulwahn@42953
|
106 |
type timings = (string * int) list
|
bulwahn@34952
|
107 |
|
bulwahn@42953
|
108 |
type mtd = string * (theory -> term -> outcome * timings)
|
bulwahn@35324
|
109 |
|
bulwahn@42953
|
110 |
type mutant_subentry = term * (string * (outcome * timings)) list
|
bulwahn@34952
|
111 |
type detailed_entry = string * bool * term * mutant_subentry list
|
bulwahn@34952
|
112 |
|
bulwahn@34952
|
113 |
type subentry = string * int * int * int * int * int * int
|
bulwahn@34952
|
114 |
type entry = string * bool * subentry list
|
bulwahn@34952
|
115 |
type report = entry list
|
bulwahn@34952
|
116 |
|
bulwahn@40901
|
117 |
(* possible invocations *)
|
bulwahn@34952
|
118 |
|
bulwahn@40901
|
119 |
(** quickcheck **)
|
bulwahn@34952
|
120 |
|
bulwahn@40901
|
121 |
fun invoke_quickcheck change_options quickcheck_generator thy t =
|
blanchet@41175
|
122 |
TimeLimit.timeLimit (seconds (!Auto_Tools.time_limit))
|
bulwahn@34952
|
123 |
(fn _ =>
|
bulwahn@42953
|
124 |
let
|
wenzelm@43232
|
125 |
val [result] = Quickcheck.test_goal_terms (change_options (Proof_Context.init_global thy))
|
bulwahn@42953
|
126 |
(false, false) [] [(t, [])]
|
bulwahn@42953
|
127 |
in
|
bulwahn@42953
|
128 |
case Quickcheck.counterexample_of result of
|
bulwahn@42953
|
129 |
NONE => (NoCex, Quickcheck.timings_of result)
|
bulwahn@42953
|
130 |
| SOME _ => (GenuineCex, Quickcheck.timings_of result)
|
bulwahn@42953
|
131 |
end) ()
|
blanchet@41175
|
132 |
handle TimeLimit.TimeOut =>
|
bulwahn@42953
|
133 |
(Timeout, [("timelimit", Real.floor (!Auto_Tools.time_limit))])
|
bulwahn@34952
|
134 |
|
bulwahn@40901
|
135 |
fun quickcheck_mtd change_options quickcheck_generator =
|
bulwahn@40901
|
136 |
("quickcheck_" ^ quickcheck_generator, invoke_quickcheck change_options quickcheck_generator)
|
bulwahn@34952
|
137 |
|
bulwahn@40901
|
138 |
(** solve direct **)
|
bulwahn@40901
|
139 |
|
bulwahn@40901
|
140 |
fun invoke_solve_direct thy t =
|
bulwahn@40901
|
141 |
let
|
wenzelm@43232
|
142 |
val state = Proof.theorem NONE (K I) (map (single o rpair []) [t]) (Proof_Context.init_global thy)
|
bulwahn@40901
|
143 |
in
|
bulwahn@40901
|
144 |
case Solve_Direct.solve_direct false state of
|
bulwahn@42953
|
145 |
(true, _) => (Solved, [])
|
bulwahn@42953
|
146 |
| (false, _) => (Unsolved, [])
|
bulwahn@40901
|
147 |
end
|
bulwahn@40901
|
148 |
|
bulwahn@40901
|
149 |
val solve_direct_mtd = ("solve_direct", invoke_solve_direct)
|
bulwahn@40901
|
150 |
|
bulwahn@40901
|
151 |
(** try **)
|
bulwahn@40901
|
152 |
|
bulwahn@40901
|
153 |
fun invoke_try thy t =
|
bulwahn@40901
|
154 |
let
|
wenzelm@43232
|
155 |
val state = Proof.theorem NONE (K I) (map (single o rpair []) [t]) (Proof_Context.init_global thy)
|
bulwahn@40901
|
156 |
in
|
blanchet@43050
|
157 |
case Try.invoke_try (SOME (seconds 5.0)) ([], [], [], []) state of
|
bulwahn@42953
|
158 |
true => (Solved, [])
|
bulwahn@42953
|
159 |
| false => (Unsolved, [])
|
bulwahn@40901
|
160 |
end
|
bulwahn@40901
|
161 |
|
bulwahn@40901
|
162 |
val try_mtd = ("try", invoke_try)
|
bulwahn@40901
|
163 |
|
bulwahn@41217
|
164 |
(** sledgehammer **)
|
bulwahn@41220
|
165 |
(*
|
bulwahn@41217
|
166 |
fun invoke_sledgehammer thy t =
|
bulwahn@41217
|
167 |
if can (Goal.prove_global thy (Term.add_free_names t []) [] t)
|
bulwahn@41217
|
168 |
(fn {context, ...} => Sledgehammer_Tactics.sledgehammer_with_metis_tac context 1) then
|
bulwahn@41217
|
169 |
(Solved, ([], NONE))
|
bulwahn@41217
|
170 |
else
|
bulwahn@41217
|
171 |
(Unsolved, ([], NONE))
|
bulwahn@41217
|
172 |
|
bulwahn@41217
|
173 |
val sledgehammer_mtd = ("sledgehammer", invoke_sledgehammer)
|
bulwahn@41220
|
174 |
*)
|
bulwahn@40901
|
175 |
(*
|
bulwahn@34952
|
176 |
fun invoke_refute thy t =
|
bulwahn@34952
|
177 |
let
|
bulwahn@34952
|
178 |
val res = MyRefute.refute_term thy [] t
|
wenzelm@40392
|
179 |
val _ = Output.urgent_message ("Refute: " ^ res)
|
bulwahn@34952
|
180 |
in
|
bulwahn@34952
|
181 |
case res of
|
bulwahn@34952
|
182 |
"genuine" => GenuineCex
|
bulwahn@34952
|
183 |
| "likely_genuine" => GenuineCex
|
bulwahn@34952
|
184 |
| "potential" => PotentialCex
|
bulwahn@34952
|
185 |
| "none" => NoCex
|
bulwahn@34952
|
186 |
| "unknown" => Donno
|
bulwahn@34952
|
187 |
| _ => Error
|
bulwahn@34952
|
188 |
end
|
bulwahn@34952
|
189 |
handle MyRefute.REFUTE (loc, details) =>
|
bulwahn@34952
|
190 |
(error ("Unhandled Refute error (" ^ quote loc ^ "): " ^ details ^
|
bulwahn@34952
|
191 |
"."))
|
bulwahn@34952
|
192 |
val refute_mtd = ("refute", invoke_refute)
|
bulwahn@34952
|
193 |
*)
|
bulwahn@34952
|
194 |
|
bulwahn@41438
|
195 |
(** nitpick **)
|
bulwahn@34952
|
196 |
|
bulwahn@34952
|
197 |
fun invoke_nitpick thy t =
|
bulwahn@34952
|
198 |
let
|
wenzelm@43232
|
199 |
val ctxt = Proof_Context.init_global thy
|
bulwahn@34952
|
200 |
val state = Proof.init ctxt
|
bulwahn@41438
|
201 |
val (res, _) = Nitpick.pick_nits_in_term state
|
bulwahn@41438
|
202 |
(Nitpick_Isar.default_params thy []) false 1 1 1 [] [] t
|
bulwahn@41438
|
203 |
val _ = Output.urgent_message ("Nitpick: " ^ res)
|
bulwahn@34952
|
204 |
in
|
bulwahn@42953
|
205 |
(rpair []) (case res of
|
bulwahn@41438
|
206 |
"genuine" => GenuineCex
|
bulwahn@41438
|
207 |
| "likely_genuine" => GenuineCex
|
bulwahn@41438
|
208 |
| "potential" => PotentialCex
|
bulwahn@41438
|
209 |
| "none" => NoCex
|
bulwahn@41438
|
210 |
| "unknown" => Donno
|
bulwahn@41438
|
211 |
| _ => Error)
|
bulwahn@34952
|
212 |
end
|
bulwahn@41438
|
213 |
|
bulwahn@34952
|
214 |
val nitpick_mtd = ("nitpick", invoke_nitpick)
|
bulwahn@34952
|
215 |
|
bulwahn@40901
|
216 |
(* filtering forbidden theorems and mutants *)
|
bulwahn@40901
|
217 |
|
haftmann@39093
|
218 |
val comms = [@{const_name HOL.eq}, @{const_name HOL.disj}, @{const_name HOL.conj}]
|
bulwahn@34952
|
219 |
|
bulwahn@34952
|
220 |
val forbidden =
|
bulwahn@34952
|
221 |
[(* (@{const_name "power"}, "'a"), *)
|
bulwahn@35325
|
222 |
(*(@{const_name induct_equal}, "'a"),
|
bulwahn@35325
|
223 |
(@{const_name induct_implies}, "'a"),
|
bulwahn@35325
|
224 |
(@{const_name induct_conj}, "'a"),*)
|
bulwahn@34952
|
225 |
(@{const_name "undefined"}, "'a"),
|
bulwahn@34952
|
226 |
(@{const_name "default"}, "'a"),
|
bulwahn@36255
|
227 |
(@{const_name "dummy_pattern"}, "'a::{}"),
|
bulwahn@36255
|
228 |
(@{const_name "HOL.simp_implies"}, "prop => prop => prop"),
|
bulwahn@36255
|
229 |
(@{const_name "bot_fun_inst.bot_fun"}, "'a"),
|
bulwahn@36255
|
230 |
(@{const_name "top_fun_inst.top_fun"}, "'a"),
|
bulwahn@36255
|
231 |
(@{const_name "Pure.term"}, "'a"),
|
bulwahn@36255
|
232 |
(@{const_name "top_class.top"}, "'a"),
|
bulwahn@36255
|
233 |
(@{const_name "Quotient.Quot_True"}, "'a")(*,
|
bulwahn@34952
|
234 |
(@{const_name "uminus"}, "'a"),
|
bulwahn@34952
|
235 |
(@{const_name "Nat.size"}, "'a"),
|
haftmann@35092
|
236 |
(@{const_name "Groups.abs"}, "'a") *)]
|
bulwahn@34952
|
237 |
|
bulwahn@34952
|
238 |
val forbidden_thms =
|
bulwahn@34952
|
239 |
["finite_intvl_succ_class",
|
bulwahn@34952
|
240 |
"nibble"]
|
bulwahn@34952
|
241 |
|
bulwahn@34952
|
242 |
val forbidden_consts =
|
bulwahn@40901
|
243 |
[@{const_name nibble_pair_of_char}, @{const_name "TYPE"}]
|
bulwahn@34952
|
244 |
|
bulwahn@34952
|
245 |
fun is_forbidden_theorem (s, th) =
|
bulwahn@34952
|
246 |
let val consts = Term.add_const_names (prop_of th) [] in
|
haftmann@36677
|
247 |
exists (member (op =) (space_explode "." s)) forbidden_thms orelse
|
haftmann@36677
|
248 |
exists (member (op =) forbidden_consts) consts orelse
|
bulwahn@34952
|
249 |
length (space_explode "." s) <> 2 orelse
|
bulwahn@34952
|
250 |
String.isPrefix "type_definition" (List.last (space_explode "." s)) orelse
|
bulwahn@34952
|
251 |
String.isSuffix "_def" s orelse
|
bulwahn@40901
|
252 |
String.isSuffix "_raw" s orelse
|
bulwahn@40901
|
253 |
String.isPrefix "term_of" (List.last (space_explode "." s))
|
bulwahn@34952
|
254 |
end
|
bulwahn@34952
|
255 |
|
bulwahn@36255
|
256 |
val forbidden_mutant_constnames =
|
bulwahn@36255
|
257 |
["HOL.induct_equal",
|
bulwahn@36255
|
258 |
"HOL.induct_implies",
|
bulwahn@36255
|
259 |
"HOL.induct_conj",
|
bulwahn@36255
|
260 |
@{const_name undefined},
|
bulwahn@36255
|
261 |
@{const_name default},
|
bulwahn@36255
|
262 |
@{const_name dummy_pattern},
|
bulwahn@36255
|
263 |
@{const_name "HOL.simp_implies"},
|
bulwahn@36255
|
264 |
@{const_name "bot_fun_inst.bot_fun"},
|
bulwahn@36255
|
265 |
@{const_name "top_fun_inst.top_fun"},
|
bulwahn@36255
|
266 |
@{const_name "Pure.term"},
|
bulwahn@36255
|
267 |
@{const_name "top_class.top"},
|
bulwahn@40901
|
268 |
(*@{const_name "HOL.equal"},*)
|
bulwahn@41217
|
269 |
@{const_name "Quotient.Quot_True"},
|
bulwahn@41217
|
270 |
@{const_name "equal_fun_inst.equal_fun"},
|
bulwahn@41217
|
271 |
@{const_name "equal_bool_inst.equal_bool"},
|
bulwahn@41217
|
272 |
@{const_name "ord_fun_inst.less_eq_fun"},
|
bulwahn@41217
|
273 |
@{const_name "ord_fun_inst.less_fun"},
|
bulwahn@41217
|
274 |
@{const_name Metis.fequal},
|
bulwahn@41217
|
275 |
@{const_name Meson.skolem},
|
bulwahn@41217
|
276 |
@{const_name transfer_morphism}
|
bulwahn@40901
|
277 |
(*@{const_name "==>"}, @{const_name "=="}*)]
|
bulwahn@40901
|
278 |
|
bulwahn@40901
|
279 |
val forbidden_mutant_consts =
|
bulwahn@40901
|
280 |
[
|
bulwahn@40901
|
281 |
(@{const_name "Groups.zero_class.zero"}, @{typ "prop => prop => prop"}),
|
bulwahn@40901
|
282 |
(@{const_name "Groups.one_class.one"}, @{typ "prop => prop => prop"}),
|
bulwahn@40901
|
283 |
(@{const_name "Groups.plus_class.plus"}, @{typ "prop => prop => prop"}),
|
bulwahn@40901
|
284 |
(@{const_name "Groups.minus_class.minus"}, @{typ "prop => prop => prop"}),
|
bulwahn@40901
|
285 |
(@{const_name "Groups.times_class.times"}, @{typ "prop => prop => prop"}),
|
bulwahn@40901
|
286 |
(@{const_name "Rings.inverse_class.divide"}, @{typ "prop => prop => prop"}),
|
bulwahn@40901
|
287 |
(@{const_name "Lattices.semilattice_inf_class.inf"}, @{typ "prop => prop => prop"}),
|
bulwahn@40901
|
288 |
(@{const_name "Lattices.semilattice_sup_class.sup"}, @{typ "prop => prop => prop"}),
|
bulwahn@40901
|
289 |
(@{const_name "Orderings.bot_class.bot"}, @{typ "prop => prop => prop"}),
|
bulwahn@40901
|
290 |
(@{const_name "Orderings.ord_class.min"}, @{typ "prop => prop => prop"}),
|
bulwahn@40901
|
291 |
(@{const_name "Orderings.ord_class.max"}, @{typ "prop => prop => prop"}),
|
bulwahn@40901
|
292 |
(@{const_name "Divides.div_class.mod"}, @{typ "prop => prop => prop"}),
|
bulwahn@40901
|
293 |
(@{const_name "Divides.div_class.div"}, @{typ "prop => prop => prop"}),
|
bulwahn@40901
|
294 |
(@{const_name "GCD.gcd_class.gcd"}, @{typ "prop => prop => prop"}),
|
bulwahn@40901
|
295 |
(@{const_name "GCD.gcd_class.lcm"}, @{typ "prop => prop => prop"}),
|
bulwahn@40901
|
296 |
(@{const_name "Orderings.bot_class.bot"}, @{typ "bool => prop"}),
|
bulwahn@40901
|
297 |
(@{const_name "Groups.one_class.one"}, @{typ "bool => prop"}),
|
bulwahn@40901
|
298 |
(@{const_name "Groups.zero_class.zero"},@{typ "bool => prop"})]
|
bulwahn@36255
|
299 |
|
bulwahn@34952
|
300 |
fun is_forbidden_mutant t =
|
bulwahn@36255
|
301 |
let
|
bulwahn@40901
|
302 |
val const_names = Term.add_const_names t []
|
bulwahn@40901
|
303 |
val consts = Term.add_consts t []
|
bulwahn@36255
|
304 |
in
|
bulwahn@40901
|
305 |
exists (String.isPrefix "Nitpick") const_names orelse
|
bulwahn@40901
|
306 |
exists (String.isSubstring "_sumC") const_names orelse
|
bulwahn@40901
|
307 |
exists (member (op =) forbidden_mutant_constnames) const_names orelse
|
bulwahn@40901
|
308 |
exists (member (op =) forbidden_mutant_consts) consts
|
bulwahn@34952
|
309 |
end
|
bulwahn@34952
|
310 |
|
bulwahn@40901
|
311 |
(* executable via quickcheck *)
|
bulwahn@40901
|
312 |
|
bulwahn@40483
|
313 |
fun is_executable_term thy t =
|
bulwahn@40901
|
314 |
let
|
wenzelm@43232
|
315 |
val ctxt = Proof_Context.init_global thy
|
bulwahn@40901
|
316 |
in
|
bulwahn@40901
|
317 |
can (TimeLimit.timeLimit (seconds 2.0)
|
bulwahn@40901
|
318 |
(Quickcheck.test_goal_terms
|
bulwahn@40901
|
319 |
((Config.put Quickcheck.finite_types true #>
|
bulwahn@41354
|
320 |
Config.put Quickcheck.finite_type_size 1 #>
|
bulwahn@40901
|
321 |
Config.put Quickcheck.size 1 #> Config.put Quickcheck.iterations 1) ctxt)
|
bulwahn@42901
|
322 |
(false, false) [])) (map (rpair [] o Object_Logic.atomize_term thy) (fst (Variable.import_terms true [t] ctxt)))
|
bulwahn@40901
|
323 |
end
|
bulwahn@40483
|
324 |
|
bulwahn@34952
|
325 |
fun is_executable_thm thy th = is_executable_term thy (prop_of th)
|
bulwahn@34952
|
326 |
|
bulwahn@34952
|
327 |
val freezeT =
|
bulwahn@34952
|
328 |
map_types (map_type_tvar (fn ((a, i), S) =>
|
bulwahn@34952
|
329 |
TFree (if i = 0 then a else a ^ "_" ^ string_of_int i, S)))
|
bulwahn@34952
|
330 |
|
bulwahn@34952
|
331 |
fun thms_of all thy =
|
bulwahn@34952
|
332 |
filter
|
bulwahn@34952
|
333 |
(fn th => (all orelse Context.theory_name (theory_of_thm th) = Context.theory_name thy)
|
bulwahn@34952
|
334 |
(* andalso is_executable_thm thy th *))
|
bulwahn@34952
|
335 |
(map snd (filter_out is_forbidden_theorem (Mutabelle.all_unconcealed_thms_of thy)))
|
bulwahn@34952
|
336 |
|
wenzelm@41657
|
337 |
fun count x = (length oo filter o equal) x
|
bulwahn@34952
|
338 |
|
wenzelm@42885
|
339 |
fun cpu_time description e =
|
wenzelm@42885
|
340 |
let val ({cpu, ...}, result) = Timing.timing e ()
|
wenzelm@42885
|
341 |
in (result, (description, Time.toMilliseconds cpu)) end
|
bulwahn@40901
|
342 |
(*
|
bulwahn@40901
|
343 |
fun unsafe_invoke_mtd thy (mtd_name, invoke_mtd) t =
|
bulwahn@40901
|
344 |
let
|
bulwahn@40901
|
345 |
val _ = Output.urgent_message ("Invoking " ^ mtd_name)
|
bulwahn@40901
|
346 |
val ((res, (timing, reports)), time) = cpu_time "total time" (fn () => invoke_mtd thy t
|
bulwahn@40901
|
347 |
handle ERROR s => (tracing s; (Error, ([], NONE))))
|
bulwahn@40901
|
348 |
val _ = Output.urgent_message (" Done")
|
bulwahn@40901
|
349 |
in (res, (time :: timing, reports)) end
|
bulwahn@40901
|
350 |
*)
|
bulwahn@34952
|
351 |
fun safe_invoke_mtd thy (mtd_name, invoke_mtd) t =
|
bulwahn@34952
|
352 |
let
|
wenzelm@40392
|
353 |
val _ = Output.urgent_message ("Invoking " ^ mtd_name)
|
bulwahn@42953
|
354 |
val (res, timing) = (*cpu_time "total time"
|
bulwahn@40901
|
355 |
(fn () => *)case try (invoke_mtd thy) t of
|
bulwahn@42953
|
356 |
SOME (res, timing) => (res, timing)
|
wenzelm@40392
|
357 |
| NONE => (Output.urgent_message ("**** PROBLEMS WITH " ^ Syntax.string_of_term_global thy t);
|
bulwahn@42953
|
358 |
(Error, []))
|
wenzelm@40392
|
359 |
val _ = Output.urgent_message (" Done")
|
bulwahn@42953
|
360 |
in (res, timing) end
|
bulwahn@34952
|
361 |
|
bulwahn@34952
|
362 |
(* theory -> term list -> mtd -> subentry *)
|
bulwahn@40901
|
363 |
|
bulwahn@34952
|
364 |
fun test_mutants_using_one_method thy mutants (mtd_name, invoke_mtd) =
|
bulwahn@34952
|
365 |
let
|
bulwahn@40901
|
366 |
val res = map (fst o safe_invoke_mtd thy (mtd_name, invoke_mtd)) mutants
|
bulwahn@34952
|
367 |
in
|
bulwahn@34952
|
368 |
(mtd_name, count GenuineCex res, count PotentialCex res, count NoCex res,
|
bulwahn@34952
|
369 |
count Donno res, count Timeout res, count Error res)
|
bulwahn@34952
|
370 |
end
|
bulwahn@34952
|
371 |
|
bulwahn@40901
|
372 |
(* creating entries *)
|
bulwahn@40901
|
373 |
|
bulwahn@34952
|
374 |
fun create_entry thy thm exec mutants mtds =
|
wenzelm@36752
|
375 |
(Thm.get_name_hint thm, exec, map (test_mutants_using_one_method thy mutants) mtds)
|
bulwahn@40901
|
376 |
|
bulwahn@34952
|
377 |
fun create_detailed_entry thy thm exec mutants mtds =
|
bulwahn@34952
|
378 |
let
|
bulwahn@34952
|
379 |
fun create_mutant_subentry mutant = (mutant,
|
bulwahn@34952
|
380 |
map (fn (mtd_name, invoke_mtd) =>
|
bulwahn@34952
|
381 |
(mtd_name, safe_invoke_mtd thy (mtd_name, invoke_mtd) mutant)) mtds)
|
bulwahn@34952
|
382 |
in
|
wenzelm@36752
|
383 |
(Thm.get_name_hint thm, exec, prop_of thm, map create_mutant_subentry mutants)
|
bulwahn@34952
|
384 |
end
|
bulwahn@34952
|
385 |
|
bulwahn@34952
|
386 |
(* (theory -> thm -> bool -> term list -> mtd list -> 'a) -> theory -> mtd list -> thm -> 'a *)
|
bulwahn@34952
|
387 |
fun mutate_theorem create_entry thy mtds thm =
|
bulwahn@34952
|
388 |
let
|
bulwahn@34952
|
389 |
val exec = is_executable_thm thy thm
|
bulwahn@40901
|
390 |
val _ = Output.tracing (if exec then "EXEC" else "NOEXEC")
|
bulwahn@34952
|
391 |
val mutants =
|
bulwahn@34952
|
392 |
(if num_mutations = 0 then
|
bulwahn@34952
|
393 |
[Thm.prop_of thm]
|
bulwahn@34952
|
394 |
else
|
bulwahn@34952
|
395 |
Mutabelle.mutate_mix (Thm.prop_of thm) thy comms forbidden
|
bulwahn@34952
|
396 |
num_mutations)
|
bulwahn@40901
|
397 |
|> tap (fn muts => tracing ("mutants: " ^ string_of_int (length muts)))
|
bulwahn@34952
|
398 |
|> filter_out is_forbidden_mutant
|
bulwahn@34952
|
399 |
val mutants =
|
bulwahn@34952
|
400 |
if exec then
|
bulwahn@34952
|
401 |
let
|
wenzelm@40392
|
402 |
val _ = Output.urgent_message ("BEFORE PARTITION OF " ^
|
wenzelm@41739
|
403 |
string_of_int (length mutants) ^ " MUTANTS")
|
bulwahn@34952
|
404 |
val (execs, noexecs) = List.partition (is_executable_term thy) (take_random (20 * max_mutants) mutants)
|
wenzelm@41739
|
405 |
val _ = tracing ("AFTER PARTITION (" ^ string_of_int (length execs) ^
|
wenzelm@41739
|
406 |
" vs " ^ string_of_int (length noexecs) ^ ")")
|
bulwahn@34952
|
407 |
in
|
bulwahn@34952
|
408 |
execs @ take_random (Int.max (0, max_mutants - length execs)) noexecs
|
bulwahn@34952
|
409 |
end
|
bulwahn@34952
|
410 |
else
|
bulwahn@34952
|
411 |
mutants
|
bulwahn@34952
|
412 |
val mutants = mutants
|
bulwahn@34952
|
413 |
|> map Mutabelle.freeze |> map freezeT
|
bulwahn@34952
|
414 |
(* |> filter (not o is_forbidden_mutant) *)
|
wenzelm@43308
|
415 |
|> map_filter (try (Sign.cert_term thy))
|
wenzelm@43308
|
416 |
|> filter (is_some o try (Thm.cterm_of thy))
|
wenzelm@43308
|
417 |
|> filter (is_some o try (Syntax.check_term (Proof_Context.init_global thy)))
|
bulwahn@41217
|
418 |
|> take_random max_mutants
|
wenzelm@40392
|
419 |
val _ = map (fn t => Output.urgent_message ("MUTANT: " ^ Syntax.string_of_term_global thy t)) mutants
|
bulwahn@34952
|
420 |
in
|
bulwahn@34952
|
421 |
create_entry thy thm exec mutants mtds
|
bulwahn@34952
|
422 |
end
|
bulwahn@34952
|
423 |
|
bulwahn@34952
|
424 |
(* theory -> mtd list -> thm list -> report *)
|
bulwahn@34952
|
425 |
val mutate_theorems = map ooo mutate_theorem
|
bulwahn@34952
|
426 |
|
bulwahn@35324
|
427 |
fun string_of_mutant_subentry thy thm_name (t, results) =
|
bulwahn@34952
|
428 |
"mutant: " ^ Syntax.string_of_term_global thy t ^ "\n" ^
|
bulwahn@35324
|
429 |
space_implode "; "
|
bulwahn@35324
|
430 |
(map (fn (mtd_name, (outcome, timing)) => mtd_name ^ ": " ^ string_of_outcome outcome) results) ^
|
bulwahn@34952
|
431 |
"\n"
|
bulwahn@34952
|
432 |
|
bulwahn@36255
|
433 |
(* string -> string *)
|
wenzelm@39812
|
434 |
val unyxml = XML.content_of o YXML.parse_body
|
bulwahn@36255
|
435 |
|
bulwahn@35324
|
436 |
fun string_of_mutant_subentry' thy thm_name (t, results) =
|
bulwahn@35380
|
437 |
let
|
bulwahn@42953
|
438 |
(* fun string_of_report (Quickcheck.Report {iterations = i, raised_match_errors = e,
|
bulwahn@35380
|
439 |
satisfied_assms = s, positive_concl_tests = p}) =
|
bulwahn@35380
|
440 |
"errors: " ^ string_of_int e ^ "; conclusion tests: " ^ string_of_int p
|
bulwahn@35380
|
441 |
fun string_of_reports NONE = ""
|
bulwahn@35380
|
442 |
| string_of_reports (SOME reports) =
|
bulwahn@35380
|
443 |
cat_lines (map (fn (size, [report]) =>
|
bulwahn@42953
|
444 |
"size " ^ string_of_int size ^ ": " ^ string_of_report report) (rev reports))*)
|
bulwahn@42953
|
445 |
fun string_of_mtd_result (mtd_name, (outcome, timing)) =
|
bulwahn@40901
|
446 |
mtd_name ^ ": " ^ string_of_outcome outcome
|
bulwahn@40901
|
447 |
(*" with time " ^ " (" ^ space_implode "; " (map (fn (s, t) => (s ^ ": " ^ string_of_int t)) timing) ^ ")"*)
|
bulwahn@36255
|
448 |
(*^ "\n" ^ string_of_reports reports*)
|
bulwahn@35380
|
449 |
in
|
bulwahn@36255
|
450 |
"mutant of " ^ thm_name ^ ":\n"
|
bulwahn@40901
|
451 |
^ unyxml (Syntax.string_of_term_global thy t) ^ "\n" ^ space_implode "; " (map string_of_mtd_result results)
|
bulwahn@35380
|
452 |
end
|
bulwahn@35324
|
453 |
|
bulwahn@34952
|
454 |
fun string_of_detailed_entry thy (thm_name, exec, t, mutant_subentries) =
|
bulwahn@34952
|
455 |
thm_name ^ " " ^ (if exec then "[exe]" else "[noexe]") ^ ": " ^
|
bulwahn@36255
|
456 |
Syntax.string_of_term_global thy t ^ "\n" ^
|
bulwahn@35324
|
457 |
cat_lines (map (string_of_mutant_subentry' thy thm_name) mutant_subentries) ^ "\n"
|
bulwahn@34952
|
458 |
|
bulwahn@36255
|
459 |
fun theoryfile_string_of_mutant_subentry thy thm_name (i, (t, results)) =
|
bulwahn@36255
|
460 |
"lemma " ^ thm_name ^ "_" ^ string_of_int (i + 1) ^ ":\n" ^
|
bulwahn@36255
|
461 |
"\"" ^ unyxml (Syntax.string_of_term_global thy t) ^
|
bulwahn@40901
|
462 |
"\" \nquickcheck\noops\n"
|
bulwahn@36255
|
463 |
|
bulwahn@36255
|
464 |
fun theoryfile_string_of_detailed_entry thy (thm_name, exec, t, mutant_subentries) =
|
bulwahn@36255
|
465 |
"subsubsection {* mutants of " ^ thm_name ^ " *}\n\n" ^
|
bulwahn@36255
|
466 |
cat_lines (map_index
|
bulwahn@36255
|
467 |
(theoryfile_string_of_mutant_subentry thy thm_name) mutant_subentries) ^ "\n"
|
bulwahn@36255
|
468 |
|
bulwahn@34952
|
469 |
(* subentry -> string *)
|
bulwahn@34952
|
470 |
fun string_for_subentry (mtd_name, genuine_cex, potential_cex, no_cex, donno,
|
bulwahn@34952
|
471 |
timeout, error) =
|
wenzelm@41739
|
472 |
" " ^ mtd_name ^ ": " ^ string_of_int genuine_cex ^ "+ " ^
|
wenzelm@41739
|
473 |
string_of_int potential_cex ^ "= " ^ string_of_int no_cex ^ "- " ^
|
wenzelm@41739
|
474 |
string_of_int donno ^ "? " ^ string_of_int timeout ^ "T " ^
|
wenzelm@41739
|
475 |
string_of_int error ^ "!"
|
bulwahn@40901
|
476 |
|
bulwahn@34952
|
477 |
(* entry -> string *)
|
bulwahn@34952
|
478 |
fun string_for_entry (thm_name, exec, subentries) =
|
bulwahn@34952
|
479 |
thm_name ^ " " ^ (if exec then "[exe]" else "[noexe]") ^ ":\n" ^
|
bulwahn@34952
|
480 |
cat_lines (map string_for_subentry subentries) ^ "\n"
|
bulwahn@40901
|
481 |
|
bulwahn@34952
|
482 |
(* report -> string *)
|
bulwahn@34952
|
483 |
fun string_for_report report = cat_lines (map string_for_entry report)
|
bulwahn@34952
|
484 |
|
bulwahn@34952
|
485 |
(* string -> report -> unit *)
|
bulwahn@34952
|
486 |
fun write_report file_name =
|
bulwahn@34952
|
487 |
File.write (Path.explode file_name) o string_for_report
|
bulwahn@34952
|
488 |
|
bulwahn@34952
|
489 |
(* theory -> mtd list -> thm list -> string -> unit *)
|
bulwahn@34952
|
490 |
fun mutate_theorems_and_write_report thy mtds thms file_name =
|
bulwahn@34952
|
491 |
let
|
wenzelm@40392
|
492 |
val _ = Output.urgent_message "Starting Mutabelle..."
|
wenzelm@43232
|
493 |
val ctxt = Proof_Context.init_global thy
|
bulwahn@34952
|
494 |
val path = Path.explode file_name
|
bulwahn@34952
|
495 |
(* for normal report: *)
|
bulwahn@40901
|
496 |
(*
|
bulwahn@40901
|
497 |
val (gen_create_entry, gen_string_for_entry) = (create_entry, string_for_entry)
|
bulwahn@40901
|
498 |
*)
|
bulwahn@40901
|
499 |
(* for detailled report: *)
|
bulwahn@40901
|
500 |
val (gen_create_entry, gen_string_for_entry) = (create_detailed_entry, string_of_detailed_entry thy)
|
bulwahn@40901
|
501 |
(* for theory creation: *)
|
bulwahn@40901
|
502 |
(*val (gen_create_entry, gen_string_for_entry) = (create_detailed_entry, theoryfile_string_of_detailed_entry thy)*)
|
bulwahn@34952
|
503 |
in
|
bulwahn@34952
|
504 |
File.write path (
|
bulwahn@34952
|
505 |
"Mutation options = " ^
|
bulwahn@34952
|
506 |
"max_mutants: " ^ string_of_int max_mutants ^
|
bulwahn@34952
|
507 |
"; num_mutations: " ^ string_of_int num_mutations ^ "\n" ^
|
bulwahn@34952
|
508 |
"QC options = " ^
|
bulwahn@34952
|
509 |
(*"quickcheck_generator: " ^ quickcheck_generator ^ ";*)
|
bulwahn@40901
|
510 |
"size: " ^ string_of_int (Config.get ctxt Quickcheck.size) ^
|
bulwahn@40901
|
511 |
"; iterations: " ^ string_of_int (Config.get ctxt Quickcheck.iterations) ^ "\n");
|
bulwahn@34952
|
512 |
map (File.append path o gen_string_for_entry o mutate_theorem gen_create_entry thy mtds) thms;
|
bulwahn@34952
|
513 |
()
|
bulwahn@34952
|
514 |
end
|
bulwahn@34952
|
515 |
|
bulwahn@34952
|
516 |
end;
|