random-aux.lsp 10.7 KB
 pfdietz committed Jun 10, 2003 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 `````` Daniel Kochmański committed Sep 01, 2015 6 `````` `````` pfdietz committed Jun 10, 2003 7 `````` `````` pfdietz committed Jul 01, 2005 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)))) `````` pfdietz committed Jun 10, 2003 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)) `````` pfdietz committed Aug 09, 2003 24 `````` (t (error "Can't happen?! (in random-case)~%"))))) `````` pfdietz committed Jun 10, 2003 25 `````` `````` pfdietz committed Sep 14, 2003 26 27 28 29 30 31 ``````(defmacro rcase (&body cases) "Usage: (RCASE (
+)+), where is a positive real indicating the relative probability of executing the associated implicit progn." (assert cases) (let* ((weights (mapcar #'car cases)) `````` sds committed Aug 12, 2009 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))) `````` pfdietz committed Sep 14, 2003 36 `````` (assert (every #'plusp weights)) `````` 37 `````` (when (typep total 'ratio) (setf total (coerce total 'double-float))) `````` pfdietz committed Sep 14, 2003 38 39 `````` `(let ((,r (random ,total))) (cond `````` sds committed Aug 12, 2009 40 41 42 43 `````` ,@(loop for case in (butlast cases) for cw in cumulative-weights collect `((< ,r ,cw) ,@(cdr case))) (t ,@(cdar (last cases))))))) `````` pfdietz committed Sep 14, 2003 44 `````` `````` pfdietz committed Jan 30, 2006 45 46 ``````(defmacro rselect (cumulative-frequency-array &rest cases) (let ((len (length cases)) `````` sds committed Aug 12, 2009 47 48 49 50 51 `````` (a (gensym "A")) (max (gensym "MAX")) (r (gensym "R")) (p (gensym "P")) (done (gensym "DONE"))) `````` pfdietz committed Jan 30, 2006 52 53 54 55 `````` (assert (> len 0)) `(let ((,a ,cumulative-frequency-array)) (assert (eql ,len (length ,a))) (let* ((,max (aref ,a ,(1- len))) `````` sds committed Aug 12, 2009 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 committed Jan 30, 2006 64 `````` `````` pfdietz committed Jul 01, 2005 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 committed Aug 12, 2009 71 72 73 74 `````` (- (random r) (floor (/ r 2)))))) (let ((x (%r)) (y (%r))) (list (min x y) (max x y))))) `````` pfdietz committed Jul 01, 2005 75 `````` (1 (let* ((b (ash 1 (1+ (random *maximum-random-int-bits*)))) `````` sds committed Aug 12, 2009 76 77 78 79 `````` (b2 (floor (/ b 2)))) (let ((x (- (random b) b2)) (y (- (random b) b2))) (list (min x y) (max x y))))))) `````` pfdietz committed Jul 01, 2005 80 `````` `````` pfdietz committed Sep 12, 2003 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 committed Aug 12, 2009 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)))))) `````` pfdietz committed Sep 12, 2003 97 `````` `````` pfdietz committed Jul 01, 2005 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 committed Aug 12, 2009 107 `````` (n (random r))) `````` pfdietz committed Jul 01, 2005 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 committed Aug 12, 2009 114 `````` (n (random r))) `````` pfdietz committed Jul 01, 2005 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 committed Aug 12, 2009 121 `````` (n (1+ (random r)))) `````` pfdietz committed Jul 01, 2005 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 committed Aug 12, 2009 141 142 143 `````` while (or (and (not lower-inclusive) (zerop x)) (and (not upper-inclusive) (= x upper-limit))) finally (return x)))))) `````` pfdietz committed Jul 01, 2005 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)))) `````` pfdietz committed Sep 12, 2003 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)) `````` pfdietz committed Aug 07, 2004 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 committed Aug 12, 2009 172 `````` (random-partition (1- n) (max 10 (1- n)))))) `````` pfdietz committed Aug 07, 2004 173 174 `````` ))) `````` pfdietz committed Aug 26, 2004 175 176 177 ``````(defparameter *use-random-byte* t) (defparameter *random-readable* nil) `````` pfdietz committed Feb 27, 2005 178 ``````(defun make-random-string (size-spec &key simple) `````` pfdietz committed Aug 26, 2004 179 `````` (let* `````` pfdietz committed Feb 27, 2005 180 181 `````` ((size (if (eql size-spec '*) (random 30) size-spec)) (use-random-byte nil) `````` pfdietz committed Sep 02, 2004 182 `````` (etype 'character) `````` pfdietz committed Aug 26, 2004 183 `````` (s (random-case `````` sds committed Aug 12, 2009 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)))) `````` pfdietz committed Aug 26, 2004 199 `````` (if (coin) `````` sds committed Aug 12, 2009 200 201 `````` (dotimes (i size) (setf (char s i) (elt #(#\a #\b #\A #\B) (random 4)))) `````` pfdietz committed Feb 27, 2005 202 `````` (dotimes (i size) `````` sds committed Aug 12, 2009 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)))))) `````` pfdietz committed Feb 27, 2005 210 `````` (when (and (not simple) (not *random-readable*) (coin 5)) `````` pfdietz committed Feb 26, 2006 211 `````` (let ((len (+ (random (1+ size)) size))) `````` sds committed Aug 12, 2009 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))))))) `````` pfdietz committed Aug 26, 2004 219 `````` s)) `````` pfdietz committed Aug 07, 2004 220 221 222 223 `````` (defun random-leaf () (rcase (1 (let ((k (ash 1 (1+ (random 40))))) `````` sds committed Aug 12, 2009 224 `````` (random-from-interval k (- k)))) `````` pfdietz committed Aug 07, 2004 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*)))) `````` pfdietz committed Sep 12, 2003 232 233 ``````(defun random-from-interval (upper &optional (lower (- upper))) (+ (random (- upper lower)) lower)) `````` pfdietz committed Sep 11, 2003 234 `````` `````` pfdietz committed Jun 10, 2003 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 committed Aug 12, 2009 244 245 `````` do (let ((r (random i))) (rotatef (elt seq r) (elt seq (1- i)))))) `````` pfdietz committed Jun 10, 2003 246 247 `````` seq) `````` pfdietz committed Sep 06, 2003 248 249 ``````(defun binomial-distribution-test (n fn) (let* ((count (loop repeat n count (funcall fn))) `````` sds committed Aug 12, 2009 250 251 252 `````` (sigma (/ (sqrt n) 2.0)) (bound (* sigma 6)) (expected (/ n 2.0))) `````` pfdietz committed Sep 06, 2003 253 `````` (<= (- expected bound) `````` sds committed Aug 12, 2009 254 255 `````` count (+ expected bound)))) `````` pfdietz committed Sep 06, 2003 256 `````` `````` pfdietz committed Apr 30, 2005 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 committed Aug 12, 2009 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)))))))))) `````` pfdietz committed Apr 30, 2005 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))))) `````` pfdietz committed Sep 06, 2003 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 committed Aug 12, 2009 300 301 302 `````` (let ((weight (car (method-qualifiers method)))) `(,weight (call-method ,method)))) method-list))) `````` 303 `````` `(loop (catch 'fail (return (rcase ,@clauses)))))) `````` ehuelsmann committed Oct 05, 2008 304