src/random.lisp

   1 ;; -*- lisp -*-
   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 "Falsafiable 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 gen-float (&key bound (type 'short-float))
 171   "Returns a generator which producs floats of type TYPE. BOUND,
 172 if specified, constrains the ruselts to be in the range (-BOUND,
 173 BOUND)."
 174   (lambda ()
 175     (let* ((most-negative (ecase type
 176                             (short-float most-negative-short-float)
 177                             (single-float most-negative-single-float)
 178                             (double-float most-negative-double-float)
 179                             (long-float most-negative-long-float)))
 180            (most-positive (ecase type
 181                             (short-float most-positive-short-float)
 182                             (single-float most-positive-single-float)
 183                             (double-float most-positive-double-float)
 184                             (long-float most-positive-long-float)))
 185            (bound (or bound (max most-positive (- most-negative)))))
 186       (coerce
 187        (ecase (random 2)
 188          (0 ;; generate a positive number
 189           (random (min most-positive bound)))
 190          (1 ;; generate a negative number
 191           (- (random (min (- most-negative) bound)))))
 192        type))))
 193
 194 (defun gen-character (&key (code-limit char-code-limit)
 195                            (code (gen-integer :min 0 :max (1- code-limit)))
 196                            (alphanumericp nil))
 197   "Returns a generator of characters.
 198
 199 CODE must be a generator of random integers. ALPHANUMERICP, if
 200 non-NIL, limits the returned chars to those which pass
 201 alphanumericp."
 202   (lambda ()
 203     (loop
 204        for count upfrom 0
 205        for char = (code-char (funcall code))
 206        until (and char
 207                   (or (not alphanumericp)
 208                       (alphanumericp char)))
 209        when (= 1000 count)
 210        do (error "After 1000 iterations ~S has still not generated ~:[a valid~;an alphanumeric~] character :(."
 211                  code alphanumericp)
 212        finally (return char))))
 213
 214 (defun gen-string (&key (length (gen-integer :min 0 :max 80))
 215                         (elements (gen-character))
 216                         (element-type 'character))
 217   "Returns a generator which producs random strings. LENGTH must
 218 be a generator which producs integers, ELEMENTS must be a
 219 generator which produces characters of type ELEMENT-TYPE."
 220   (lambda ()
 221     (loop
 222        with length = (funcall length)
 223        with string = (make-string length :element-type element-type)
 224        for index below length
 225        do (setf (aref string index) (funcall elements))
 226        finally (return string))))
 227
 228 (defun gen-list (&key (length (gen-integer :min 0 :max 10))
 229                       (elements (gen-integer :min -10 :max 10)))
 230   "Returns a generator which producs random lists. LENGTH must be
 231 an integer generator and ELEMENTS must be a generator which
 232 producs objects."
 233   (lambda ()
 234     (loop
 235        repeat (funcall length)
 236        collect (funcall elements))))
 237
 238 (defun gen-tree (&key (size 20)
 239                       (elements (gen-integer :min -10 :max 10)))
 240   "Returns a generator which producs random trees. SIZE control
 241 the approximate size of the tree, but don't try anything above
 242  30, you have been warned. ELEMENTS must be a generator which
 243 will produce the elements."
 244   (labels ((rec (&optional (current-depth 0))
 245              (let ((key (random (+ 3 (- size current-depth)))))
 246                (cond ((> key 2)
 247                       (list (rec (+ current-depth 1))
 248                             (rec (+ current-depth 1))))
 249                      (t (funcall elements))))))
 250     (lambda ()
 251       (rec))))
 252
 253 (defun gen-buffer (&key (length (gen-integer :min 0 :max 50))
 254                         (element-type '(unsigned-byte 8))
 255                         (elements (gen-integer :min 0 :max (1- (expt 2 8)))))
 256   (lambda ()
 257     (let ((buffer (make-array (funcall length) :element-type element-type)))
 258       (map-into buffer elements))))
 259
 260 (defun gen-one-element (&rest elements)
 261   (lambda ()
 262     (nth (random (length elements)) elements)))
 263
 264 ;;;; The trivial always-produce-the-same-thing generator is done using
 265 ;;;; cl:constantly.