cl-game-random: Provides randomness utilities useful in many games.

cl-game-random.lisp

(defpackage #:cl-game-random
  (:use #:cl)
  (:export #:random-whole #:random-range
           #:random-digit #:random-alpha
	   #:random-array-subscripts
           #:random-char #:random-svref
	   #:random-nth #:random-elt
	   #:random-aref
           #:sample
	   #:bias
	   #:nshuffle #:shuffle)
  (:documentation "cl-game-random

Provides randomness utilities useful in many games."))

(in-package #:cl-game-random)

;;; Random

(defun random-whole (bound)
  "Return random whole number between 1 and `bound'."
  (1+ (random bound)))

(defun random-range (bound1 bound2)
  "Return random number between bounds, inclusive."
  (let ((above (min bound1 bound2))
        (below (1+ (max bound1 bound2))))
    (+ above
       (random (- below above)))))

(defun random-digit (&optional (base 10))
  "Return random digit character in given `base', default 10."
  (digit-char (random base)
	      base))

(defun random-alpha ()
  "Return random capital letter character from A-Z."
  (digit-char (+ 10 (random 26)) ; NOFIX: do NOT depend on `random-range'
	      36))

(defun random-array-subscripts (array)
  "Create a list random subscripts in array."
  (mapcar #'random
	  (array-dimensions array)))


;;; Random elements

(defun random-char (string)
  "Return random element of a string."
  (let ((length-string (length string)))
    (when (< 0 length-string)
      (char string
            (random length-string)))))

(defun random-svref (simple-vector)
  "Return random element of a simple-vector."
  (let ((length-simple-vector (length simple-vector)))
    (when (< 0 length-simple-vector)
      (svref simple-vector
             (random length-simple-vector)))))

(defun random-nth (list)
  "Return random item of a list."
  (let ((length-list (length list)))
    (when (< 0 length-list)
      (nth (random length-list)
	   list))))

;; More generic, less efficient
(defun random-elt (sequence)
  "Return random element of any sequence."
  (let ((length-sequence (length sequence)))
    (when (< 0 length-sequence)
      (elt sequence
	   (random length-sequence)))))

(defun random-aref (array)
  "Return random element of an array."
  (row-major-aref array
		  (random (array-total-size array))))


;;; Sample

(defgeneric sample (collection &key with)
  (:documentation "Return a procedurally chosen element of collection.")

  (:method ((col string) &key (with #'random-char))
    (funcall with col))

  (:method ((col vector) &key (with #'random-svref))
    (funcall with col))

  (:method ((col list) &key (with #'random-nth))
    (funcall with col))

  (:method ((col array) &key (with #'random-array))
    (funcall with col)))


;;; Bias

(defun bias (weight0 weight1 &rest weights-rest)
  "Return a function that returns a weighted random sample of sequence."
  (let ((weights (list* weight0 weight1 weights-rest)))
    (assert (= 1 (reduce #'+ weights))
	    (weights)
	    "Weights ~S should sum to 1" weights)
    (let* ((weights-count (length weights))
           (weighted-norm (reduce #'lcm weights :key #'denominator))
           (weighted-odds (maplist (lambda (weights)
				     (* weighted-norm (reduce #'+ weights)))
                                   weights))
           (weighted-last (first (last weighted-odds))))
      (lambda (sequence)
        (assert (= weights-count (length sequence))
                (weights-count)
                "Sequence ~S must have length ~D" sequence weights-count)
        (let* ((pick (+ weighted-last (random weighted-norm)))
               (index (mod (1- (position-if (lambda (odds) (<= odds pick))
                                            weighted-odds))
                           weights-count)))
          (elt sequence index))))))


;;; Shuffle

(defun nshuffle (sequence)
  "Destructively Knuth shuffle a sequence."
  (let ((size (length sequence)))
    (dotimes (i size sequence)
      (rotatef (elt sequence i)
	       (elt sequence (+ i (random (- size i))))))))

(defun shuffle (sequence)
  "Non-destructively Knuth shuffle a sequence."
  (nshuffle (copy-seq sequence)))


;;; Tests

(let* ((rstate (make-random-state t))
       (*random-state* (make-random-state rstate))
       (expect (random 6)))

  (let* ((*random-state* (make-random-state rstate))
         (subject (random-whole 6)))
    (assert (= expect
               (1- subject))))

  (let* ((*random-state* (make-random-state rstate))
         (subject (random-range 3 8)))
    (assert (= expect
               (+ -3 subject))))

  (let* ((*random-state* (make-random-state rstate))
         (indyvar 6)
         (subject (random-digit indyvar)))
    (assert (= expect (digit-char-p subject indyvar)))))

(let* ((rstate (make-random-state t))
       (*random-state* (make-random-state rstate))
       (expect (random 26)))

  (let* ((*random-state* (make-random-state rstate))
         (subject (random-alpha)))
    (assert (= expect
               (+ -10 (digit-char-p subject 36))))))

(let* ((rstate (make-random-state t))
       (*random-state* (make-random-state rstate))
       (expect (random 4)))

  (let* ((*random-state* (make-random-state rstate))
         (indyvar "abcd")
         (subject (random-char indyvar)))
    (assert (= expect
               (position subject indyvar))))  

  (let* ((*random-state* (make-random-state rstate))
         (indyvar #(:foo :bar :bax :qux))
         (subject (random-svref indyvar)))
    (assert (= expect
               (position subject indyvar))))
  
  (let* ((*random-state* (make-random-state rstate))
         (indyvar '(:foo :bar :baz :qux))
         (subject (random-nth indyvar)))
    (assert (= expect
               (position subject indyvar)))))

;; FIXME: figure out how to test `nshuffle'.
;; (let* ((rstate (make-random-state t))
;;        (*random-state* (make-random-state rstate))
;;        (indyvar #(:foo :bar :baz :qux))
;;        (expect (loop
;;                   for i from 0 below (length indyvar)
;;                   collect (+ i (random i)))))

;;   (let* ((*random-state* (make-random-state rstate))
;;          (subject (nshuffle indyvar)))
;;     (assert ())))