X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Frandom.lisp;h=3813f439315cdd0b55c22402db170cc267662f94;hb=32647bbefaa857c797ba241ea14ff3bfe2c0ac95;hp=f91ca4671535a10dbfd11c021ee75c5ff061ecf0;hpb=dd25ec9992371a9aa37e2dfdec64d9a149c54e79;p=fiveam.git diff --git a/src/random.lisp b/src/random.lisp index f91ca46..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 @@ -66,7 +66,7 @@ Examples: (for-all (((a b) (gen-two-integers))) (is (integerp a)) (is (integerp b)))" - (with-unique-names (test-lambda-args) + (with-gensyms (test-lambda-args) `(perform-random-testing (list ,@(mapcar #'second bindings)) (lambda (,test-lambda-args) @@ -77,7 +77,7 @@ Examples: (throw 'run-once (list :guard-conditions-failed)))))))) -;;;; *** Implementation +;;;; *** Implementation ;;;; We could just make FOR-ALL a monster macro, but having FOR-ALL be ;;;; a preproccessor for the perform-random-testing function is @@ -144,7 +144,7 @@ Examples: (: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) ()) @@ -167,29 +167,57 @@ than or equal to MIN and less than or equal to MIN." (lambda () (+ min (random (1+ (- max min)))))) -(defun gen-float (&key bound (type 'short-float)) - "Returns a generator which producs floats of type TYPE. BOUND, -if specified, constrains the ruselts to be in the range (-BOUND, -BOUND)." +(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 () - (let* ((most-negative (ecase 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))) - (most-positive (ecase 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))) - (bound (or bound (max most-positive (- most-negative))))) - (coerce - (ecase (random 2) - (0 ;; generate a positive number - (random (min most-positive bound))) - (1 ;; generate a negative number - (- (random (min (- most-negative) bound))))) - type)))) + (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))) @@ -200,16 +228,16 @@ CODE must be a generator of random integers. ALPHANUMERICP, if non-NIL, limits the returned chars to those which pass alphanumericp." (lambda () - (if alphanumericp - (loop - for count upfrom 0 - for char = (code-char (funcall code)) - until (alphanumericp char) - when (= 1000 count) - do (error "After 1000 iterations ~S has still not generated an alphanumeric character :(." - code) - finally (return char)) - (code-char (funcall code))))) + (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)) @@ -235,6 +263,21 @@ producs objects." 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)))))