source: trunk/source/tests/ansi-tests/make-random-element-of.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 9.3 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Tue Dec 28 20:28:03 2004
4;;;; Contains: Code to make random elements of types
5
6(in-package :cl-test)
7
8(defgeneric make-random-element-of (type)
9  (:documentation
10   "Create a random element of TYPE, or throw an error if it can't figure out how to do it."))
11
12(defgeneric make-random-element-of-compound-type (type args &key &allow-other-keys)
13  (:documentation
14   "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))
17  (make-random-element-of-compound-type (car type) (cdr type)))
18
19(defmethod make-random-element-of ((type (eql bit))) (random 2))
20
21(defmethod make-random-element-of ((type (eql boolean)))
22  (random-from-seq #(nil t)))
23
24(defmethod make-random-elememt-of ((type (eql symbol)))
25  (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car)))
26
27(defmethod make-random-element-of ((type (eql unsigned-byte)))
28  (random-from-interval
29   (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)))
37  (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
38         (n (random r))
39         (d (loop for x = (random r) unless (zerop x) do (return x))))
40    (if (coin) (/ n d) (- (/ n d)))))
41
42(defmethod make-random-element-of ((type (eql integer)))
43  (let* ((b (random *maximum-random-int-bits*))
44         (x (ash 1 b)))
45    (rcase
46     (1 (+ x (make-random-element-of 'integer)))
47     (1 (- (make-random-element-of 'integer) x))
48     (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)))
87  (rcase
88   (3 (random-from-seq +standard-chars+))
89   (2 (let ((r (random 256)))
90        (or (code-char r) (make-random-element-of 'character))))
91   (1 (let ((r (random #.(ash 1 16))))
92        (or (code-char r) (make-random-element-of 'character))))
93   (1 (let ((r (random #.(ash 1 24))))
94        (or (code-char r) (make-random-element-of 'character))))))
95
96(defmethod make-random-element-of ((type 'base-char))
97  (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)))
109  (make-random-vector '* '*))
110
111(defmethod make-random-element-of ((type (eql simple-vector)))
112  (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 '*))
147  (setq element-type (make-random-array-element-type element-type))
148  (make-random-element-of `(,(if simple 'simple-vector 'vector) ,element-type ,length)))
149
150(defun make-random-array (dimensions &key simple (element-type '*))
151  (setq element-type (make-random-array-element-type element-type))
152  (make-random-element-of `(,(if simple 'simple-array 'array) ,element-type ,length)))
153
154(defun make-random-array-element-type (elememt-type)
155  (if (eq element-type '*)
156    (rcase
157     (1 'bit)
158     (1 `(unsigned-byte (1+ (random *maximum-random-int-bits*))))
159     (1 `(signed-byte (1+ (random *maximum-random-int-bits*))))
160     (2 (random-from-seq #(character base-char standard-char)))
161     ;; Put float, complex types here also
162     (4 t))
163    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
Note: See TracBrowser for help on using the repository browser.