X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Frandom.lisp;h=3813f439315cdd0b55c22402db170cc267662f94;hb=c594b36a037a74047be52c9c0e35eefcbbcf14da;hp=f5a1526649338fa513543f6e7a96d77a74c242a4;hpb=150482b3553c2f416ff5608b3330e81e1624f8c0;p=fiveam.git diff --git a/src/random.lisp b/src/random.lisp index f5a1526..3813f43 100644 --- a/src/random.lisp +++ b/src/random.lisp @@ -1,6 +1,6 @@ -;; -*- lisp -*- +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- -(in-package :it.bese.FiveAM) +(in-package :it.bese.fiveam) ;;;; ** Random (QuickCheck-ish) testing @@ -14,6 +14,16 @@ ;;;; failure we stop running and report what values of the variables ;;;; caused the code to fail. +;;;; The generation of the random data is done using "generator +;;;; functions" (see below for details). A generator function is a +;;;; function which creates, based on user supplied parameters, a +;;;; function which returns random data. In order to facilitate +;;;; generating good random data the FOR-ALL macro also supports guard +;;;; conditions and creating one random input based on the values of +;;;; another (see the FOR-ALL macro for details). + +;;;; *** Public Interface to the Random Tester + (defparameter *num-trials* 100 "Number of times we attempt to run the body of the FOR-ALL test.") @@ -27,13 +37,51 @@ where the test code is never run due to the guards never returning true. This second run limit prevents that.") (defmacro for-all (bindings &body body) - `(perform-random-testing - (list ,@(mapcar #'second bindings)) - (lambda ,(mapcar #'first bindings) - (if (and ,@(delete-if #'null (mapcar #'third bindings))) - (progn ,@body) - (throw 'run-once - (list :guard-conditions-failed)))))) + "Bind BINDINGS to random variables and test BODY *num-trials* times. + +BINDINGS is a list of binding forms, each element is a list +of (BINDING VALUE &optional GUARD). Value, which is evaluated +once when the for-all is evaluated, must return a generator which +be called each time BODY is evaluated. BINDING is either a symbol +or a list which will be passed to destructuring-bind. GUARD is a +form which, if present, stops BODY from executing when IT returns +NIL. The GUARDS are evaluated after all the random data has been +generated and they can refer to the current value of any +binding. NB: Generator forms, unlike guard forms, can not contain +references to the boud variables. + +Examples: + + (for-all ((a (gen-integer))) + (is (integerp a))) + + (for-all ((a (gen-integer) (plusp a))) + (is (integerp a)) + (is (plusp a))) + + (for-all ((less (gen-integer)) + (more (gen-integer) (< less more))) + (is (<= less more))) + + (for-all (((a b) (gen-two-integers))) + (is (integerp a)) + (is (integerp b)))" + (with-gensyms (test-lambda-args) + `(perform-random-testing + (list ,@(mapcar #'second bindings)) + (lambda (,test-lambda-args) + (destructuring-bind ,(mapcar #'first bindings) + ,test-lambda-args + (if (and ,@(delete-if #'null (mapcar #'third bindings))) + (progn ,@body) + (throw 'run-once + (list :guard-conditions-failed)))))))) + +;;;; *** Implementation + +;;;; We could just make FOR-ALL a monster macro, but having FOR-ALL be +;;;; a preproccessor for the perform-random-testing function is +;;;; actually much easier. (defun perform-random-testing (generators body) (loop @@ -72,7 +120,7 @@ returning true. This second run limit prevents that.") (catch 'run-once (bind-run-state ((result-list '())) (let ((values (mapcar #'funcall generators))) - (apply body values) + (funcall body values) (cond ((null result-list) (throw 'run-once (list :no-tests))) @@ -96,7 +144,7 @@ returning true. This second run limit prevents that.") (:method ((object t)) nil)) (defmethod reason ((result for-all-test-failed)) - (format nil "Falsafiable with ~S" (slot-value result 'failure-values))) + (format nil "Falsifiable with ~S" (slot-value result 'failure-values))) (defclass for-all-test-no-tests (test-failure for-all-test-result) ()) @@ -112,38 +160,134 @@ returning true. This second run limit prevents that.") ;;;; We provide a set of built-in generators. -(defmacro defgenerator (name arguments &body body) - `(defun ,name ,arguments - (lambda () ,@body))) - -(defgenerator gen-integer (&key (max (1+ most-positive-fixnum)) - (min (1- most-negative-fixnum))) - (+ min (random (1+ (- max min))))) - -(defgenerator gen-character (&key (code (gen-integer :min 0 :max (1- char-code-limit))) - (alphanumericp nil)) - (if alphanumericp - (code-char (funcall code)) - (loop - for char = (code-char (funcall code)) - until (alphanumericp char) - finally (return char)))) - -(defgenerator gen-string (&key (length (gen-integer :min 0 :max 80)) - (elements (gen-character)) - (element-type 'character)) - (loop - with length = (funcall length) - with string = (make-string length :element-type element-type) - for index below length - do (setf (aref string index) (funcall elements)) - finally (return string))) - -(defgenerator gen-list (&key (length (gen-integer :min 0 :max 10)) - (elements (gen-integer :min -10 :max 10))) - (loop - repeat (funcall length) - collect (funcall elements))) +(defun gen-integer (&key (max (1+ most-positive-fixnum)) + (min (1- most-negative-fixnum))) + "Returns a generator which produces random integers greater +than or equal to MIN and less than or equal to MIN." + (lambda () + (+ min (random (1+ (- max min)))))) + +(defun type-most-negative (floating-point-type) + (ecase floating-point-type + (short-float most-negative-short-float) + (single-float most-negative-single-float) + (double-float most-negative-double-float) + (long-float most-negative-long-float))) + +(defun type-most-positive (floating-point-type) + (ecase floating-point-type + (short-float most-positive-short-float) + (single-float most-positive-single-float) + (double-float most-positive-double-float) + (long-float most-positive-long-float)) ) + +(defun gen-float (&key bound (type 'short-float) min max) + "Returns a generator which producs floats of type TYPE. + +BOUND, which defaults to the most-positive value of TYPE, constrains +the results to be in the range (-BOUND, BOUND). + +MIN and MAX, if supplied, cause the returned float to be within the +floating point interval (MIN, MAX). It is the caller's responsibility +to ensure that the range between MIN and MAX is less than the +requested type's maximum interval. MIN defaults to 0.0 (when only MAX +is supplied), MAX defaults to MOST-POSITIVE- (when only MIN is +supplied). This peculiar calling convention is designed for the common +case of generating positive values below a known limit. + +NOTE: Since GEN-FLOAT is built on CL:RANDOM the distribution of +returned values will be continuous, not discrete. In other words: the +values will be evenly distributed across the specified numeric range, +the distribution of possible floating point values, when seen as a +sequence of bits, will not be even." + (lambda () + (flet ((rand (limit) (random (coerce limit type)))) + (when (and bound (or min max)) + (error "GET-FLOAT does not support specifying :BOUND and :MAX/:MIN.")) + (if (or min max) + (handler-bind ((arithmetic-error (lambda (c) + (error "ERROR ~S occured when attempting to generate a random value between ~S and ~S." c min max)))) + (setf min (or min 0) + max (or max (type-most-positive type))) + (+ min (rand (- max min)))) + (let ((min (if bound bound (- (type-most-negative type)))) + (max (if bound bound (type-most-positive type)))) + (ecase (random 2) + (0 ;; generate a positive number + (rand max)) + (1 ;; generate a negative number NB: min is actually + ;; positive. see the if statement above. + (- (rand min))))))))) + +(defun gen-character (&key (code-limit char-code-limit) + (code (gen-integer :min 0 :max (1- code-limit))) + (alphanumericp nil)) + "Returns a generator of characters. + +CODE must be a generator of random integers. ALPHANUMERICP, if +non-NIL, limits the returned chars to those which pass +alphanumericp." + (lambda () + (loop + for count upfrom 0 + for char = (code-char (funcall code)) + until (and char + (or (not alphanumericp) + (alphanumericp char))) + when (= 1000 count) + do (error "After 1000 iterations ~S has still not generated ~:[a valid~;an alphanumeric~] character :(." + code alphanumericp) + finally (return char)))) + +(defun gen-string (&key (length (gen-integer :min 0 :max 80)) + (elements (gen-character)) + (element-type 'character)) + "Returns a generator which producs random strings. LENGTH must +be a generator which producs integers, ELEMENTS must be a +generator which produces characters of type ELEMENT-TYPE." + (lambda () + (loop + with length = (funcall length) + with string = (make-string length :element-type element-type) + for index below length + do (setf (aref string index) (funcall elements)) + finally (return string)))) + +(defun gen-list (&key (length (gen-integer :min 0 :max 10)) + (elements (gen-integer :min -10 :max 10))) + "Returns a generator which producs random lists. LENGTH must be +an integer generator and ELEMENTS must be a generator which +producs objects." + (lambda () + (loop + repeat (funcall length) + collect (funcall elements)))) + +(defun gen-tree (&key (size 20) + (elements (gen-integer :min -10 :max 10))) + "Returns a generator which producs random trees. SIZE control +the approximate size of the tree, but don't try anything above + 30, you have been warned. ELEMENTS must be a generator which +will produce the elements." + (labels ((rec (&optional (current-depth 0)) + (let ((key (random (+ 3 (- size current-depth))))) + (cond ((> key 2) + (list (rec (+ current-depth 1)) + (rec (+ current-depth 1)))) + (t (funcall elements)))))) + (lambda () + (rec)))) + +(defun gen-buffer (&key (length (gen-integer :min 0 :max 50)) + (element-type '(unsigned-byte 8)) + (elements (gen-integer :min 0 :max (1- (expt 2 8))))) + (lambda () + (let ((buffer (make-array (funcall length) :element-type element-type))) + (map-into buffer elements)))) + +(defun gen-one-element (&rest elements) + (lambda () + (nth (random (length elements)) elements))) ;;;; The trivial always-produce-the-same-thing generator is done using ;;;; cl:constantly.