/[gcl]/gcl/ansi-tests/random-aux.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/random-aux.lsp

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

revision 1.11 by pfdietz, Sat Apr 30 21:32:34 2005 UTC revision 1.12 by pfdietz, Fri Jul 1 12:34:36 2005 UTC
# Line 5  Line 5 
5    
6  (in-package :cl-test)  (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)  (defun random-from-seq (seq)
14    "Generate a random member of a sequence."    "Generate a random member of a sequence."
15    (let ((len (length seq)))    (let ((len (length seq)))
# Line 36  Line 41 
41                  collect `((< ,r ,cw) ,@(cdr case)))                  collect `((< ,r ,cw) ,@(cdr case)))
42          (t ,@(cdar (last cases)))))))          (t ,@(cdar (last cases)))))))
43    
44    (defun make-random-integer-range (&optional var)
45      "Generate a list (LO HI) of integers, LO <= HI.  This is used
46       for generating integer types."
47      (declare (ignore var))
48      (rcase
49       (1 (flet ((%r () (let ((r (ash 1 (1+ (random *maximum-random-int-bits*)))))
50                          (- (random r) (floor (/ r 2))))))
51            (let ((x (%r))
52                  (y (%r)))
53              (list (min x y) (max x y)))))
54       (1 (let* ((b (ash 1 (1+ (random *maximum-random-int-bits*))))
55                 (b2 (floor (/ b 2))))
56            (let ((x (- (random b) b2))
57                  (y (- (random b) b2)))
58              (list (min x y) (max x y)))))))
59    
60  (defun random-nonnegative-real ()  (defun random-nonnegative-real ()
61    (if (coin 3)    (if (coin 3)
62        (random-case        (random-case
# Line 53  Line 74 
74               (expt 2.0d0 (random 32))               (expt 2.0d0 (random 32))
75               (expt 2.0l0 (random 32))))))               (expt 2.0l0 (random 32))))))
76    
77    (defun make-random-integer ()
78      (let ((r (ash 1 (1+ (random *maximum-random-int-bits*)))))
79        (rcase
80         (6 (- (random r) (floor (/ r 2))))
81         (1 (- r (random (min 10 r))))
82         (1 (+ (floor (/ r 2)) (random (min 10 r)))))))
83    
84    (defun make-random-rational ()
85      (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
86             (n (random r)))
87        (assert (>= r 2))
88        (let ((d (loop for x = (random r) unless (zerop x) do (return x))))
89          (if (coin) (/ n d) (- (/ n d))))))
90    
91    (defun make-random-nonnegative-rational ()
92      (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
93             (n (random r)))
94        (assert (>= r 2))
95        (let ((d (loop for x = (random r) unless (zerop x) do (return x))))
96          (/ n d))))
97    
98    (defun make-random-positive-rational ()
99      (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
100             (n (1+ (random r))))
101        (assert (>= r 2))
102        (let ((d (loop for x = (random r) unless (zerop x) do (return x))))
103          (/ n d))))
104    
105    (defun make-random-bounded-rational (upper-limit lower-inclusive upper-inclusive)
106      (assert (rationalp upper-limit))
107      (assert (not (minusp upper-limit)))
108      (cond
109       ((= upper-limit 0) 0)
110       ((<= upper-limit 1/1000000)
111        (/ (make-random-bounded-rational (* 1000000 upper-limit) lower-inclusive upper-inclusive)
112           1000000))
113       ((>= upper-limit 1000000)
114        (* (random 1000000)
115           (make-random-bounded-rational (/ upper-limit 1000000) lower-inclusive upper-inclusive)))
116       (t
117        (assert (< 1/1000000 upper-limit 1000000))
118        (let ((x 0))
119          (loop do (setq x (* upper-limit (rational (random 1.0))))
120                while (or (and (not lower-inclusive) (zerop x))
121                          (and (not upper-inclusive) (= x upper-limit)))
122                finally (return x))))))  
123    
124    (defun make-random-float ()
125      (rcase
126       (1 (random most-positive-short-float))
127       (1 (random most-positive-single-float))
128       (1 (random most-positive-double-float))
129       (1 (random most-positive-long-float))))
130    
131    (defun make-random-symbol ()
132      (rcase
133       (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)))
134       (2 (random-from-seq *cl-symbols-vector*))
135       (1 (gensym))))
136    
137  (defun random-real ()  (defun random-real ()
138    (if (coin) (random-nonnegative-real)    (if (coin) (random-nonnegative-real)
139      (- (random-nonnegative-real))))      (- (random-nonnegative-real))))
# Line 70  Line 151 
151                                  (random-partition (1- n) (max 10 (1- n))))))                                  (random-partition (1- n) (max 10 (1- n))))))
152       )))       )))
153    
 (declaim (special +standard-chars+ *cl-symbols-vector*))  
   
154  (defparameter *use-random-byte* t)  (defparameter *use-random-byte* t)
155  (defparameter *random-readable* nil)  (defparameter *random-readable* nil)
156    

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.12

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