1;;; 2;;; srfi-27.scm - Sources of Random Bits 3;;; 4;;; Copyright (c) 2000-2020 Shiro Kawai <shiro@acm.org> 5;;; 6;;; Redistribution and use in source and binary forms, with or without 7;;; modification, are permitted provided that the following conditions 8;;; are met: 9;;; 10;;; 1. Redistributions of source code must retain the above copyright 11;;; notice, this list of conditions and the following disclaimer. 12;;; 13;;; 2. Redistributions in binary form must reproduce the above copyright 14;;; notice, this list of conditions and the following disclaimer in the 15;;; documentation and/or other materials provided with the distribution. 16;;; 17;;; 3. Neither the name of the authors nor the names of its contributors 18;;; may be used to endorse or promote products derived from this 19;;; software without specific prior written permission. 20;;; 21;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 27;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32;;; 33 34;; Implements SRFI-27 interface on top of math.mt-random module. 35 36(define-module srfi-27 37 (use math.mt-random) 38 (use gauche.uvector) 39 (use binary.io) 40 (export random-integer random-real default-random-source 41 make-random-source random-source? 42 random-source-state-ref random-source-state-set! 43 random-source-randomize! random-source-pseudo-randomize! 44 random-source-make-integers random-source-make-reals 45 )) 46(select-module srfi-27) 47 48;; Assumes random source is <mersenne-twister> random object for now. 49;; It is possible that I extend the implementation so that users can 50;; specify the class of random source in future. 51(define-constant random-source <mersenne-twister>) 52 53;; Operations on random source 54(define (make-random-source) (make random-source)) 55(define (random-source? obj) (is-a? obj random-source)) 56(define default-random-source (make-random-source)) 57 58(define (random-source-state-ref source) 59 (mt-random-get-state source)) 60(define (random-source-state-set! source state) 61 (mt-random-set-state! source state)) 62 63;; Randomize 64(define (random-source-randomize! source) 65 (assume (random-source? source)) 66 (cond 67 [(sys-access "/dev/urandom" R_OK) 68 (call-with-input-file "/dev/urandom" 69 (^p 70 (let1 seedv (make-u32vector 4) 71 (u32vector-set! seedv 0 (read-u32 p)) 72 (u32vector-set! seedv 1 (read-u32 p)) 73 (u32vector-set! seedv 2 (read-u32 p)) 74 (u32vector-set! seedv 3 (read-u32 p)) 75 (mt-random-set-seed! source seedv))))] 76 [else 77 (let1 t (current-time) 78 (mt-random-set-seed! source 79 (* (~ t'second) (~ t'nanosecond) 80 (sys-getpid))))])) 81 82(define (random-source-pseudo-randomize! source i j) 83 ;; This procedure is effectively required to map integers (i,j) into 84 ;; a seed value in a deterministic way. Talking advantage of the fact 85 ;; that Mersenne Twister can take vector of numbers. 86 87 ;; interleave-i and interleave-j creates a list of integers, each 88 ;; is less than 2^32, consisted by interleaving each 32-bit chunk of i and j. 89 (define (interleave-i i j lis) 90 (if (zero? i) 91 (if (zero? j) lis (interleave-j 0 j (cons 0 lis))) 92 (receive (q r) (quotient&remainder i #x100000000) 93 (interleave-j q j (cons r lis))))) 94 95 (define (interleave-j i j lis) 96 (if (zero? j) 97 (if (zero? i) lis (interleave-i i 0 (cons 0 lis))) 98 (receive (q r) (quotient&remainder j #x100000000) 99 (interleave-i i q (cons r lis))))) 100 101 ;; main body 102 (assume (random-source? source)) 103 (when (or (not (integer? i)) (not (integer? j)) 104 (negative? i) (negative? j)) 105 (errorf "indices must be non-negative integers: ~s, ~s" i j)) 106 (mt-random-set-seed! source 107 (list->u32vector (interleave-i i j '(#xffffffff)))) 108 ) 109 110;; Obtain generators from random source. 111(define (random-source-make-integers source) 112 (assume (random-source? source)) 113 (^n (mt-random-integer source n))) 114 115(define random-source-make-reals 116 (case-lambda 117 [(source) 118 (assume (random-source? source)) 119 (^[] (mt-random-real source))] 120 [(source unit) 121 (assume (random-source? source)) 122 (unless (< 0 unit 1) 123 (error "unit must be between 0.0 and 1.0 (exclusive), but got" unit)) 124 (let* ([1/unit (/ unit)] 125 [range (- (floor->exact 1/unit) 1)]) 126 (^[] (/ (+ 1 (mt-random-integer source range)) 1/unit)))])) 127 128;; Default random generators. 129(define-values (random-integer random-real) 130 (let1 src default-random-source 131 (values (^n (mt-random-integer src n)) 132 (^[] (mt-random-real src))))) 133 134