21 |
(1 (random-from-seq #(integer unsigned-byte ratio rational real float |
(1 (random-from-seq #(integer unsigned-byte ratio rational real float |
22 |
short-float single-float double-float |
short-float single-float double-float |
23 |
long-float complex symbol cons function))) |
long-float complex symbol cons function))) |
|
#| |
|
24 |
(1 |
(1 |
25 |
(let* ((len (random *maximum-random-int-bits*)) |
(let* ((len (random *maximum-random-int-bits*)) |
26 |
(r1 (ash 1 len)) |
(r1 (ash 1 len)) |
30 |
(lo (min x y)) |
(lo (min x y)) |
31 |
(hi (max x y))) |
(hi (max x y))) |
32 |
`(integer ,lo ,hi))) |
`(integer ,lo ,hi))) |
|
|# |
|
33 |
(1 (make-random-real-type)) |
(1 (make-random-real-type)) |
34 |
(1 (make-random-complex-type)) |
;; (1 (make-random-complex-type)) |
35 |
) |
) |
36 |
(rcase |
(rcase |
37 |
(2 (let* ((op (random-from-seq #(cons cons and or))) |
(2 (let* ((op (random-from-seq #(cons cons and or))) |
68 |
(types (mapcar #'make-random-type sizes))) |
(types (mapcar #'make-random-type sizes))) |
69 |
`(function (,(car types)) ,(cadr types)))) |
`(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) |
(defun test-random-types (n size) |
166 |
(loop for t1 = (make-random-type size) |
(loop for t1 = (make-random-type size) |
167 |
for t2 = (make-random-type size) |
for t2 = (make-random-type size) |
173 |
when (test-types t1 t2) |
when (test-types t1 t2) |
174 |
collect (list t1 t2) |
collect (list t1 t2) |
175 |
finally (terpri))) |
finally (terpri))) |
176 |
|
|
177 |
|
(defun test-random-mutated-types (n size) |
178 |
|
(loop for t1 = (make-random-type size) |
179 |
|
for t2 = (mutate-type t1) |
180 |
|
for i from 0 below n |
181 |
|
;; do (print (list t1 t2)) |
182 |
|
do (setf *random-types* (list t1 t2)) |
183 |
|
do (when (and (= (mod i 100) 0) (> i 0)) |
184 |
|
(format t "~A " i) (finish-output *standard-output*)) |
185 |
|
when (test-types t1 t2) |
186 |
|
collect (list t1 t2) |
187 |
|
finally (terpri))) |
188 |
|
|
189 |
(defun test-types (t1 t2) |
(defun test-types (t1 t2) |
190 |
(multiple-value-bind (sub success) |
(multiple-value-bind (sub success) |