make-random-element-of.lsp 9.65 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Tue Dec 28 20:28:03 2004
;;;; Contains: Code to make random elements of types

(in-package :cl-test)

(defgeneric make-random-element-of (type)
  (:documentation
   "Create a random element of TYPE, or throw an error if it can't figure out how to do it."))

(defgeneric make-random-element-of-compound-type (type args &key &allow-other-keys)
  (:documentation
14
   "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))
17
  (make-random-element-of-compound-type (car type) (cdr type)))
18 19 20 21 22 23 24 25 26 27 28 29 30

(defmethod make-random-element-of ((type (eql bit))) (random 2))

(defmethod make-random-element-of ((type (eql boolean)))
  (random-from-seq #(nil t)))

(defmethod make-random-elememt-of ((type (eql symbol)))
  (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car)))

(defmethod make-random-element-of ((type (eql unsigned-byte)))
  (random-from-interval
   (1+ (ash 1 (random *maximum-random-int-bits*)))))

31 32 33 34 35
(defmethod make-random-elememt-of ((type (eql signed-byte)))
  (random-from-interval
   (1+ (ash 1 (random *maximum-random-int-bits*)))
   (- (ash 1 (random *maximum-random-int-bits*)))))

36 37
(defmethod make-random-element-of ((type (eql rational)))
  (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
sds's avatar
sds committed
38 39
         (n (random r))
         (d (loop for x = (random r) unless (zerop x) do (return x))))
40 41 42 43
    (if (coin) (/ n d) (- (/ n d)))))

(defmethod make-random-element-of ((type (eql integer)))
  (let* ((b (random *maximum-random-int-bits*))
sds's avatar
sds committed
44
         (x (ash 1 b)))
45 46 47 48 49
    (rcase
     (1 (+ x (make-random-element-of 'integer)))
     (1 (- (make-random-element-of 'integer) x))
     (6 (random-from-interval (1+ x) (- x))))))

50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70
(defmethod make-random-element-of ((type (eql short-float)))
  (make-random-element-of (list type)))

(defmethod make-random-element-of ((type (eql single-float)))
  (make-random-element-of (list type)))

(defmethod make-random-element-of ((type (eql double-float)))
  (make-random-element-of (list type)))

(defmethod make-random-element-of ((type (eql long-float)))
  (make-random-element-of (list type)))

(defmethod make-random-element-of ((type (eql float)))
  (make-random-element-of
   (list (random-from-seq #'(short-float single-float double-float long-float)))))

(defmethod make-random-element-of ((type (eql real)))
  (make-random-element-of (random-from-seq #(integer rational float))))

(defmethod make-random-element-of ((type (eql ratio)))
  (loop for x = (make-random-element-of 'rational)
sds's avatar
sds committed
71
        unless (integerp x) return x))
72 73 74 75 76 77 78 79 80

(defmethod make-random-element-of ((type complex))
  (make-random-element-of '(complex real)))

(defmethod make-random-element-of ((type fixnum))
  (make-random-element-of `(integer ,most-negative-fixnum ,most-positive-fixnum)))

(defmethod make-random-element-of ((type bignum))
  (make-random-element-of `(or (integer * (,most-negative-fixnum))
sds's avatar
sds committed
81
                               (integer (,most-positive-fixnum)))))
82 83 84 85

(defmethod make-random-element-of ((type (eql number)))
  (make-random-element-of (random-from-seq #(integer rational float complex))))

86 87 88 89
(defmethod make-random-element-of ((type (eql character)))
  (rcase
   (3 (random-from-seq +standard-chars+))
   (2 (let ((r (random 256)))
sds's avatar
sds committed
90
        (or (code-char r) (make-random-element-of 'character))))
91
   (1 (let ((r (random #.(ash 1 16))))
sds's avatar
sds committed
92
        (or (code-char r) (make-random-element-of 'character))))
93
   (1 (let ((r (random #.(ash 1 24))))
sds's avatar
sds committed
94
        (or (code-char r) (make-random-element-of 'character))))))
95

96 97 98 99
(defmethod make-random-element-of ((type 'base-char))
  (random-from-seq +standard-chars+))

(defmethod make-random-element-of ((type 'standard-char))
100 101
  (random-from-seq +standard-chars+))

102 103 104 105 106 107
(defmethod make-random-element-of ((type (eql bit-vector)))
  (make-random-vector 'bit '*))

(defmethod make-random-element-of ((type (eql simple-bit-vector)))
  (make-random-vector 'bit '* :simple t))

108
(defmethod make-random-element-of ((type (eql vector)))
109
  (make-random-vector '* '*))
110 111

(defmethod make-random-element-of ((type (eql simple-vector)))
112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
  (make-random-vector 't '* :simple t))

(defmethod make-random-elemnt-of ((type (eql array)))
  (make-random-array '* '*))

(defmethod make-random-elemnt-of ((type (eql simple-array)))
  (make-random-array '* '* :simple t))

(defmethod make-random-elememt-of ((type (eql string)))
  (make-random-string '*))

(defmethod make-random-elememt-of ((type (eql simple-string)))
  (make-random-string '* :simple t))

(defmethod make-random-element-of ((type (eql base-string)))
  (make-random-vector 'base-char '*))

(defmethod make-random-element-of ((type (eql simple-base-string)))
  (make-random-vector 'base-char '* :simple t))

(defmethod make-random-element-of ((type (eql cons)))
  (make-random-element-of '(cons t t)))

(defmethod make-random-element-of ((type (eql null))) nil)

(defmethod make-random-elememt-of ((type (eql list)))
  (let ((len (min (random 10) (random 10))))
    (loop repeat len collect (make-random-element-of-type t))))

(defmethod make-random-element-of ((type (eql sequence)))
  (make-random-element-of '(or list vector)))

;;;;
145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164

(defun make-random-vector (length &key simple (element-type '*))
  (setq element-type (make-random-array-element-type element-type))
  (make-random-element-of `(,(if simple 'simple-vector 'vector) ,element-type ,length)))

(defun make-random-array (dimensions &key simple (element-type '*))
  (setq element-type (make-random-array-element-type element-type))
  (make-random-element-of `(,(if simple 'simple-array 'array) ,element-type ,length)))

(defun make-random-array-element-type (elememt-type)
  (if (eq element-type '*)
    (rcase
     (1 'bit)
     (1 `(unsigned-byte (1+ (random *maximum-random-int-bits*))))
     (1 `(signed-byte (1+ (random *maximum-random-int-bits*))))
     (2 (random-from-seq #(character base-char standard-char)))
     ;; Put float, complex types here also
     (4 t))
    element-type))

165 166 167 168 169 170 171
;;;;

(defmethod make-random-element-of-compound-type ((type-op (eql or)) (args cons))
  (make-random-element-of (random-from-seq args)))

(defmethod make-random-element-of-compound-type ((type-op (eql and)) (args cons))
  (loop for e = (make-random-element-of (car args))
sds's avatar
sds committed
172 173 174 175 176
        repeat 100
        when (or (null (cdr args)) (typep e (cons 'and (cdr args))))
        return x
        finally (error "Cannot generate a random element of ~A"
                       (cons 'and args))))
177 178 179

(defmethod make-random-element-of-compound-type ((type-op (eql integer)) (args t))
  (let ((lo (let ((lo (car args)))
sds's avatar
sds committed
180 181 182 183 184 185 186 187 188
              (cond
               ((consp lo) (1+ (car lo)))
               ((eq lo nil) '*)
               (t lo))))
        (hi (let ((hi (cadr args)))
              (cond
               ((consp hi) (1- (car hi)))
               ((eq hi nil) '*)
               (t hi)))))
189
    (if (eq lo '*)
sds's avatar
sds committed
190 191 192 193 194 195
        (if (eq hi '*)
            (let ((x (ash 1 (random *maximum-random-int-bits*))))
              (random-from-interval x (- x)))
          (random-from-interval (1+ hi)
                                (- hi (random (ash 1 *maximum-random-int-bits*)))))

196
      (if (eq hi '*)
sds's avatar
sds committed
197 198 199 200 201 202
          (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1)
                                lo)
        ;; May generalize the next case to increase odds
        ;; of certain integers (near 0, near endpoints, near
        ;; powers of 2...)
        (random-from-interval (1+ hi) lo)))))
203 204 205 206 207 208 209 210 211 212 213 214 215 216 217

(defmethod make-random-element-of-compound-type ((type-op (eql short-float)) (args t))
  (make-random-element-of-float-type type args))

(defmethod make-random-element-of-compound-type ((type-op (eql single-float)) (args t))
  (make-random-element-of-float-type type args))

(defmethod make-random-element-of-compound-type ((type-op (eql double-float)) (args t))
  (make-random-element-of-float-type type args))

(defmethod make-random-element-of-compound-type ((type-op (eql long-float)) (args t))
  (make-random-element-of-float-type type args))

(defun make-random-element-of-float-type (type-op args)
  (let ((lo (car args))
sds's avatar
sds committed
218 219
        (hi (cadr args))
        lo= hi=)
220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240
    (cond
     ((consp lo) nil)
     ((member lo '(* nil))
      (setq lo (most-negative-float type-op))
      (setq lo= t))
     (t
      (assert (typep lo type-op))
      (setq lo= t)))
    (cond
     ((consp hi) nil)
     ((member hi '(* nil))
      (setq hi (most-positive-float type-op))
      (setq hi= t))
     (t
      (assert (typep hi type-op))
      (setq hi= t)))
    (assert (<= lo hi))
    (assert (or (< lo hi) (and lo= hi=)))
    (let ((limit 100000))
      (cond
       ((or (<= hi 0)
sds's avatar
sds committed
241 242 243 244
            (>= lo 0)
            (and (<= (- limit) hi limit) (<= (- limit) lo limit)))
        (loop for x = (+ (random (- hi lo)) lo)
              do (when (or lo= (/= x lo)) (return x))))
245
       (t
sds's avatar
sds committed
246 247 248
        (rcase
         (1 (random (min hi (float limit hi))))
         (1 (- (random (min (float limit lo) (- lo)))))))))))
249 250 251 252 253 254 255 256 257 258 259 260

(defmethod make-random-element-of-compound-type ((type-op (eql mod)) (args cons))
  (let ((modulus (car args)))
    (assert (integerp modulus))
    (assert (plusp modulus))
    (make-random-element-of `(integer 0 (,modulus)))))

(defmethod make-random-element-of-compound-type ((type-op (eql unsigned-byte)) (args t))
  (if (null args)
      (make-random-element-of '(integer 0 *))
    (let ((bits (car args)))
      (if (eq bits'*)
sds's avatar
sds committed
261 262 263 264
          (make-random-element-of '(integer 0 *))
        (progn
          (assert (and (integerp bits) (>= bits 1)))
          (make-random-element-of `(integer 0 ,(1- (ash 1 bits)))))))))
265 266 267 268 269 270 271 272 273 274

(defmethod make-random-element-of-compound-type ((type-op (eql eql)) (args cons))
  (assert (null (cdr args)))
  (car args))

(defmethod make-random-element-of-compound-type ((type-op (eql member)) (args cons))
  (random-from-seq args))