11 |
|
|
12 |
(defgeneric make-random-element-of-compound-type (type args &key &allow-other-keys) |
(defgeneric make-random-element-of-compound-type (type args &key &allow-other-keys) |
13 |
(:documentation |
(:documentation |
14 |
"Create a random elemtn of (TYPE . ARGS), or throw an error if it can't figure out how to do it.")) |
"Create a random element of (TYPE . ARGS), or throw an error if it can't figure out how to do it.")) |
15 |
|
|
16 |
(defmethod make-random-element-of ((type cons)) |
(defmethod make-random-element-of ((type cons)) |
17 |
(apply #'make-random-element-of-compound-type type)) |
(make-random-element-of-compound-type (car type) (cdr type))) |
18 |
|
|
19 |
(defmethod make-random-element-of ((type (eql bit))) (random 2)) |
(defmethod make-random-element-of ((type (eql bit))) (random 2)) |
20 |
|
|
28 |
(random-from-interval |
(random-from-interval |
29 |
(1+ (ash 1 (random *maximum-random-int-bits*))))) |
(1+ (ash 1 (random *maximum-random-int-bits*))))) |
30 |
|
|
31 |
|
(defmethod make-random-elememt-of ((type (eql signed-byte))) |
32 |
|
(random-from-interval |
33 |
|
(1+ (ash 1 (random *maximum-random-int-bits*))) |
34 |
|
(- (ash 1 (random *maximum-random-int-bits*))))) |
35 |
|
|
36 |
(defmethod make-random-element-of ((type (eql rational))) |
(defmethod make-random-element-of ((type (eql rational))) |
37 |
(let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) |
(let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) |
38 |
(n (random r)) |
(n (random r)) |
47 |
(1 (- (make-random-element-of 'integer) x)) |
(1 (- (make-random-element-of 'integer) x)) |
48 |
(6 (random-from-interval (1+ x) (- x)))))) |
(6 (random-from-interval (1+ x) (- x)))))) |
49 |
|
|
50 |
|
(defmethod make-random-element-of ((type (eql short-float))) |
51 |
|
(make-random-element-of (list type))) |
52 |
|
|
53 |
|
(defmethod make-random-element-of ((type (eql single-float))) |
54 |
|
(make-random-element-of (list type))) |
55 |
|
|
56 |
|
(defmethod make-random-element-of ((type (eql double-float))) |
57 |
|
(make-random-element-of (list type))) |
58 |
|
|
59 |
|
(defmethod make-random-element-of ((type (eql long-float))) |
60 |
|
(make-random-element-of (list type))) |
61 |
|
|
62 |
|
(defmethod make-random-element-of ((type (eql float))) |
63 |
|
(make-random-element-of |
64 |
|
(list (random-from-seq #'(short-float single-float double-float long-float))))) |
65 |
|
|
66 |
|
(defmethod make-random-element-of ((type (eql real))) |
67 |
|
(make-random-element-of (random-from-seq #(integer rational float)))) |
68 |
|
|
69 |
|
(defmethod make-random-element-of ((type (eql ratio))) |
70 |
|
(loop for x = (make-random-element-of 'rational) |
71 |
|
unless (integerp x) return x)) |
72 |
|
|
73 |
|
(defmethod make-random-element-of ((type complex)) |
74 |
|
(make-random-element-of '(complex real))) |
75 |
|
|
76 |
|
(defmethod make-random-element-of ((type fixnum)) |
77 |
|
(make-random-element-of `(integer ,most-negative-fixnum ,most-positive-fixnum))) |
78 |
|
|
79 |
|
(defmethod make-random-element-of ((type bignum)) |
80 |
|
(make-random-element-of `(or (integer * (,most-negative-fixnum)) |
81 |
|
(integer (,most-positive-fixnum))))) |
82 |
|
|
83 |
|
(defmethod make-random-element-of ((type (eql number))) |
84 |
|
(make-random-element-of (random-from-seq #(integer rational float complex)))) |
85 |
|
|
86 |
(defmethod make-random-element-of ((type (eql character))) |
(defmethod make-random-element-of ((type (eql character))) |
87 |
(rcase |
(rcase |
88 |
(3 (random-from-seq +standard-chars+)) |
(3 (random-from-seq +standard-chars+)) |
93 |
(1 (let ((r (random #.(ash 1 24)))) |
(1 (let ((r (random #.(ash 1 24)))) |
94 |
(or (code-char r) (make-random-element-of 'character)))))) |
(or (code-char r) (make-random-element-of 'character)))))) |
95 |
|
|
96 |
(defmethod make-random-element-of ((type (eql standard-character))) |
(defmethod make-random-element-of ((type 'base-char)) |
97 |
(random-from-seq +standard-chars+)) |
(random-from-seq +standard-chars+)) |
98 |
|
|
99 |
|
(defmethod make-random-element-of ((type 'standard-char)) |
100 |
|
(random-from-seq +standard-chars+)) |
101 |
|
|
102 |
|
(defmethod make-random-element-of ((type (eql bit-vector))) |
103 |
|
(make-random-vector 'bit '*)) |
104 |
|
|
105 |
|
(defmethod make-random-element-of ((type (eql simple-bit-vector))) |
106 |
|
(make-random-vector 'bit '* :simple t)) |
107 |
|
|
108 |
(defmethod make-random-element-of ((type (eql vector))) |
(defmethod make-random-element-of ((type (eql vector))) |
109 |
(make-random-vector '*)) |
(make-random-vector '* '*)) |
110 |
|
|
111 |
(defmethod make-random-element-of ((type (eql simple-vector))) |
(defmethod make-random-element-of ((type (eql simple-vector))) |
112 |
(make-random-vector '* :simple t)) |
(make-random-vector 't '* :simple t)) |
113 |
|
|
114 |
|
(defmethod make-random-elemnt-of ((type (eql array))) |
115 |
|
(make-random-array '* '*)) |
116 |
|
|
117 |
|
(defmethod make-random-elemnt-of ((type (eql simple-array))) |
118 |
|
(make-random-array '* '* :simple t)) |
119 |
|
|
120 |
|
(defmethod make-random-elememt-of ((type (eql string))) |
121 |
|
(make-random-string '*)) |
122 |
|
|
123 |
|
(defmethod make-random-elememt-of ((type (eql simple-string))) |
124 |
|
(make-random-string '* :simple t)) |
125 |
|
|
126 |
|
(defmethod make-random-element-of ((type (eql base-string))) |
127 |
|
(make-random-vector 'base-char '*)) |
128 |
|
|
129 |
|
(defmethod make-random-element-of ((type (eql simple-base-string))) |
130 |
|
(make-random-vector 'base-char '* :simple t)) |
131 |
|
|
132 |
|
(defmethod make-random-element-of ((type (eql cons))) |
133 |
|
(make-random-element-of '(cons t t))) |
134 |
|
|
135 |
|
(defmethod make-random-element-of ((type (eql null))) nil) |
136 |
|
|
137 |
|
(defmethod make-random-elememt-of ((type (eql list))) |
138 |
|
(let ((len (min (random 10) (random 10)))) |
139 |
|
(loop repeat len collect (make-random-element-of-type t)))) |
140 |
|
|
141 |
|
(defmethod make-random-element-of ((type (eql sequence))) |
142 |
|
(make-random-element-of '(or list vector))) |
143 |
|
|
144 |
|
;;;; |
145 |
|
|
146 |
(defun make-random-vector (length &key simple (element-type '*)) |
(defun make-random-vector (length &key simple (element-type '*)) |
147 |
(setq element-type (make-random-array-element-type element-type)) |
(setq element-type (make-random-array-element-type element-type)) |
162 |
(4 t)) |
(4 t)) |
163 |
element-type)) |
element-type)) |
164 |
|
|
165 |
|
;;;; |
166 |
|
|
167 |
|
(defmethod make-random-element-of-compound-type ((type-op (eql or)) (args cons)) |
168 |
|
(make-random-element-of (random-from-seq args))) |
169 |
|
|
170 |
|
(defmethod make-random-element-of-compound-type ((type-op (eql and)) (args cons)) |
171 |
|
(loop for e = (make-random-element-of (car args)) |
172 |
|
repeat 100 |
173 |
|
when (or (null (cdr args)) (typep e (cons 'and (cdr args)))) |
174 |
|
return x |
175 |
|
finally (error "Cannot generate a random element of ~A" |
176 |
|
(cons 'and args)))) |
177 |
|
|
178 |
|
(defmethod make-random-element-of-compound-type ((type-op (eql integer)) (args t)) |
179 |
|
(let ((lo (let ((lo (car args))) |
180 |
|
(cond |
181 |
|
((consp lo) (1+ (car lo))) |
182 |
|
((eq lo nil) '*) |
183 |
|
(t lo)))) |
184 |
|
(hi (let ((hi (cadr args))) |
185 |
|
(cond |
186 |
|
((consp hi) (1- (car hi))) |
187 |
|
((eq hi nil) '*) |
188 |
|
(t hi))))) |
189 |
|
(if (eq lo '*) |
190 |
|
(if (eq hi '*) |
191 |
|
(let ((x (ash 1 (random *maximum-random-int-bits*)))) |
192 |
|
(random-from-interval x (- x))) |
193 |
|
(random-from-interval (1+ hi) |
194 |
|
(- hi (random (ash 1 *maximum-random-int-bits*))))) |
195 |
|
|
196 |
|
(if (eq hi '*) |
197 |
|
(random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1) |
198 |
|
lo) |
199 |
|
;; May generalize the next case to increase odds |
200 |
|
;; of certain integers (near 0, near endpoints, near |
201 |
|
;; powers of 2...) |
202 |
|
(random-from-interval (1+ hi) lo))))) |
203 |
|
|
204 |
|
(defmethod make-random-element-of-compound-type ((type-op (eql short-float)) (args t)) |
205 |
|
(make-random-element-of-float-type type args)) |
206 |
|
|
207 |
|
(defmethod make-random-element-of-compound-type ((type-op (eql single-float)) (args t)) |
208 |
|
(make-random-element-of-float-type type args)) |
209 |
|
|
210 |
|
(defmethod make-random-element-of-compound-type ((type-op (eql double-float)) (args t)) |
211 |
|
(make-random-element-of-float-type type args)) |
212 |
|
|
213 |
|
(defmethod make-random-element-of-compound-type ((type-op (eql long-float)) (args t)) |
214 |
|
(make-random-element-of-float-type type args)) |
215 |
|
|
216 |
|
(defun make-random-element-of-float-type (type-op args) |
217 |
|
(let ((lo (car args)) |
218 |
|
(hi (cadr args)) |
219 |
|
lo= hi=) |
220 |
|
(cond |
221 |
|
((consp lo) nil) |
222 |
|
((member lo '(* nil)) |
223 |
|
(setq lo (most-negative-float type-op)) |
224 |
|
(setq lo= t)) |
225 |
|
(t |
226 |
|
(assert (typep lo type-op)) |
227 |
|
(setq lo= t))) |
228 |
|
(cond |
229 |
|
((consp hi) nil) |
230 |
|
((member hi '(* nil)) |
231 |
|
(setq hi (most-positive-float type-op)) |
232 |
|
(setq hi= t)) |
233 |
|
(t |
234 |
|
(assert (typep hi type-op)) |
235 |
|
(setq hi= t))) |
236 |
|
(assert (<= lo hi)) |
237 |
|
(assert (or (< lo hi) (and lo= hi=))) |
238 |
|
(let ((limit 100000)) |
239 |
|
(cond |
240 |
|
((or (<= hi 0) |
241 |
|
(>= lo 0) |
242 |
|
(and (<= (- limit) hi limit) (<= (- limit) lo limit))) |
243 |
|
(loop for x = (+ (random (- hi lo)) lo) |
244 |
|
do (when (or lo= (/= x lo)) (return x)))) |
245 |
|
(t |
246 |
|
(rcase |
247 |
|
(1 (random (min hi (float limit hi)))) |
248 |
|
(1 (- (random (min (float limit lo) (- lo))))))))))) |
249 |
|
|
250 |
|
(defmethod make-random-element-of-compound-type ((type-op (eql mod)) (args cons)) |
251 |
|
(let ((modulus (car args))) |
252 |
|
(assert (integerp modulus)) |
253 |
|
(assert (plusp modulus)) |
254 |
|
(make-random-element-of `(integer 0 (,modulus))))) |
255 |
|
|
256 |
|
(defmethod make-random-element-of-compound-type ((type-op (eql unsigned-byte)) (args t)) |
257 |
|
(if (null args) |
258 |
|
(make-random-element-of '(integer 0 *)) |
259 |
|
(let ((bits (car args))) |
260 |
|
(if (eq bits'*) |
261 |
|
(make-random-element-of '(integer 0 *)) |
262 |
|
(progn |
263 |
|
(assert (and (integerp bits) (>= bits 1))) |
264 |
|
(make-random-element-of `(integer 0 ,(1- (ash 1 bits))))))))) |
265 |
|
|
266 |
|
(defmethod make-random-element-of-compound-type ((type-op (eql eql)) (args cons)) |
267 |
|
(assert (null (cdr args))) |
268 |
|
(car args)) |
269 |
|
|
270 |
|
(defmethod make-random-element-of-compound-type ((type-op (eql member)) (args cons)) |
271 |
|
(random-from-seq args)) |
272 |
|
|
273 |
|
|
274 |
|
|