|
| 1 | +;; SRFI-27 Implementation for Goldfish Scheme |
| 2 | +;; |
| 3 | +;; This is an implementation of SRFI-27 "Sources of Random Bits". |
| 4 | +;; It is based on s7.c's built-in random functions. |
| 5 | +;; |
| 6 | +;; Copyright (C) Sebastian Egner (2002). All Rights Reserved. |
| 7 | +;; |
| 8 | +;; Permission is hereby granted, free of charge, to any person obtaining |
| 9 | +;; a copy of this software and associated documentation files (the |
| 10 | +;; "Software"), to deal in the Software without restriction, including |
| 11 | +;; without limitation the rights to use, copy, modify, merge, publish, |
| 12 | +;; distribute, sublicense, and/or sell copies of the Software, and to |
| 13 | +;; permit persons to whom the Software is furnished to do so, subject to |
| 14 | +;; the following conditions: |
| 15 | +;; |
| 16 | +;; The above copyright notice and this permission notice shall be |
| 17 | +;; included in all copies or substantial portions of the Software. |
| 18 | +;; |
| 19 | +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, |
| 20 | +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF |
| 21 | +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND |
| 22 | +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE |
| 23 | +;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION |
| 24 | +;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION |
| 25 | +;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |
| 26 | + |
| 27 | +(define-library (srfi srfi-27) |
| 28 | + (import (scheme base) |
| 29 | + (srfi srfi-19) |
| 30 | + (liii error) |
| 31 | + ) ;import |
| 32 | + (export |
| 33 | + random-integer |
| 34 | + random-real |
| 35 | + default-random-source |
| 36 | + make-random-source |
| 37 | + random-source? |
| 38 | + random-source-state-ref |
| 39 | + random-source-state-set! |
| 40 | + random-source-randomize! |
| 41 | + random-source-pseudo-randomize! |
| 42 | + random-source-make-integers |
| 43 | + random-source-make-reals |
| 44 | + ) ;export |
| 45 | + (begin |
| 46 | + |
| 47 | + ;; ==================== |
| 48 | + ;; Random Source Record Type |
| 49 | + ;; ==================== |
| 50 | + ;; A random-source is a record containing: |
| 51 | + ;; - state: the underlying s7 random-state object |
| 52 | + ;; - state-ref: thunk to get the state as external representation |
| 53 | + ;; - state-set!: procedure to set state from external representation |
| 54 | + ;; - randomize!: procedure to randomize state |
| 55 | + ;; - pseudo-randomize!: procedure to pseudo-randomize with indices |
| 56 | + ;; - make-integers: procedure returning a random-integer generator |
| 57 | + ;; - make-reals: procedure returning a random-real generator |
| 58 | + |
| 59 | + (define-record-type <random-source> |
| 60 | + (%make-random-source state state-ref state-set! randomize! pseudo-randomize! make-integers make-reals) |
| 61 | + random-source? |
| 62 | + (state random-source-internal-state) |
| 63 | + (state-ref random-source-state-ref-proc) |
| 64 | + (state-set! random-source-state-set-proc) |
| 65 | + (randomize! random-source-randomize-proc) |
| 66 | + (pseudo-randomize! random-source-pseudo-randomize-proc) |
| 67 | + (make-integers random-source-make-integers-proc) |
| 68 | + (make-reals random-source-make-reals-proc) |
| 69 | + ) ;define-record-type |
| 70 | + |
| 71 | + ;; ==================== |
| 72 | + ;; Internal Helpers |
| 73 | + ;; ==================== |
| 74 | + |
| 75 | + ;; Get current time in nanoseconds as integer |
| 76 | + ;; Used for randomization |
| 77 | + (define (current-time-nanoseconds) |
| 78 | + (let ((t (current-time TIME-UTC))) |
| 79 | + (+ (* (time-second t) 1000000000) |
| 80 | + (time-nanosecond t) |
| 81 | + ) ;+ |
| 82 | + ) ;let |
| 83 | + ) ;define |
| 84 | + |
| 85 | + ;; Create a new s7 random-state with given seed and carry |
| 86 | + (define (make-s7-random-state seed carry) |
| 87 | + (random-state seed carry) |
| 88 | + ) ;define |
| 89 | + |
| 90 | + ;; Get state as list (seed carry) |
| 91 | + (define (get-s7-state state) |
| 92 | + (random-state->list state) |
| 93 | + ) ;define |
| 94 | + |
| 95 | + ;; ==================== |
| 96 | + ;; Random Source Operations |
| 97 | + ;; ==================== |
| 98 | + |
| 99 | + (define (make-random-source) |
| 100 | + (let ((state (random-state 0))) ; Create initial state with seed 0 |
| 101 | + (%make-random-source |
| 102 | + state |
| 103 | + ;; state-ref: return external representation |
| 104 | + (lambda () |
| 105 | + (cons 'random-source-state (random-state->list state)) |
| 106 | + ) ;lambda |
| 107 | + ;; state-set!: set state from external representation |
| 108 | + (lambda (new-state) |
| 109 | + (unless (and (pair? new-state) |
| 110 | + (eq? (car new-state) 'random-source-state) |
| 111 | + (= (length new-state) 3)) |
| 112 | + (error 'wrong-type-arg "invalid random source state" new-state) |
| 113 | + ) ;unless |
| 114 | + (let ((seed (cadr new-state)) |
| 115 | + (carry (caddr new-state))) |
| 116 | + (set! state (random-state seed carry)) |
| 117 | + ) ;let |
| 118 | + ) ;lambda |
| 119 | + ;; randomize!: use current time to randomize |
| 120 | + (lambda () |
| 121 | + (let ((ns (current-time-nanoseconds))) |
| 122 | + ;; Use nanoseconds to create a pseudo-random seed |
| 123 | + (let ((seed (modulo ns 4294967296)) |
| 124 | + (carry (modulo (quotient ns 4294967296) 4294967296))) |
| 125 | + (set! state (random-state seed carry)) |
| 126 | + ) ;let |
| 127 | + ) ;let |
| 128 | + ) ;lambda |
| 129 | + ;; pseudo-randomize!: use i, j indices |
| 130 | + (lambda (i j) |
| 131 | + (unless (and (integer? i) (exact? i) (>= i 0)) |
| 132 | + (error 'wrong-type-arg "pseudo-randomize! i must be a non-negative exact integer" i) |
| 133 | + ) ;unless |
| 134 | + (unless (and (integer? j) (exact? j) (>= j 0)) |
| 135 | + (error 'wrong-type-arg "pseudo-randomize! j must be a non-negative exact integer" j) |
| 136 | + ) ;unless |
| 137 | + ;; Create a deterministic state based on i and j |
| 138 | + ;; Using a simple hash of i and j to create seed and carry |
| 139 | + (let ((seed (modulo (+ (* i 12345) j) 4294967296)) |
| 140 | + (carry (modulo (+ (* j 54321) i) 4294967296))) |
| 141 | + (set! state (random-state seed carry)) |
| 142 | + ) ;let |
| 143 | + ) ;lambda |
| 144 | + ;; make-integers: return a procedure that generates random integers |
| 145 | + (lambda () |
| 146 | + (lambda (n) |
| 147 | + (unless (and (integer? n) (exact? n) (positive? n)) |
| 148 | + (error 'wrong-type-arg "random-integer: n must be a positive exact integer" n) |
| 149 | + ) ;unless |
| 150 | + ;; s7's random returns [0, n), we need [0, n-1] which is the same |
| 151 | + (random n state) |
| 152 | + ) ;lambda |
| 153 | + ) ;lambda |
| 154 | + ;; make-reals: return a procedure that generates random reals |
| 155 | + (lambda args |
| 156 | + (let ((unit #f)) |
| 157 | + (if (pair? args) |
| 158 | + (begin |
| 159 | + (set! unit (car args)) |
| 160 | + (unless (and (real? unit) (< 0 unit 1)) |
| 161 | + (error 'wrong-type-arg "random-source-make-reals: unit must be a real in (0,1)" unit) |
| 162 | + ) ;unless |
| 163 | + ) ;begin |
| 164 | + ) ;if |
| 165 | + (lambda () |
| 166 | + (let ((r (random 1.0 state))) |
| 167 | + ;; random returns [0.0, 1.0), but SRFI-27 requires (0, 1) |
| 168 | + ;; s7's random for reals already returns (0, 1) when n > 0 |
| 169 | + ;; But we need to ensure we never return 0 or 1 |
| 170 | + (if (zero? r) |
| 171 | + 0.0000000000000001 ; smallest positive value |
| 172 | + r |
| 173 | + ) ;if |
| 174 | + ) ;let |
| 175 | + ) ;lambda |
| 176 | + ) ;let |
| 177 | + ) ;lambda |
| 178 | + ) ;%make-random-source |
| 179 | + ) ;let |
| 180 | + ) ;define |
| 181 | + |
| 182 | + ;; ==================== |
| 183 | + ;; Standard Interface |
| 184 | + ;; ==================== |
| 185 | + |
| 186 | + (define default-random-source (make-random-source)) |
| 187 | + |
| 188 | + (define (random-integer n) |
| 189 | + ((random-source-make-integers default-random-source) n) |
| 190 | + ) ;define |
| 191 | + |
| 192 | + (define (random-real) |
| 193 | + ((random-source-make-reals default-random-source)) |
| 194 | + ) ;define |
| 195 | + |
| 196 | + ;; ==================== |
| 197 | + ;; Random Source State Operations |
| 198 | + ;; ==================== |
| 199 | + |
| 200 | + (define (random-source-state-ref s) |
| 201 | + (unless (random-source? s) |
| 202 | + (error 'wrong-type-arg "random-source-state-ref: expected random-source" s) |
| 203 | + ) ;unless |
| 204 | + ((random-source-state-ref-proc s)) |
| 205 | + ) ;define |
| 206 | + |
| 207 | + (define (random-source-state-set! s new-state) |
| 208 | + (unless (random-source? s) |
| 209 | + (error 'wrong-type-arg "random-source-state-set!: expected random-source" s) |
| 210 | + ) ;unless |
| 211 | + ((random-source-state-set-proc s) new-state) |
| 212 | + ) ;define |
| 213 | + |
| 214 | + (define (random-source-randomize! s) |
| 215 | + (unless (random-source? s) |
| 216 | + (error 'wrong-type-arg "random-source-randomize!: expected random-source" s) |
| 217 | + ) ;unless |
| 218 | + ((random-source-randomize-proc s)) |
| 219 | + ) ;define |
| 220 | + |
| 221 | + (define (random-source-pseudo-randomize! s i j) |
| 222 | + (unless (random-source? s) |
| 223 | + (error 'wrong-type-arg "random-source-pseudo-randomize!: expected random-source" s) |
| 224 | + ) ;unless |
| 225 | + ((random-source-pseudo-randomize-proc s) i j) |
| 226 | + ) ;define |
| 227 | + |
| 228 | + ;; ==================== |
| 229 | + ;; Random Source Generator Creation |
| 230 | + ;; ==================== |
| 231 | + |
| 232 | + (define (random-source-make-integers s) |
| 233 | + (unless (random-source? s) |
| 234 | + (error 'wrong-type-arg "random-source-make-integers: expected random-source" s) |
| 235 | + ) ;unless |
| 236 | + ((random-source-make-integers-proc s)) |
| 237 | + ) ;define |
| 238 | + |
| 239 | + (define (random-source-make-reals s . unit) |
| 240 | + (unless (random-source? s) |
| 241 | + (error 'wrong-type-arg "random-source-make-reals: expected random-source" s) |
| 242 | + ) ;unless |
| 243 | + (apply (random-source-make-reals-proc s) unit) |
| 244 | + ) ;define |
| 245 | + |
| 246 | + ) ;begin |
| 247 | +) ;define-library |
0 commit comments