1 | ;-*- Mode: Lisp -*- |
---|
2 | ;;;; Author: Paul Dietz |
---|
3 | ;;;; Created: Mon Oct 6 05:04:45 2003 |
---|
4 | ;;;; Contains: Generating random types and testing relationships on them |
---|
5 | |
---|
6 | (in-package :cl-test) |
---|
7 | |
---|
8 | (compile-and-load "types-aux.lsp") |
---|
9 | (compile-and-load "random-aux.lsp") |
---|
10 | (compile-and-load "random-int-form.lsp") |
---|
11 | |
---|
12 | (defparameter *random-types* nil) |
---|
13 | |
---|
14 | (defun make-random-type (size) |
---|
15 | (if (<= size 1) |
---|
16 | (rcase |
---|
17 | (1 nil) |
---|
18 | (1 t) |
---|
19 | (1 `(eql ,(let ((r (ash 1 (random 45)))) |
---|
20 | (random-from-interval r (- r))))) |
---|
21 | (1 (random-from-seq #(integer unsigned-byte ratio rational real float |
---|
22 | short-float single-float double-float |
---|
23 | long-float complex symbol cons function))) |
---|
24 | (1 |
---|
25 | (let* ((len (random *maximum-random-int-bits*)) |
---|
26 | (r1 (ash 1 len)) |
---|
27 | (r2 (+ r1 r1)) |
---|
28 | (x (- (random r2) r1)) |
---|
29 | (y (- (random r2) r1)) |
---|
30 | (lo (min x y)) |
---|
31 | (hi (max x y))) |
---|
32 | `(integer ,lo ,hi))) |
---|
33 | (1 (make-random-real-type)) |
---|
34 | ;; (1 (make-random-complex-type)) |
---|
35 | ) |
---|
36 | (rcase |
---|
37 | (2 (let* ((op (random-from-seq #(cons cons and or))) |
---|
38 | (nargs (if (eq op 'cons) 2 |
---|
39 | (1+ (random (min size 4))))) |
---|
40 | (sizes (random-partition (1- size) nargs))) |
---|
41 | `(,op ,@(mapcar #'make-random-type sizes)))) |
---|
42 | (1 `(not ,(make-random-type (1- size)))) |
---|
43 | ; (1 (make-random-function-type size)) |
---|
44 | ))) |
---|
45 | |
---|
46 | (defun make-random-real-type () |
---|
47 | (rcase |
---|
48 | (1 (random-from-seq '(integer unsigned-byte short-float single-float |
---|
49 | double-float long-float rational real))) |
---|
50 | (1 (destructuring-bind (lo hi) |
---|
51 | (make-random-integer-range) |
---|
52 | (rcase |
---|
53 | (4 `(integer ,lo ,hi)) |
---|
54 | (1 `(integer ,lo)) |
---|
55 | (1 `(integer ,lo *)) |
---|
56 | (2 `(integer * ,hi))))) |
---|
57 | (1 (let ((r1 (random-real)) |
---|
58 | (r2 (random-real))) |
---|
59 | `(real ,(min r1 r2) ,(max r2 r2)))) |
---|
60 | ;;; Add more cases here |
---|
61 | )) |
---|
62 | |
---|
63 | (defun make-random-complex-type () |
---|
64 | `(complex ,(make-random-real-type))) |
---|
65 | |
---|
66 | (defun make-random-function-type (size) |
---|
67 | (let* ((sizes (random-partition (1- size) 2)) |
---|
68 | (types (mapcar #'make-random-type sizes))) |
---|
69 | `(function (,(car types)) ,(cadr types)))) |
---|
70 | |
---|
71 | (defun size-of-type (type) |
---|
72 | (if (consp type) |
---|
73 | (case (car type) |
---|
74 | (complex (1+ (size-of-type (cadr type)))) |
---|
75 | ((array simple-array) (1+ (size-of-type (cadr type)))) |
---|
76 | (vector (1+ (size-of-type (cadr type)))) |
---|
77 | (complex (1+ (size-of-type (cadr type)))) |
---|
78 | ((cons or and not) (reduce #'+ (cdr type) :initial-value 1 |
---|
79 | :key #'size-of-type)) |
---|
80 | (t 1)) |
---|
81 | 1)) |
---|
82 | |
---|
83 | (defun mutate-type (type) |
---|
84 | (let* ((size (size-of-type type)) |
---|
85 | (r (random size))) |
---|
86 | (flet ((%f () |
---|
87 | (rcase |
---|
88 | (6 (make-random-type (random (1+ size)))) |
---|
89 | (2 `(not ,type)) |
---|
90 | (1 `(and ,(make-random-type 1) ,type)) |
---|
91 | (1 `(and ,type ,(make-random-type 1))) |
---|
92 | (1 `(or ,(make-random-type 1) ,type)) |
---|
93 | (1 `(or ,type ,(make-random-type 1))))) |
---|
94 | (%random-int () |
---|
95 | (let ((bits (1+ (min (random 20) (random 20))))) |
---|
96 | (- (ash 1 bits) (random (ash 1 (1+ bits))))))) |
---|
97 | (if (or (and (= r 0) (coin)) (not (consp type))) |
---|
98 | (%f) |
---|
99 | (case (car type) |
---|
100 | ((and or not cons complex) |
---|
101 | (let ((sizes (mapcar #'size-of-type (cdr type)))) |
---|
102 | (loop with sum = 0 |
---|
103 | for e on sizes |
---|
104 | for ctype in (cdr type) |
---|
105 | for i from 0 |
---|
106 | do (setf sum (incf (car e) sum)) |
---|
107 | when (>= sum r) |
---|
108 | return (rcase |
---|
109 | (1 ctype) ;; replace with component type |
---|
110 | (1 (cons (car type) |
---|
111 | (append (subseq (cdr type) 0 i) |
---|
112 | (list (mutate-type ctype)) |
---|
113 | (subseq (cdr type) (1+ i))))))))) |
---|
114 | ((array simple-array vector) |
---|
115 | (let ((ctype (if (cdr type) (cadr type) t))) |
---|
116 | (rcase |
---|
117 | (1 (if (eql ctype *) t ctype)) |
---|
118 | (1 (cons (car type) |
---|
119 | (cons (mutate-type ctype) |
---|
120 | (cddr type))))))) |
---|
121 | ((unsigned-byte) |
---|
122 | (if (integerp (cadr type)) |
---|
123 | (rcase |
---|
124 | (1 'unsigned-byte) |
---|
125 | (1 `(unsigned-byte (+ (cadr type) (- 10 (random 20)))))) |
---|
126 | (%f))) |
---|
127 | |
---|
128 | ((integer) |
---|
129 | (let ((lo-delta (%random-int)) |
---|
130 | (hi-delta (%random-int)) |
---|
131 | (old-lo (or (cadr type) '*)) |
---|
132 | (old-hi (or (caddr type) '*))) |
---|
133 | (flet ((%inc (old delta) |
---|
134 | (if (or (coin) (not (integerp old))) |
---|
135 | delta |
---|
136 | (+ old delta)))) |
---|
137 | (rcase |
---|
138 | (1 `(integer ,old-lo *)) |
---|
139 | (1 `(integer * ,old-hi)) |
---|
140 | (1 (let ((new-lo (%inc old-lo lo-delta))) |
---|
141 | (if (or (null (cdr type)) |
---|
142 | (null (cddr type)) |
---|
143 | (not (integerp old-hi))) |
---|
144 | `(integer ,new-lo ,@(cddr type)) |
---|
145 | ;; caddr is integer |
---|
146 | (if (<= new-lo old-hi) |
---|
147 | `(integer ,new-lo ,old-hi) |
---|
148 | `(integer ,old-hi ,new-lo))))) |
---|
149 | (1 (let ((new-hi (%inc old-hi hi-delta))) |
---|
150 | (if (or (null (cdr type)) |
---|
151 | (null (cddr type)) |
---|
152 | (not (integerp old-lo))) |
---|
153 | `(integer ,old-lo ,new-hi) |
---|
154 | (if (<= old-lo new-hi) |
---|
155 | `(integer ,old-lo ,new-hi) |
---|
156 | `(integer ,new-hi ,old-lo))))) |
---|
157 | (1 (let ((new-lo (%inc old-lo lo-delta)) |
---|
158 | (new-hi (%inc old-hi hi-delta))) |
---|
159 | (if (<= new-lo new-hi) |
---|
160 | `(integer ,new-lo ,new-hi) |
---|
161 | `(integer ,new-hi ,new-lo)))))))) |
---|
162 | |
---|
163 | (t (%f))))))) |
---|
164 | |
---|
165 | (defun test-random-types (n size) |
---|
166 | (loop for t1 = (make-random-type size) |
---|
167 | for t2 = (make-random-type size) |
---|
168 | for i from 0 below n |
---|
169 | ;; do (print (list t1 t2)) |
---|
170 | do (setf *random-types* (list t1 t2)) |
---|
171 | do (when (and (= (mod i 100) 0) (> i 0)) |
---|
172 | (format t "~A " i) (finish-output *standard-output*)) |
---|
173 | when (test-types t1 t2) |
---|
174 | collect (list t1 t2) |
---|
175 | finally (terpri))) |
---|
176 | |
---|
177 | (defun test-random-mutated-types (n size &key (reps 1)) |
---|
178 | (loop for t1 = (make-random-type size) |
---|
179 | for t2 = (let ((x t1)) (loop repeat reps |
---|
180 | do (setq x (mutate-type x))) x) |
---|
181 | for i from 0 below n |
---|
182 | ;; do (print (list t1 t2)) |
---|
183 | do (setf *random-types* (list t1 t2)) |
---|
184 | do (when (and (= (mod i 100) 0) (> i 0)) |
---|
185 | (format t "~A " i) (finish-output *standard-output*)) |
---|
186 | when (test-types t1 t2) |
---|
187 | collect (list t1 t2) |
---|
188 | finally (terpri))) |
---|
189 | |
---|
190 | (defun test-types (t1 t2) |
---|
191 | (multiple-value-bind (sub success) |
---|
192 | (subtypep t1 t2) |
---|
193 | (when success |
---|
194 | (if sub |
---|
195 | (check-all-subtypep t1 t2) |
---|
196 | (let ((nt1 `(not ,t1)) |
---|
197 | (nt2 `(not ,t2))) |
---|
198 | (subtypep nt2 nt1)))))) |
---|
199 | |
---|
200 | (defun prune-type (tp try-fn) |
---|
201 | (declare (type function try-fn)) |
---|
202 | (flet ((try (x) (funcall try-fn x))) |
---|
203 | (cond |
---|
204 | ((member tp '(nil t))) |
---|
205 | ((symbolp tp) |
---|
206 | (try nil) |
---|
207 | (try t)) |
---|
208 | ((consp tp) |
---|
209 | (try nil) |
---|
210 | (try t) |
---|
211 | (let ((op (first tp)) |
---|
212 | (args (rest tp))) |
---|
213 | (case op |
---|
214 | ((cons) |
---|
215 | (try 'cons) |
---|
216 | (prune-list args |
---|
217 | #'prune-type |
---|
218 | #'(lambda (args) (try `(cons ,@args))))) |
---|
219 | ((integer) |
---|
220 | (try op) |
---|
221 | (try '(eql 0)) |
---|
222 | (when (= (length args) 2) |
---|
223 | (let ((arg1 (first args)) |
---|
224 | (arg2 (second args))) |
---|
225 | (when (and (integerp arg1) (integerp arg2)) |
---|
226 | (try `(eql ,arg1)) |
---|
227 | (try `(eql ,arg2)) |
---|
228 | (when (and (< arg1 0) (<= 0 arg2)) |
---|
229 | (try `(integer 0 ,arg2))) |
---|
230 | (when (and (<= arg1 0) (< 0 arg2)) |
---|
231 | (try `(integer ,arg1 0))) |
---|
232 | (when (> (- arg2 arg1) 1) |
---|
233 | (try `(integer ,(+ arg1 (floor (- arg2 arg1) 2)) ,arg2)) |
---|
234 | (try `(integer ,arg1 ,(- arg2 (floor (- arg2 arg1) 2))))))))) |
---|
235 | |
---|
236 | ((real float ratio single-float double-float short-float long-float) |
---|
237 | (try op)) |
---|
238 | |
---|
239 | ((or and) |
---|
240 | (mapc try-fn args) |
---|
241 | (loop for i from 0 below (length args) |
---|
242 | do (try `(,op ,@(subseq args 0 i) |
---|
243 | ,@(subseq args (1+ i))))) |
---|
244 | (prune-list args |
---|
245 | #'prune-type |
---|
246 | #'(lambda (args) (try (cons op args))))) |
---|
247 | ((not) |
---|
248 | (let ((arg (first args))) |
---|
249 | (try arg) |
---|
250 | (when (and (consp arg) |
---|
251 | (eq (car arg) 'not)) |
---|
252 | (try (second arg))) |
---|
253 | (prune-type arg #'(lambda (arg) (try `(not ,arg)))))) |
---|
254 | |
---|
255 | ((member) |
---|
256 | (dolist (arg (cdr tp)) |
---|
257 | (try `(eql ,arg))) |
---|
258 | (when (cddr tp) |
---|
259 | (try `(member ,@(cddr tp))))) |
---|
260 | |
---|
261 | ((eql) |
---|
262 | (assert (= (length args) 1)) |
---|
263 | (let ((arg (first args))) |
---|
264 | (unless (= arg 0) |
---|
265 | (try `(eql 0)) |
---|
266 | (cond |
---|
267 | ((< arg -1) |
---|
268 | (try `(eql ,(ceiling arg 2)))) |
---|
269 | ((> arg 1) |
---|
270 | (try `(eql ,(floor arg 2)))))))) |
---|
271 | |
---|
272 | ))))) |
---|
273 | (values)) |
---|
274 | |
---|
275 | (defun prune-type-pair (pair &optional (fn #'test-types)) |
---|
276 | (declare (type function fn)) |
---|
277 | (let ((t1 (first pair)) |
---|
278 | (t2 (second pair)) |
---|
279 | changed) |
---|
280 | (loop |
---|
281 | do (flet ((%try2 (new-tp) |
---|
282 | (when (funcall fn t1 new-tp) |
---|
283 | (print "Success in first loop") |
---|
284 | (print new-tp) |
---|
285 | (setq t2 new-tp |
---|
286 | changed t) |
---|
287 | (throw 'success nil)))) |
---|
288 | (catch 'success |
---|
289 | (prune-type t2 #'%try2))) |
---|
290 | do (flet ((%try1 (new-tp) |
---|
291 | (when (funcall fn new-tp t2) |
---|
292 | (print "Success in second loop") |
---|
293 | (print new-tp) |
---|
294 | (setq t1 new-tp |
---|
295 | changed t) |
---|
296 | (throw 'success nil)))) |
---|
297 | (catch 'success |
---|
298 | (prune-type t1 #'%try1))) |
---|
299 | while changed |
---|
300 | do (setq changed nil)) |
---|
301 | (list t1 t2))) |
---|
302 | |
---|
303 | (defun test-type-triple (t1 t2 t3) |
---|
304 | ;; Returns non-nil if a problem is found |
---|
305 | (catch 'problem |
---|
306 | (multiple-value-bind (sub1 success1) |
---|
307 | (subtypep t1 t2) |
---|
308 | (when success1 |
---|
309 | (if sub1 |
---|
310 | (append |
---|
311 | (check-all-subtypep t1 `(or ,t2 ,t3)) |
---|
312 | (check-all-subtypep `(and ,t1 ,t3) t2)) |
---|
313 | (or (subtypep `(or ,t1 ,t3) t2) |
---|
314 | (subtypep t1 `(and ,t2 ,t3)))))))) |
---|
315 | |
---|
316 | (defun test-random-types3 (n size) |
---|
317 | (loop for t1 = (make-random-type (1+ (random size))) |
---|
318 | for t2 = (make-random-type (1+ (random size))) |
---|
319 | for t3 = (make-random-type (1+ (random size))) |
---|
320 | for i from 1 to n |
---|
321 | ;; do (print (list t1 t2)) |
---|
322 | do (setf *random-types* (list t1 t2 t3)) |
---|
323 | do (when (and (= (mod i 100) 0) (> i 0)) |
---|
324 | (format t "~A " i) (finish-output *standard-output*)) |
---|
325 | when (test-type-triple t1 t2 t3) |
---|
326 | collect (list t1 t2 t3) |
---|
327 | finally (terpri))) |
---|
328 | |
---|
329 | (defun prune-type-triple (pair &optional (fn #'test-type-triple)) |
---|
330 | (declare (type function fn)) |
---|
331 | (let ((t1 (first pair)) |
---|
332 | (t2 (second pair)) |
---|
333 | (t3 (third pair)) |
---|
334 | changed) |
---|
335 | (loop |
---|
336 | do (flet ((%try2 (new-tp) |
---|
337 | (when (funcall fn t1 new-tp t3) |
---|
338 | (print "Success in first loop") |
---|
339 | (print new-tp) |
---|
340 | (setq t2 new-tp |
---|
341 | changed t) |
---|
342 | (throw 'success nil)))) |
---|
343 | (catch 'success |
---|
344 | (prune-type t2 #'%try2))) |
---|
345 | do (flet ((%try1 (new-tp) |
---|
346 | (when (funcall fn new-tp t2 t3) |
---|
347 | (print "Success in second loop") |
---|
348 | (print new-tp) |
---|
349 | (setq t1 new-tp |
---|
350 | changed t) |
---|
351 | (throw 'success nil)))) |
---|
352 | (catch 'success |
---|
353 | (prune-type t1 #'%try1))) |
---|
354 | do (flet ((%try3 (new-tp) |
---|
355 | (when (funcall fn t1 t2 new-tp) |
---|
356 | (print "Success in second loop") |
---|
357 | (print new-tp) |
---|
358 | (setq t3 new-tp |
---|
359 | changed t) |
---|
360 | (throw 'success nil)))) |
---|
361 | (catch 'success |
---|
362 | (prune-type t3 #'%try3))) |
---|
363 | while changed |
---|
364 | do (setq changed nil)) |
---|
365 | (list t1 t2 t3))) |
---|
366 | |
---|
367 | |
---|
368 | |
---|
369 | |
---|