random-aux.lsp 10.7 KB
Newer Older
1 2 3 4 5
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun Jun  8 06:56:15 2003
;;;; Contains: Aux. functions and macros used for randomization

6

7

8 9 10 11 12
(declaim (special +standard-chars+ *cl-symbols-vector*))

(defvar *maximum-random-int-bits*
  (max 36 (1+ (integer-length most-positive-fixnum))))

13 14 15 16 17 18 19 20 21 22 23
(defun random-from-seq (seq)
  "Generate a random member of a sequence."
  (let ((len (length seq)))
    (assert (> len 0))
    (elt seq (random len))))

(defmacro random-case (&body cases)
  (let ((len (length cases)))
    (assert (> len 0))
    `(case (random ,len)
       ,@(loop for i from 0 for e in cases collect `(,i ,e))
24
       (t (error "Can't happen?! (in random-case)~%")))))
25

26 27 28 29 30 31
(defmacro rcase (&body cases)
  "Usage: (RCASE (<weight> <form>+)+), where <weight> is a positive real
   indicating the relative probability of executing the associated implicit
   progn."
  (assert cases)
  (let* ((weights (mapcar #'car cases))
sds's avatar
sds committed
32 33 34 35
         (cumulative-weights (let ((sum 0))
                               (loop for w in weights collect (incf sum w))))
         (total (car (last cumulative-weights)))
         (r (gensym)))
36
    (assert (every #'plusp weights))
37
    (when (typep total 'ratio) (setf total (coerce total 'double-float)))
38 39
    `(let ((,r (random ,total)))
       (cond
sds's avatar
sds committed
40 41 42 43
        ,@(loop for case in (butlast cases)
                for cw in cumulative-weights
                collect `((< ,r ,cw) ,@(cdr case)))
        (t ,@(cdar (last cases)))))))
44

pfdietz's avatar
pfdietz committed
45 46
(defmacro rselect (cumulative-frequency-array &rest cases)
  (let ((len (length cases))
sds's avatar
sds committed
47 48 49 50 51
        (a (gensym "A"))
        (max (gensym "MAX"))
        (r (gensym "R"))
        (p (gensym "P"))
        (done (gensym "DONE")))
pfdietz's avatar
pfdietz committed
52 53 54 55
    (assert (> len 0))
    `(let ((,a ,cumulative-frequency-array))
       (assert (eql ,len (length ,a)))
       (let* ((,max (aref ,a ,(1- len)))
sds's avatar
sds committed
56 57 58 59 60 61 62 63
              (,r (random ,max)))
         (block ,done
          ,@(loop for i from 0
                  for c in cases
                  collect
                  `(let ((,p (aref ,a ,i)))
                     (when (< ,r ,p) (return-from ,done ,c))))
          (error "Should not happen!"))))))
pfdietz's avatar
pfdietz committed
64

65 66 67 68 69 70
(defun make-random-integer-range (&optional var)
  "Generate a list (LO HI) of integers, LO <= HI.  This is used
   for generating integer types."
  (declare (ignore var))
  (rcase
   (1 (flet ((%r () (let ((r (ash 1 (1+ (random *maximum-random-int-bits*)))))
sds's avatar
sds committed
71 72 73 74
                      (- (random r) (floor (/ r 2))))))
        (let ((x (%r))
              (y (%r)))
          (list (min x y) (max x y)))))
75
   (1 (let* ((b (ash 1 (1+ (random *maximum-random-int-bits*))))
sds's avatar
sds committed
76 77 78 79
             (b2 (floor (/ b 2))))
        (let ((x (- (random b) b2))
              (y (- (random b) b2)))
          (list (min x y) (max x y)))))))
80

81 82 83 84 85 86 87 88
(defun random-nonnegative-real ()
  (if (coin 3)
      (random-case
       (/ (random 10000) (1+ (random 1000)))
       (/ (random 1000000) (1+ (random 100000)))
       (/ (random 100000000) (1+ (random 10000000)))
       (/ (random 1000000000000) (1+ (random 10000000))))
    (random (random-case
sds's avatar
sds committed
89 90 91 92 93 94 95 96
             1000
             100000
             10000000
             1000000000
             (expt 2.0s0 (random 15))
             (expt 2.0f0 (random 32))
             (expt 2.0d0 (random 32))
             (expt 2.0l0 (random 32))))))
97

98 99 100 101 102 103 104 105 106
(defun make-random-integer ()
  (let ((r (ash 1 (1+ (random *maximum-random-int-bits*)))))
    (rcase
     (6 (- (random r) (floor (/ r 2))))
     (1 (- r (random (min 10 r))))
     (1 (+ (floor (/ r 2)) (random (min 10 r)))))))

(defun make-random-rational ()
  (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
sds's avatar
sds committed
107
         (n (random r)))
108 109 110 111 112 113
    (assert (>= r 2))
    (let ((d (loop for x = (random r) unless (zerop x) do (return x))))
      (if (coin) (/ n d) (- (/ n d))))))

(defun make-random-nonnegative-rational ()
  (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
sds's avatar
sds committed
114
         (n (random r)))
115 116 117 118 119 120
    (assert (>= r 2))
    (let ((d (loop for x = (random r) unless (zerop x) do (return x))))
      (/ n d))))

(defun make-random-positive-rational ()
  (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
sds's avatar
sds committed
121
         (n (1+ (random r))))
122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140
    (assert (>= r 2))
    (let ((d (loop for x = (random r) unless (zerop x) do (return x))))
      (/ n d))))

(defun make-random-bounded-rational (upper-limit lower-inclusive upper-inclusive)
  (assert (rationalp upper-limit))
  (assert (not (minusp upper-limit)))
  (cond
   ((= upper-limit 0) 0)
   ((<= upper-limit 1/1000000)
    (/ (make-random-bounded-rational (* 1000000 upper-limit) lower-inclusive upper-inclusive)
       1000000))
   ((>= upper-limit 1000000)
    (* (random 1000000)
       (make-random-bounded-rational (/ upper-limit 1000000) lower-inclusive upper-inclusive)))
   (t
    (assert (< 1/1000000 upper-limit 1000000))
    (let ((x 0))
      (loop do (setq x (* upper-limit (rational (random 1.0))))
sds's avatar
sds committed
141 142 143
            while (or (and (not lower-inclusive) (zerop x))
                      (and (not upper-inclusive) (= x upper-limit)))
            finally (return x))))))
144 145 146 147 148 149 150 151 152 153 154 155 156 157

(defun make-random-float ()
  (rcase
   (1 (random most-positive-short-float))
   (1 (random most-positive-single-float))
   (1 (random most-positive-double-float))
   (1 (random most-positive-long-float))))

(defun make-random-symbol ()
  (rcase
   (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)))
   (2 (random-from-seq *cl-symbols-vector*))
   (1 (gensym))))

158 159 160 161 162 163 164 165
(defun random-real ()
  (if (coin) (random-nonnegative-real)
    (- (random-nonnegative-real))))

(defun random-fixnum ()
  (+ (random (1+ (- most-positive-fixnum most-negative-fixnum)))
     most-negative-fixnum))

166 167 168 169 170 171
(defun random-thing (n)
  (if (<= n 1)
      (random-leaf)
    (rcase
     (1 (apply #'cons (mapcar #'random-thing (random-partition (1- n) 2))))
     (1 (apply #'vector (mapcar #'random-thing
sds's avatar
sds committed
172
                                (random-partition (1- n) (max 10 (1- n))))))
173 174
     )))

175 176 177
(defparameter *use-random-byte* t)
(defparameter *random-readable* nil)

178
(defun make-random-string (size-spec &key simple)
179
  (let*
180 181
      ((size (if (eql size-spec '*) (random 30) size-spec))
       (use-random-byte nil)
182
       (etype 'character)
183
       (s (random-case
sds's avatar
sds committed
184 185 186 187 188 189 190 191 192 193 194 195 196 197 198
           (progn
             (setf use-random-byte *use-random-byte*)
             (make-string size :element-type 'character))
           (progn
             (setf use-random-byte *use-random-byte*)
             (make-array size :element-type 'character
                         :initial-element #\a))
           (make-array size :element-type (setf etype (if *random-readable* 'character 'standard-char))
                       :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t)))
                       :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size)))))
                       :initial-element #\a)
           (make-array size :element-type (setf etype (if *random-readable* 'character 'base-char))
                       :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t)))
                       :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size)))))
                       :initial-element #\a))))
199
    (if (coin)
sds's avatar
sds committed
200 201
        (dotimes (i size)
          (setf (char s i) (elt #(#\a #\b #\A #\B) (random 4))))
202
      (dotimes (i size)
sds's avatar
sds committed
203 204 205 206 207 208 209
        (setf (char s i)
              (or (and (eql etype 'character)
                       use-random-byte
                       (or (code-char (random (min char-code-limit (ash 1 16))))
                           (code-char (random 256))))
                  (elt "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
                       (random 62))))))
210
    (when (and (not simple) (not *random-readable*) (coin 5))
211
      (let ((len (+ (random (1+ size)) size)))
sds's avatar
sds committed
212 213 214 215 216 217 218
        (setq s (make-random-string len))
        (setq etype (array-element-type s))
        (setq s (make-array size
                            :element-type etype
                            :displaced-to s
                            :displaced-index-offset (random (1+ (- len size)))))))

219
    s))
220 221 222 223

(defun random-leaf ()
  (rcase
   (1 (let ((k (ash 1 (1+ (random 40)))))
sds's avatar
sds committed
224
        (random-from-interval k (- k))))
225 226 227 228 229 230 231
   (1 (random-from-seq +standard-chars+))
   (1 (random-real))
   (1 (make-random-string (random 20)))
   (1 (gensym))
   (1 (make-symbol (make-random-string (random 20))))
   (1 (random-from-seq *cl-symbols-vector*))))

232 233
(defun random-from-interval (upper &optional (lower (- upper)))
  (+ (random (- upper lower)) lower))
234

235 236 237 238 239 240 241 242 243
(defun coin (&optional (n 2))
  "Flip an n-sided coin."
  (eql (random n) 0))

;;; Randomly permute a sequence
(defun random-permute (seq)
  (setq seq (copy-seq seq))
  (let ((len (length seq)))
    (loop for i from len downto 2
sds's avatar
sds committed
244 245
          do (let ((r (random i)))
               (rotatef (elt seq r) (elt seq (1- i))))))
246 247
  seq)

248 249
(defun binomial-distribution-test (n fn)
  (let* ((count (loop repeat n count (funcall fn)))
sds's avatar
sds committed
250 251 252
         (sigma (/ (sqrt n) 2.0))
         (bound (* sigma 6))
         (expected (/ n 2.0)))
253
    (<= (- expected bound)
sds's avatar
sds committed
254 255
        count
        (+ expected bound))))
256

257 258 259 260 261 262 263
(defun random-partition* (n p)
  "Partition n into p numbers, each >= 0.  Return list of numbers."
  (assert (<= 1 p))
  (cond
   ((= p 1) (list n))
   ((= n 0) (make-list p :initial-element 0))
   (t (let* ((r (random p))
sds's avatar
sds committed
264 265 266 267 268 269 270 271 272 273 274 275
             (n1 (random (1+ n))))
        (cond
         ((= r 0)
          (cons n1 (random-partition* (- n n1) (1- p))))
         ((= r (1- p))
          (append (random-partition* (- n n1) (1- p)) (list n1)))
         (t
          (let* ((n2 (random (1+ (- n n1))))
                 (n3 (- n n1 n2)))
            (append (random-partition* n2 r)
                    (list n1)
                    (random-partition* n3 (- p 1 r))))))))))
276 277 278 279 280 281 282

(defun random-partition (n p)
  "Partition n into p numbers, each >= 1 (if possible.)"
  (cond
   ((<= n p)
    (make-list p :initial-element 1))
   (t (mapcar #'1+ (random-partition* (- n p) p)))))
283

284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299

;;; Random method combination
;;; Methods in this method combination take a single method qualifier,
;;; which is a positive integer.  Each method is invoked
;;; with probability proportional to its qualifier.
;;;
;;; Inside a method, a throw to the symbol FAIL causes
;;; the application to repeat.  This enables methods to abort
;;; and retry the random selection process.

(defun positive-integer-qualifier-p (qualifiers)
  (typep qualifiers '(cons (integer 1) null)))

(define-method-combination randomized nil ((method-list positive-integer-qualifier-p))
  (assert method-list)
  (let ((clauses (mapcar #'(lambda (method)
sds's avatar
sds committed
300 301 302
                             (let ((weight (car (method-qualifiers method))))
                               `(,weight (call-method ,method))))
                         method-list)))
303
  `(loop (catch 'fail (return (rcase ,@clauses))))))
304