source: trunk/source/tests/ansi-tests/random-aux.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.7 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun Jun  8 06:56:15 2003
4;;;; Contains: Aux. functions and macros used for randomization
5
6(in-package :cl-test)
7
8(declaim (special +standard-chars+ *cl-symbols-vector*))
9
10(defvar *maximum-random-int-bits*
11  (max 36 (1+ (integer-length most-positive-fixnum))))
12
13(defun random-from-seq (seq)
14  "Generate a random member of a sequence."
15  (let ((len (length seq)))
16    (assert (> len 0))
17    (elt seq (random len))))
18
19(defmacro random-case (&body cases)
20  (let ((len (length cases)))
21    (assert (> len 0))
22    `(case (random ,len)
23       ,@(loop for i from 0 for e in cases collect `(,i ,e))
24       (t (error "Can't happen?! (in random-case)~%")))))
25
26(defmacro rcase (&body cases)
27  "Usage: (RCASE (<weight> <form>+)+), where <weight> is a positive real
28   indicating the relative probability of executing the associated implicit
29   progn."
30  (assert cases)
31  (let* ((weights (mapcar #'car cases))
32         (cumulative-weights (let ((sum 0))
33                               (loop for w in weights collect (incf sum w))))
34         (total (car (last cumulative-weights)))
35         (r (gensym)))
36    (assert (every #'plusp weights))
37    (when (typep total 'ratio) (setf total (coerce total 'double-float)))
38    `(let ((,r (random ,total)))
39       (cond
40        ,@(loop for case in (butlast cases)
41                for cw in cumulative-weights
42                collect `((< ,r ,cw) ,@(cdr case)))
43        (t ,@(cdar (last cases)))))))
44
45(defmacro rselect (cumulative-frequency-array &rest cases)
46  (let ((len (length cases))
47        (a (gensym "A"))
48        (max (gensym "MAX"))
49        (r (gensym "R"))
50        (p (gensym "P"))
51        (done (gensym "DONE")))
52    (assert (> len 0))
53    `(let ((,a ,cumulative-frequency-array))
54       (assert (eql ,len (length ,a)))
55       (let* ((,max (aref ,a ,(1- len)))
56              (,r (random ,max)))
57         (block ,done
58          ,@(loop for i from 0
59                  for c in cases
60                  collect
61                  `(let ((,p (aref ,a ,i)))
62                     (when (< ,r ,p) (return-from ,done ,c))))
63          (error "Should not happen!"))))))
64
65(defun make-random-integer-range (&optional var)
66  "Generate a list (LO HI) of integers, LO <= HI.  This is used
67   for generating integer types."
68  (declare (ignore var))
69  (rcase
70   (1 (flet ((%r () (let ((r (ash 1 (1+ (random *maximum-random-int-bits*)))))
71                      (- (random r) (floor (/ r 2))))))
72        (let ((x (%r))
73              (y (%r)))
74          (list (min x y) (max x y)))))
75   (1 (let* ((b (ash 1 (1+ (random *maximum-random-int-bits*))))
76             (b2 (floor (/ b 2))))
77        (let ((x (- (random b) b2))
78              (y (- (random b) b2)))
79          (list (min x y) (max x y)))))))
80
81(defun random-nonnegative-real ()
82  (if (coin 3)
83      (random-case
84       (/ (random 10000) (1+ (random 1000)))
85       (/ (random 1000000) (1+ (random 100000)))
86       (/ (random 100000000) (1+ (random 10000000)))
87       (/ (random 1000000000000) (1+ (random 10000000))))
88    (random (random-case
89             1000
90             100000
91             10000000
92             1000000000
93             (expt 2.0s0 (random 15))
94             (expt 2.0f0 (random 32))
95             (expt 2.0d0 (random 32))
96             (expt 2.0l0 (random 32))))))
97
98(defun make-random-integer ()
99  (let ((r (ash 1 (1+ (random *maximum-random-int-bits*)))))
100    (rcase
101     (6 (- (random r) (floor (/ r 2))))
102     (1 (- r (random (min 10 r))))
103     (1 (+ (floor (/ r 2)) (random (min 10 r)))))))
104
105(defun make-random-rational ()
106  (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
107         (n (random r)))
108    (assert (>= r 2))
109    (let ((d (loop for x = (random r) unless (zerop x) do (return x))))
110      (if (coin) (/ n d) (- (/ n d))))))
111
112(defun make-random-nonnegative-rational ()
113  (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
114         (n (random r)))
115    (assert (>= r 2))
116    (let ((d (loop for x = (random r) unless (zerop x) do (return x))))
117      (/ n d))))
118
119(defun make-random-positive-rational ()
120  (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
121         (n (1+ (random r))))
122    (assert (>= r 2))
123    (let ((d (loop for x = (random r) unless (zerop x) do (return x))))
124      (/ n d))))
125
126(defun make-random-bounded-rational (upper-limit lower-inclusive upper-inclusive)
127  (assert (rationalp upper-limit))
128  (assert (not (minusp upper-limit)))
129  (cond
130   ((= upper-limit 0) 0)
131   ((<= upper-limit 1/1000000)
132    (/ (make-random-bounded-rational (* 1000000 upper-limit) lower-inclusive upper-inclusive)
133       1000000))
134   ((>= upper-limit 1000000)
135    (* (random 1000000)
136       (make-random-bounded-rational (/ upper-limit 1000000) lower-inclusive upper-inclusive)))
137   (t
138    (assert (< 1/1000000 upper-limit 1000000))
139    (let ((x 0))
140      (loop do (setq x (* upper-limit (rational (random 1.0))))
141            while (or (and (not lower-inclusive) (zerop x))
142                      (and (not upper-inclusive) (= x upper-limit)))
143            finally (return x))))))   
144
145(defun make-random-float ()
146  (rcase
147   (1 (random most-positive-short-float))
148   (1 (random most-positive-single-float))
149   (1 (random most-positive-double-float))
150   (1 (random most-positive-long-float))))
151
152(defun make-random-symbol ()
153  (rcase
154   (3 (random-from-seq #(a b c d e f g h i j k l m n o p q r s t u v w x y z)))
155   (2 (random-from-seq *cl-symbols-vector*))
156   (1 (gensym))))
157
158(defun random-real ()
159  (if (coin) (random-nonnegative-real)
160    (- (random-nonnegative-real))))
161
162(defun random-fixnum ()
163  (+ (random (1+ (- most-positive-fixnum most-negative-fixnum)))
164     most-negative-fixnum))
165
166(defun random-thing (n)
167  (if (<= n 1)
168      (random-leaf)
169    (rcase
170     (1 (apply #'cons (mapcar #'random-thing (random-partition (1- n) 2))))
171     (1 (apply #'vector (mapcar #'random-thing
172                                (random-partition (1- n) (max 10 (1- n))))))
173     )))
174
175(defparameter *use-random-byte* t)
176(defparameter *random-readable* nil)
177
178(defun make-random-string (size-spec &key simple)
179  (let*
180      ((size (if (eql size-spec '*) (random 30) size-spec))
181       (use-random-byte nil)
182       (etype 'character)
183       (s (random-case
184           (progn
185             (setf use-random-byte *use-random-byte*)
186             (make-string size :element-type 'character))
187           (progn
188             (setf use-random-byte *use-random-byte*)
189             (make-array size :element-type 'character
190                         :initial-element #\a))
191           (make-array size :element-type (setf etype (if *random-readable* 'character 'standard-char))
192                       :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t)))
193                       :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size)))))
194                       :initial-element #\a)
195           (make-array size :element-type (setf etype (if *random-readable* 'character 'base-char))
196                       :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t)))
197                       :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size)))))
198                       :initial-element #\a))))
199    (if (coin)
200        (dotimes (i size)
201          (setf (char s i) (elt #(#\a #\b #\A #\B) (random 4))))
202      (dotimes (i size)
203        (setf (char s i)
204              (or (and (eql etype 'character)
205                       use-random-byte
206                       (or (code-char (random (min char-code-limit (ash 1 16))))
207                           (code-char (random 256))))
208                  (elt "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
209                       (random 62))))))
210    (when (and (not simple) (not *random-readable*) (coin 5))
211      (let ((len (+ (random (1+ size)) size)))
212        (setq s (make-random-string len))
213        (setq etype (array-element-type s))
214        (setq s (make-array size
215                            :element-type etype
216                            :displaced-to s
217                            :displaced-index-offset (random (1+ (- len size)))))))
218     
219    s))
220
221(defun random-leaf ()
222  (rcase
223   (1 (let ((k (ash 1 (1+ (random 40)))))
224        (random-from-interval k (- k))))
225   (1 (random-from-seq +standard-chars+))
226   (1 (random-real))
227   (1 (make-random-string (random 20)))
228   (1 (gensym))
229   (1 (make-symbol (make-random-string (random 20))))
230   (1 (random-from-seq *cl-symbols-vector*))))
231
232(defun random-from-interval (upper &optional (lower (- upper)))
233  (+ (random (- upper lower)) lower))
234
235(defun coin (&optional (n 2))
236  "Flip an n-sided coin."
237  (eql (random n) 0))
238
239;;; Randomly permute a sequence
240(defun random-permute (seq)
241  (setq seq (copy-seq seq))
242  (let ((len (length seq)))
243    (loop for i from len downto 2
244          do (let ((r (random i)))
245               (rotatef (elt seq r) (elt seq (1- i))))))
246  seq)
247
248(defun binomial-distribution-test (n fn)
249  (let* ((count (loop repeat n count (funcall fn)))
250         (sigma (/ (sqrt n) 2.0))
251         (bound (* sigma 6))
252         (expected (/ n 2.0)))
253    (<= (- expected bound)
254        count
255        (+ expected bound))))
256
257(defun random-partition* (n p)
258  "Partition n into p numbers, each >= 0.  Return list of numbers."
259  (assert (<= 1 p))
260  (cond
261   ((= p 1) (list n))
262   ((= n 0) (make-list p :initial-element 0))
263   (t (let* ((r (random p))
264             (n1 (random (1+ n))))
265        (cond
266         ((= r 0)
267          (cons n1 (random-partition* (- n n1) (1- p))))
268         ((= r (1- p))
269          (append (random-partition* (- n n1) (1- p)) (list n1)))
270         (t
271          (let* ((n2 (random (1+ (- n n1))))
272                 (n3 (- n n1 n2)))
273            (append (random-partition* n2 r)
274                    (list n1)
275                    (random-partition* n3 (- p 1 r))))))))))
276
277(defun random-partition (n p)
278  "Partition n into p numbers, each >= 1 (if possible.)"
279  (cond
280   ((<= n p)
281    (make-list p :initial-element 1))
282   (t (mapcar #'1+ (random-partition* (- n p) p)))))
283
284
285;;; Random method combination
286;;; Methods in this method combination take a single method qualifier,
287;;; which is a positive integer.  Each method is invoked
288;;; with probability proportional to its qualifier.
289;;;
290;;; Inside a method, a throw to the symbol FAIL causes
291;;; the application to repeat.  This enables methods to abort
292;;; and retry the random selection process.
293
294(defun positive-integer-qualifier-p (qualifiers)
295  (typep qualifiers '(cons (integer 1) null)))
296
297(define-method-combination randomized nil ((method-list positive-integer-qualifier-p))
298  (assert method-list)
299  (let ((clauses (mapcar #'(lambda (method)
300                             (let ((weight (car (method-qualifiers method))))
301                               `(,weight (call-method ,method))))
302                         method-list)))
303  `(loop (catch 'fail (return (rcase ,@clauses))))))
Note: See TracBrowser for help on using the repository browser.