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