/[gcl]/gcl/ansi-tests/make-random-element-of.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/make-random-element-of.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by pfdietz, Sat Mar 5 18:18:03 2005 UTC revision 1.2 by pfdietz, Sun Mar 6 20:33:57 2005 UTC
# Line 11  Line 11 
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    
# Line 28  Line 28 
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))
# Line 42  Line 47 
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+))
# Line 52  Line 93 
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))
# Line 80  Line 162 
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    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26