;;; Random-number generation ;;; John David Stone ;;; Department of Computer Science ;;; Grinnell College ;;; created October 23, 1998 ;;; last revised January 9, 2017 (define-library (support random) (export random-number-generator shuffle) (import (scheme base) (scheme case-lambda)) (begin ;; ===== random-number-generator ====================================== ;; Given an exact integer, the random-number-generator procedure ;; constructs and returns a procedure that can be invoked any any of ;; three ways: ;; ;; (1) When invoked with no arguments, it returns a real number in the ;; range from 0 (inclusive) to 1 (exclusive). ;; ;; (2) When invoked with one argument, an exact positive integer, it ;; returns an exact integer in the range from 0 (inclusive) to that ;; argument (exclusive). ;; ;; (3) When invoked with two arguments, both exact integers, of which ;; the first is strictly less than the second, it returns an exact ;; integer in the range from the first argument (inclusive) to the ;; second (exclusive) ;; ;; The intention is that over a long sequence of calls with the same ;; arguments, the constructed procedure returns a sequence of values ;; that mimic the statistical characteristics of a random variable ;; uniformly distributed over the specified range. (define random-number-generator (let ((pod-size 100) (short-lag 37) (discard-size 909) (modulus (expt 2 30))) (let ((upper-index-bound (- pod-size 1))) (lambda (starter) (let ((pod (make-random-vector starter modulus pod-size short-lag)) (leader 0) (follower (- pod-size short-lag))) (rng-interface (lambda () (let ((result (vector-ref pod leader))) (if (= leader upper-index-bound) (begin (set! pod (discard-some-values pod modulus pod-size short-lag discard-size)) (set! leader 0)) (set! leader (+ leader 1))) (if (= follower upper-index-bound) (set! follower 0) (set! follower (+ follower 1))) (/ result modulus))))))))) ;; ===== make-random-vector =========================================== ;; The make-random-vector procedure builds a vector of exact integers ;; to serve as the state of a random-number-generator. (define make-random-vector (let ((force-to-even (lambda (number) (if (odd? number) (- number 1) number))) (stream-separation 70)) (lambda (starter modulus pod-size short-lag) (let ((prep-buffer (make-vector (+ (* pod-size 2) 1) 0)) (mod-diff (lambda (minuend subtrahend) (- (if (< minuend subtrahend) (+ modulus minuend) minuend) subtrahend))) (result (make-vector pod-size))) (let loop ((remaining pod-size) (index 0) (val (force-to-even (+ (remainder starter (- modulus 2)) 2)))) (unless (zero? remaining) (vector-set! prep-buffer index val) (loop (- remaining 1) (+ index 1) (let ((shifted (* val 2))) (if (< shifted modulus) shifted (- shifted (- modulus 2))))))) (vector-set! prep-buffer 1 (+ (vector-ref prep-buffer 1) 1)) (let main ((seed (remainder starter modulus)) (counter (- stream-separation 1))) (unless (and (zero? seed) (zero? counter)) (let loop ((index (- pod-size 1))) (unless (zero? index) (vector-set! prep-buffer (* index 2) (vector-ref prep-buffer index)) (loop (- index 1)))) (let loop ((remaining (quotient (- (+ pod-size short-lag) 1) 2)) (index (* (- pod-size 1) 2))) (unless (zero? remaining) (vector-set! prep-buffer (- (* pod-size 2) index 1) (force-to-even (vector-ref prep-buffer index))) (loop (- remaining 1) (- index 2)))) (let loop ((remaining (- pod-size 1)) (index (* (- pod-size 1) 2))) (unless (zero? remaining) (let ((current (vector-ref prep-buffer index)) (short-back (- index (- pod-size short-lag))) (long-back (- index pod-size))) (when (odd? current) (vector-set! prep-buffer short-back (mod-diff (vector-ref prep-buffer short-back) current)) (vector-set! prep-buffer long-back (mod-diff (vector-ref prep-buffer long-back) current)))) (loop (- remaining 1) (- index 1)))) (when (odd? seed) (let loop ((index pod-size)) (unless (zero? index) (let ((back-one (- index 1))) (vector-set! prep-buffer index (vector-ref prep-buffer back-one)) (loop back-one)))) (vector-set! prep-buffer 0 (vector-ref prep-buffer pod-size)) (if (odd? (vector-ref prep-buffer pod-size)) (vector-set! prep-buffer short-lag (mod-diff (vector-ref prep-buffer short-lag) (vector-ref prep-buffer pod-size))))) (if (zero? seed) (main seed (- counter 1)) (main (quotient seed 2) counter)))) (let loop ((remaining pod-size) (index 0)) (unless (zero? remaining) (vector-set! result index (vector-ref prep-buffer (if (< index (- pod-size short-lag)) (+ index short-lag) (- (+ index short-lag) pod-size)))) (loop (- remaining 1) (+ index 1)))) result)))) ;; ===== rng-interface ================================================ ;; The rng-interface procedure takes a nullary procedure that produces ;; random values uniformly distributed over the range from 0 ;; (inclusive) to 1 (exclusive) and returns a random-number generator ;; that can be accessed in any of the three ways discussed above. (define (rng-interface source) (case-lambda (() (source)) ((bound) (exact (truncate (* bound (source))))) ((lower upper) (+ lower (exact (truncate (* (- upper lower) (source)))))))) ;; ===== discard-some-values ========================================== ;; The discard-some-values procedure generates some random values and ;; construct and returns a vector containing the last of them, ;; discarding the others. (define discard-some-values (lambda (source-pod modulus pod-size short-lag discard-size) (let ((junk (make-vector discard-size)) (result (make-vector pod-size)) (mod-diff (lambda (minuend subtrahend) (- (if (< minuend subtrahend) (+ modulus minuend) minuend) subtrahend)))) (let ((fetch (lambda (index) (if (negative? index) (vector-ref source-pod (+ index pod-size)) (if (< index discard-size) (vector-ref junk index) (vector-ref result (- index discard-size)))))) (carry (lambda (index value) (if (< index discard-size) (vector-set! junk index value) (vector-set! result (- index discard-size) value))))) (let loop ((remaining (+ discard-size pod-size)) (index 0)) (unless (zero? remaining) (carry index (mod-diff (fetch (- index pod-size)) (fetch (- index short-lag)))) (loop (- remaining 1) (+ index 1)))) result)))) ;; ===== shuffle ====================================================== ;; The shuffle procedure constructs a list containing the elements of a ;; given list, in a random order. (define (shuffle generator ls) (letrec ((split-evenly (lambda (ls) (if (null? (cdr ls)) (values (list (car ls)) (list)) (call-with-values (lambda () (split-evenly (cdr ls))) (lambda (left right) (values (cons (car ls) right) left)))))) (recombine (lambda (left right) (let loop ((llen (length left)) (lrest left) (rlen (length right)) (rrest right)) (if (zero? llen) rrest (if (zero? rlen) lrest (if (< (generator (+ llen rlen)) llen) (cons (car lrest) (loop (- llen 1) (cdr lrest) rlen rrest)) (cons (car rrest) (loop llen lrest (- rlen 1) (cdr rrest))))))))) (shuf (lambda (ls) (if (or (null? ls) (null? (cdr ls))) ls (call-with-values (lambda () (split-evenly ls)) (lambda (left right) (recombine (shuf left) (shuf right)))))))) (shuf ls))))) ;;; copyright (C) 2011, 2017 John David Stone ;;; This program is free software. You may redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation -- either version 3 of the License, or (at ;;; your option) any later version. A copy of the GNU General Public ;;; License is available on the World Wide Web at ;;; ;;; http://www.gnu.org/licenses/gpl.html ;;; ;;; This program is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY -- without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; General Public License for more details.