source: project/release/4/srfi-27/trunk/srfi-27.scm @ 34856

Last change on this file since 34856 was 34856, checked in by Kon Lovett, 2 years ago

re-flow

File size: 8.1 KB
Line 
1;;;; srfi-27.scm
2;;;; Kon Lovett, Jun '17
3;;;; Kon Lovett, Oct '09
4
5(module srfi-27
6
7(;export
8  ;; SRFI 27
9  default-random-source
10  random-integer
11  random-real
12  make-random-source
13  random-source? check-random-source error-random-source
14  random-source-state-ref
15  random-source-state-set!
16  random-source-randomize!
17  random-source-pseudo-randomize!
18  random-source-make-integers
19  random-source-make-reals
20  ;; Extensions
21  ;
22  registered-random-sources registered-random-source
23  current-random-source
24  random-integer/current random-real/current
25  new-random-source
26  random-source-name random-source-kind
27  random-source-documentation
28  random-source-log2-period
29  random-source-maximum-range
30  random-source-entropy-source random-source-entropy-source-set!
31  random-source-make-u8vectors
32  random-source-make-f64vectors
33  random-u8vector
34  random-f64vector
35  ;
36  registered-entropy-sources registered-entropy-source
37  current-entropy-source
38  make-entropy-source new-entropy-source
39  entropy-source? check-entropy-source error-entropy-source
40  entropy-source-name entropy-source-kind
41  entropy-source-documentation
42  entropy-source-u8
43  entropy-source-f64
44  entropy-source-u8vector
45  entropy-source-f64vector)
46
47(import scheme)
48
49(import chicken)
50
51(import
52  (only data-structures alist-ref alist-update!)
53  (only srfi-4 make-u8vector make-f64vector))
54(require-library data-structures srfi-4)
55
56(import (only miscmacros define-parameter))
57(require-library miscmacros)
58
59(import
60  (only type-errors error-argument-type warning-argument-type)
61  (only srfi-27-numbers check-real-precision)
62  (only srfi-27-vector-support u8vector-filled! f64vector-filled!))
63(require-library
64  type-errors
65  srfi-27-numbers srfi-27-vector-support)
66
67(use
68  type-checks srfi-4-checks
69  random-source mrg32k3a
70  entropy-source entropy-clock)
71
72;;; Entropy Source
73
74;;
75
76(define default-entropy-source (make-entropy-source-system-clock))
77
78;;
79
80(define-parameter current-entropy-source default-entropy-source
81  (lambda (x)
82    (cond
83      ((entropy-source? x)
84        x )
85      (else
86        (warning-argument-type 'current-entropy-source x 'entropy-source)
87        (current-entropy-source) ) ) ) )
88
89(define (make-entropy-source #!optional (es (current-entropy-source)))
90  (let (
91    (ctor
92      (cond
93        ((entropy-source? es)
94          (@entropy-source-constructor es) )
95        ((symbol? es)
96          (registered-entropy-source es) )
97        (else
98          #f ) ) ) )
99    ;
100    (unless ctor
101      (error-argument-type
102        'make-entropy-source es
103        "valid entropy-source or registered entropy-source name") )
104    (ctor) ) )
105
106(define (new-entropy-source es)
107  ((@entropy-source-constructor (check-entropy-source 'new-entropy-source es))) )
108
109(define (entropy-source-name es)
110  (*entropy-source-name (check-entropy-source 'entropy-source-name es)) )
111
112(define entropy-source-kind entropy-source-name)
113
114(define (entropy-source-documentation es)
115  (*entropy-source-documentation
116    (check-entropy-source 'entropy-source-documentation es)) )
117
118(define (entropy-source-u8vector es n #!optional vec)
119  ((@entropy-source-u8vector (check-entropy-source 'entropy-source-u8vector es))
120    (check-positive-fixnum 'entropy-source-u8vector n)
121    (and vec (check-u8vector 'entropy-source-u8vector vec))) )
122
123(define (entropy-source-f64vector es n #!optional vec)
124  ((@entropy-source-f64vector (check-entropy-source 'entropy-source-f64vector es))
125    (check-positive-fixnum 'entropy-source-f64vector n)
126    (and vec (check-f64vector 'entropy-source-f64vector vec))) )
127
128(define (entropy-source-u8 es)
129  (@entropy-source-u8 (check-entropy-source 'entropy-source-u8 es)) )
130
131(define (entropy-source-f64 es)
132  (@entropy-source-f64 (check-entropy-source 'entropy-source-f64 es)) )
133
134;;; Random Source
135
136(define (*random-source-make-u8vectors rs)
137  (let ((rndint ((@random-source-make-integers rs))))
138    (lambda (n)
139      (u8vector-filled!
140        (make-u8vector (check-cardinal-integer 'random-source-make-u8vector n 'length))
141        (lambda () (rndint 256))) ) ) )
142
143(define (*random-source-make-f64vectors rs prec)
144  (let ((rnd ((@random-source-make-reals rs) prec)))
145    (lambda (n)
146      (f64vector-filled!
147        (make-f64vector (check-cardinal-integer 'random-source-make-f64vector n 'length))
148        rnd) ) ) )
149
150;;
151
152(define default-random-source (make-random-source-mrg32k3a))
153
154(define random-integer ((@random-source-make-integers default-random-source)))
155
156(define random-real ((@random-source-make-reals default-random-source) #f))
157
158(define random-u8vector
159  (let ((mkv (*random-source-make-u8vectors default-random-source)))
160    (lambda (n) (mkv n) ) ) )
161
162(define random-f64vector
163  (let ((mkv (*random-source-make-f64vectors default-random-source #f)))
164    (lambda (n) (mkv n) ) ) )
165
166;;
167
168(define-parameter current-random-source default-random-source
169  (lambda (x)
170    (cond
171      ((random-source? x)
172        x )
173      (else
174        (warning-argument-type 'current-random-source x 'random-source)
175        (current-random-source) ) ) ) )
176
177(define (random-integer/current)
178  ((@random-source-make-integers (current-random-source))) )
179
180(define (random-real/current)
181  ((@random-source-make-reals (current-random-source)) #f) )
182
183(define (make-random-source #!optional (rs (current-random-source)))
184  (let (
185    (ctor
186      (cond
187        ((random-source? rs)
188          (@random-source-constructor rs) )
189        ((symbol? rs)
190          (registered-random-source rs) )
191        (else
192          #f ) ) ) )
193    ;
194    (unless ctor
195      (error-argument-type
196        'make-random-source rs
197        "valid random-source or registered random-source name") )
198    (ctor) ) )
199
200(define (new-random-source #!optional (rs (current-random-source)))
201  ((@random-source-constructor (check-random-source 'new-random-source rs))) )
202
203(define (random-source-name rs)
204  (*random-source-name
205    (check-random-source 'random-source-name rs)) )
206
207(define random-source-kind random-source-name)
208
209(define (random-source-documentation rs)
210  (*random-source-documentation
211    (check-random-source 'random-source-documentation rs)) )
212
213(define (random-source-log2-period rs)
214  (*random-source-log2-period
215    (check-random-source 'random-source-log2-period rs)) )
216
217(define (random-source-maximum-range rs)
218  (*random-source-maximum-range
219    (check-random-source 'random-source-maximum-range rs)) )
220
221(define (random-source-entropy-source rs)
222  (*random-source-entropy-source
223    (check-random-source 'random-source-entropy-source rs)) )
224
225(define (random-source-entropy-source-set! rs es)
226  (*random-source-entropy-source-set!
227    (check-random-source 'random-source-entropy-source-set! rs)
228    ;#f indicates no set entropy-source
229    (and es (check-entropy-source 'random-source-entropy-source-set! es))) )
230
231(define (random-source-state-ref rs)
232  ((@random-source-state-ref (check-random-source 'random-source-state-ref rs))) )
233
234(define (random-source-state-set! rs state)
235  ((@random-source-state-set! (check-random-source 'random-source-state-set! rs))
236    state) )
237
238(define (random-source-randomize! rs #!optional es)
239  ((@random-source-randomize! (check-random-source 'random-source-randomize! rs))
240    (or
241      (and es (check-entropy-source 'random-source-randomize! es))
242      (*random-source-entropy-source rs)
243      (current-entropy-source))) )
244
245(define (random-source-pseudo-randomize! rs i j)
246  ((@random-source-pseudo-randomize! (check-random-source 'random-source-pseudo-randomize! rs))
247    (check-cardinal-integer 'random-source-pseudo-randomize! i)
248    (check-cardinal-integer 'random-source-pseudo-randomize! j)) )
249
250(define (random-source-make-integers rs)
251  ((@random-source-make-integers (check-random-source 'random-source-make-integers rs))) )
252
253(define (random-source-make-reals rs #!optional prec)
254  ((@random-source-make-reals (check-random-source 'random-source-make-reals rs))
255    (and prec (check-real-precision 'random-source-make-reals prec 'precision))) )
256
257(define (random-source-make-u8vectors rs)
258  (*random-source-make-u8vectors
259    (check-random-source 'random-source-make-u8vectors rs)) )
260
261(define (random-source-make-f64vectors rs #!optional prec)
262  (*random-source-make-f64vectors
263    (check-random-source 'random-source-make-f64vectors rs)
264    (and prec (check-real-precision 'random-source-make-f64vectors prec 'precision))) )
265
266) ;module srfi-27
Note: See TracBrowser for help on using the repository browser.