src/random.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2
   3 (in-package :it.bese.fiveam)
   4
   5 ;;;; ** Random (QuickCheck-ish) testing
   6
   7 ;;;; FiveAM provides the ability to automatically generate a
   8 ;;;; collection of random input data for a specific test and run a
   9 ;;;; test multiple times.
  10
  11 ;;;; Specification testing is done through the FOR-ALL macro. This
  12 ;;;; macro will bind variables to random data and run a test body a
  13 ;;;; certain number of times. Should the test body ever signal a
  14 ;;;; failure we stop running and report what values of the variables
  15 ;;;; caused the code to fail.
  16
  17 ;;;; The generation of the random data is done using "generator
  18 ;;;; functions" (see below for details). A generator function is a
  19 ;;;; function which creates, based on user supplied parameters, a
  20 ;;;; function which returns random data. In order to facilitate
  21 ;;;; generating good random data the FOR-ALL macro also supports guard
  22 ;;;; conditions and creating one random input based on the values of
  23 ;;;; another (see the FOR-ALL macro for details).
  24
  25 ;;;; *** Public Interface to the Random Tester
  26
  27 (defparameter *num-trials* 100
  28   "Number of times we attempt to run the body of the FOR-ALL test.")
  29
  30 (defparameter *max-trials* 10000
  31   "Number of total times we attempt to run the body of the
  32   FOR-ALL test including when the body is skipped due to failed
  33   guard conditions.
  34
  35 Since we have guard conditions we may get into infinite loops
  36 where the test code is never run due to the guards never
  37 returning true. This second run limit prevents that.")
  38
  39 (defmacro for-all (bindings &body body)
  40   "Bind BINDINGS to random variables and test BODY *num-trials* times.
  41
  42 BINDINGS is a list of binding forms, each element is a list
  43 of (BINDING VALUE &optional GUARD). Value, which is evaluated
  44 once when the for-all is evaluated, must return a generator which
  45 be called each time BODY is evaluated. BINDING is either a symbol
  46 or a list which will be passed to destructuring-bind. GUARD is a
  47 form which, if present, stops BODY from executing when IT returns
  48 NIL. The GUARDS are evaluated after all the random data has been
  49 generated and they can refer to the current value of any
  50 binding. NB: Generator forms, unlike guard forms, can not contain
  51 references to the boud variables.
  52
  53 Examples:
  54
  55   (for-all ((a (gen-integer)))
  56     (is (integerp a)))
  57
  58   (for-all ((a (gen-integer) (plusp a)))
  59     (is (integerp a))
  60     (is (plusp a)))
  61
  62   (for-all ((less (gen-integer))
  63             (more (gen-integer) (< less more)))
  64     (is (<= less more)))
  65
  66   (for-all (((a b) (gen-two-integers)))
  67     (is (integerp a))
  68     (is (integerp b)))"
  69   (with-gensyms (test-lambda-args)
  70     `(perform-random-testing
  71       (list ,@(mapcar #'second bindings))
  72       (lambda (,test-lambda-args)
  73         (destructuring-bind ,(mapcar #'first bindings)
  74             ,test-lambda-args
  75           (if (and ,@(delete-if #'null (mapcar #'third bindings)))
  76               (progn ,@body)
  77               (throw 'run-once
  78                 (list :guard-conditions-failed))))))))
  79
  80 ;;;; *** Implementation
  81
  82 ;;;; We could just make FOR-ALL a monster macro, but having FOR-ALL be
  83 ;;;; a preproccessor for the perform-random-testing function is
  84 ;;;; actually much easier.
  85
  86 (defun perform-random-testing (generators body)
  87   (loop
  88      with random-state = *random-state*
  89      with total-counter = *max-trials*
  90      with counter = *num-trials*
  91      with run-at-least-once = nil
  92      until (or (zerop total-counter)
  93                (zerop counter))
  94      do (let ((result (perform-random-testing/run-once generators body)))
  95           (ecase (first result)
  96             (:pass
  97              (decf counter)
  98              (decf total-counter)
  99              (setf run-at-least-once t))
 100             (:no-tests
 101              (add-result 'for-all-test-no-tests
 102                          :reason "No tests"
 103                          :random-state random-state)
 104              (return-from perform-random-testing nil))
 105             (:guard-conditions-failed
 106              (decf total-counter))
 107             (:fail
 108              (add-result 'for-all-test-failed
 109                          :reason "Found failing test data"
 110                          :random-state random-state
 111                          :failure-values (second result)
 112                          :result-list (third result))
 113              (return-from perform-random-testing nil))))
 114      finally (if run-at-least-once
 115                  (add-result 'for-all-test-passed)
 116                  (add-result 'for-all-test-never-run
 117                              :reason "Guard conditions never passed"))))
 118
 119 (defun perform-random-testing/run-once (generators body)
 120   (catch 'run-once
 121     (bind-run-state ((result-list '()))
 122       (let ((values (mapcar #'funcall generators)))
 123         (funcall body values)
 124         (cond
 125           ((null result-list)
 126            (throw 'run-once (list :no-tests)))
 127           ((every #'test-passed-p result-list)
 128            (throw 'run-once (list :pass)))
 129           ((notevery #'test-passed-p result-list)
 130            (throw 'run-once (list :fail values result-list))))))))
 131
 132 (defclass for-all-test-result ()
 133   ((random-state :initarg :random-state)))
 134
 135 (defclass for-all-test-passed (test-passed for-all-test-result)
 136   ())
 137
 138 (defclass for-all-test-failed (test-failure for-all-test-result)
 139   ((failure-values :initarg :failure-values)
 140    (result-list :initarg :result-list)))
 141
 142 (defgeneric for-all-test-failed-p (object)
 143   (:method ((object for-all-test-failed)) t)
 144   (:method ((object t)) nil))
 145
 146 (defmethod reason ((result for-all-test-failed))
 147   (format nil "Falsifiable with ~S" (slot-value result 'failure-values)))
 148
 149 (defclass for-all-test-no-tests (test-failure for-all-test-result)
 150   ())
 151
 152 (defclass for-all-test-never-run (test-failure for-all-test-result)
 153   ())
 154
 155 ;;;; *** Generators
 156
 157 ;;;; Since this is random testing we need some way of creating random
 158 ;;;; data to feed to our code. Generators are regular functions which
 159 ;;;; create this random data.
 160
 161 ;;;; We provide a set of built-in generators.
 162
 163 (defun gen-integer (&key (max (1+ most-positive-fixnum))
 164                          (min (1- most-negative-fixnum)))
 165   "Returns a generator which produces random integers greater
 166 than or equal to MIN and less than or equal to MIN."
 167   (lambda ()
 168     (+ min (random (1+ (- max min))))))
 169
 170 (defun type-most-negative (floating-point-type)
 171   (ecase floating-point-type
 172     (short-float most-negative-short-float)
 173     (single-float most-negative-single-float)
 174     (double-float most-negative-double-float)
 175     (long-float most-negative-long-float)))
 176
 177 (defun type-most-positive (floating-point-type)
 178   (ecase floating-point-type
 179     (short-float most-positive-short-float)
 180     (single-float most-positive-single-float)
 181     (double-float most-positive-double-float)
 182     (long-float most-positive-long-float)) )
 183
 184 (defun gen-float (&key bound (type 'short-float) min max)
 185   "Returns a generator which producs floats of type TYPE.
 186
 187 BOUND, which defaults to the most-positive value of TYPE, constrains
 188 the results to be in the range (-BOUND, BOUND).
 189
 190 MIN and MAX, if supplied, cause the returned float to be within the
 191 floating point interval (MIN, MAX). It is the caller's responsibility
 192 to ensure that the range between MIN and MAX is less than the
 193 requested type's maximum interval. MIN defaults to 0.0 (when only MAX
 194 is supplied), MAX defaults to MOST-POSITIVE-<TYPE> (when only MIN is
 195 supplied). This peculiar calling convention is designed for the common
 196 case of generating positive values below a known limit.
 197
 198 NOTE: Since GEN-FLOAT is built on CL:RANDOM the distribution of
 199 returned values will be continuous, not discrete. In other words: the
 200 values will be evenly distributed across the specified numeric range,
 201 the distribution of possible floating point values, when seen as a
 202 sequence of bits, will not be even."
 203   (lambda ()
 204     (flet ((rand (limit) (random (coerce limit type))))
 205       (when (and bound (or min max))
 206         (error "GET-FLOAT does not support specifying :BOUND and :MAX/:MIN."))
 207       (if (or min max)
 208           (handler-bind ((arithmetic-error (lambda (c)
 209                                              (error "ERROR ~S occured when attempting to generate a random value between ~S and ~S." c min max))))
 210             (setf min (or min 0)
 211                   max (or max (type-most-positive type)))
 212             (+ min (rand (- max min))))
 213           (let ((min (if bound bound (- (type-most-negative type))))
 214                 (max (if bound bound (type-most-positive type))))
 215             (ecase (random 2)
 216               (0 ;; generate a positive number
 217                (rand max))
 218               (1 ;; generate a negative number NB: min is actually
 219                ;; positive. see the if statement above.
 220                (- (rand min)))))))))
 221
 222 (defun gen-character (&key (code-limit char-code-limit)
 223                            (code (gen-integer :min 0 :max (1- code-limit)))
 224                            (alphanumericp nil))
 225   "Returns a generator of characters.
 226
 227 CODE must be a generator of random integers. ALPHANUMERICP, if
 228 non-NIL, limits the returned chars to those which pass
 229 alphanumericp."
 230   (lambda ()
 231     (loop
 232        for count upfrom 0
 233        for char = (code-char (funcall code))
 234        until (and char
 235                   (or (not alphanumericp)
 236                       (alphanumericp char)))
 237        when (= 1000 count)
 238        do (error "After 1000 iterations ~S has still not generated ~:[a valid~;an alphanumeric~] character :(."
 239                  code alphanumericp)
 240        finally (return char))))
 241
 242 (defun gen-string (&key (length (gen-integer :min 0 :max 80))
 243                         (elements (gen-character))
 244                         (element-type 'character))
 245   "Returns a generator which producs random strings. LENGTH must
 246 be a generator which producs integers, ELEMENTS must be a
 247 generator which produces characters of type ELEMENT-TYPE."
 248   (lambda ()
 249     (loop
 250        with length = (funcall length)
 251        with string = (make-string length :element-type element-type)
 252        for index below length
 253        do (setf (aref string index) (funcall elements))
 254        finally (return string))))
 255
 256 (defun gen-list (&key (length (gen-integer :min 0 :max 10))
 257                       (elements (gen-integer :min -10 :max 10)))
 258   "Returns a generator which producs random lists. LENGTH must be
 259 an integer generator and ELEMENTS must be a generator which
 260 producs objects."
 261   (lambda ()
 262     (loop
 263        repeat (funcall length)
 264        collect (funcall elements))))
 265
 266 (defun gen-tree (&key (size 20)
 267                       (elements (gen-integer :min -10 :max 10)))
 268   "Returns a generator which producs random trees. SIZE control
 269 the approximate size of the tree, but don't try anything above
 270  30, you have been warned. ELEMENTS must be a generator which
 271 will produce the elements."
 272   (labels ((rec (&optional (current-depth 0))
 273              (let ((key (random (+ 3 (- size current-depth)))))
 274                (cond ((> key 2)
 275                       (list (rec (+ current-depth 1))
 276                             (rec (+ current-depth 1))))
 277                      (t (funcall elements))))))
 278     (lambda ()
 279       (rec))))
 280
 281 (defun gen-buffer (&key (length (gen-integer :min 0 :max 50))
 282                         (element-type '(unsigned-byte 8))
 283                         (elements (gen-integer :min 0 :max (1- (expt 2 8)))))
 284   (lambda ()
 285     (let ((buffer (make-array (funcall length) :element-type element-type)))
 286       (map-into buffer elements))))
 287
 288 (defun gen-one-element (&rest elements)
 289   (lambda ()
 290     (nth (random (length elements)) elements)))
 291
 292 ;;;; The trivial always-produce-the-same-thing generator is done using
 293 ;;;; cl:constantly.