diff --git a/cl-rng.asd b/cl-rng.asd index 3764a68..0d832f7 100644 --- a/cl-rng.asd +++ b/cl-rng.asd @@ -7,4 +7,5 @@ :version "0.0.1" :serial t :components ((:file "package") - (:file "cl-rng"))) + (:file "urandom") + (:file "cl-rng"))) diff --git a/cl-rng.lisp b/cl-rng.lisp index 7b063ae..ab766e4 100644 --- a/cl-rng.lisp +++ b/cl-rng.lisp @@ -1,48 +1,28 @@ -;;;; cl-rng.lisp -(in-package #:cl-rng) -(defun urandom (&key (limit 1.0) (precision 1) (transform nil)) - (let ((transform (or transform (lambda (x) x)))) - (with-open-file (rng "/dev/urandom" :element-type 'unsigned-byte) - (assert (> precision 0)) - (if (= precision 1) - (funcall transform (* limit (/ (read-byte rng) 255))) - (let* ((val (apply '+ (loop for i from 0 below precision collect (read-byte rng)))) - (max (* precision 255)) - (frac (/ val max))) - (values (* limit frac) frac)))))) +(in-package :cl-rng) -(defun %urandom-vector (range &rest params) - (loop for x from 0 below (length range) collect - (setf (aref range x) (apply 'urandom params)))) +(defparameter *default-randomness-provider* #'urandom) -(defun %urandom-list (range &rest params) - (setf (car range) (apply 'urandom params)) - (when (not (null (cdr range))) - (cons (car range) (apply '%urandom-list (cons (cdr range) params))))) +(defun chance (fraction &key (provider *default-randomness-provider*)) + (< (funcall provider) fraction)) -(defun urandom-range (range &rest params) - (if (listp range) - (apply '%urandom-list (cons range params)) - (apply '%urandom-vector (cons range params)))) - -(export 'urandom) -(export 'urandom-range) - -;(defparameter *dice-results* (make-list 10)) - - -; (let ((num 0) -; (max 10000) -; (low 50)) -; (format t "~%Searching ~a values for >= ~a...~%" max low) -; (loop for i from 0 below max do -; (let ((value (apply '+ (urandom-range *dice-results* :limit 6 :transform (lambda (x) (1+ (floor x))))))) -; (and (>= value low) -; (incf num) -; (format t " -> ~a: ~a~%" i value)))) -; (format t "Found ~a / ~a (~,8f %)~%" num max (* 100 (/ num max)))) +(export '*default-randomness-provider*) +(export 'chance) +(defun weighted (weights &key (default nil) (provider *default-randomness-provider*)) + (let ((previous 0) + (result (funcall provider)) + (rval default)) + (mapc (lambda (x) + (let ((value (car x)) + (weight (cdr x))) + (and (>= result previous) + (<= result (+ previous weight)) + (setf rval value)) + (incf previous weight))) + weights) + (values rval result))) +(export 'weighted) diff --git a/urandom.lisp b/urandom.lisp new file mode 100644 index 0000000..1c23e0f --- /dev/null +++ b/urandom.lisp @@ -0,0 +1,48 @@ +;;;; cl-rng.lisp + +(in-package #:cl-rng) + +(defun urandom (&key (limit 1.0) (precision 1) (transform nil)) + (let ((transform (or transform #'identity))) + (with-open-file (rng "/dev/urandom" :element-type 'unsigned-byte) + (assert (> precision 0)) + (if (= precision 1) + (funcall transform (* limit (/ (read-byte rng) 255))) + (let* ((val (apply '+ (loop for i from 0 below precision collect (read-byte rng)))) + (max (* precision 255)) + (frac (/ val max))) + (values (* limit frac) frac)))))) + +(defun %urandom-vector (range &rest params) + (loop for x from 0 below (length range) collect + (setf (aref range x) (apply 'urandom params)))) + +(defun %urandom-list (range &rest params) + (setf (car range) (apply 'urandom params)) + (unless (null (cdr range)) + (cons (car range) (apply '%urandom-list (cons (cdr range) params))))) + +(defun urandom-range (range &rest params) + (if (listp range) + (apply '%urandom-list (cons range params)) + (apply '%urandom-vector (cons range params)))) + +(export 'urandom) +(export 'urandom-range) + +;(defparameter *dice-results* (make-list 10)) + + +; (let ((num 0) +; (max 10000) +; (low 50)) +; (format t "~%Searching ~a values for >= ~a...~%" max low) +; (loop for i from 0 below max do +; (let ((value (apply '+ (urandom-range *dice-results* :limit 6 :transform (lambda (x) (1+ (floor x))))))) +; (and (>= value low) +; (incf num) +; (format t " -> ~a: ~a~%" i value)))) +; (format t "Found ~a / ~a (~,8f %)~%" num max (* 100 (/ num max)))) + + +