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

Last change on this file since 35473 was 35473, checked in by kon, 7 months ago

fix make reals type, add type for clock entropy

File size: 10.5 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  ;
21  ;; Extensions
22  registered-random-sources registered-random-source
23  current-random-source
24  current-random-integer
25  current-random-real
26  new-random-source
27  random-source-name random-source-kind
28  random-source-documentation
29  random-source-log2-period
30  random-source-maximum-range
31  random-source-entropy-source random-source-entropy-source-set!
32  random-source-make-u8vectors
33  random-source-make-f64vectors
34  random-u8vector
35  random-f64vector
36  ;
37  registered-entropy-sources registered-entropy-source
38  current-entropy-source
39  make-entropy-source new-entropy-source
40  entropy-source? check-entropy-source error-entropy-source
41  entropy-source-name entropy-source-kind
42  entropy-source-documentation
43  entropy-source-u8
44  entropy-source-f64
45  entropy-source-u8vector
46  entropy-source-f64vector
47  ;;
48  random-integer/current
49  random-real/current)
50
51(import scheme chicken)
52
53(use
54  (only data-structures alist-ref alist-update!)
55  (only srfi-4 make-u8vector make-f64vector)
56  (only miscmacros define-parameter)
57  (only type-errors error-argument-type warning-argument-type)
58  (only srfi-27-numbers check-real-precision)
59  (only srfi-27-vector-support u8vector-filled! f64vector-filled!)
60  type-checks srfi-4-checks
61  random-source mrg32k3a
62  entropy-source entropy-clock)
63
64;;;
65
66(include "srfi-27-common-types")
67
68;;;
69
70;;; Entropy Source
71
72;;
73
74(: DEFAULT-ENTROPY-SOURCE entropy-source)
75;
76(define DEFAULT-ENTROPY-SOURCE (make-entropy-source-system-clock))
77
78;;
79
80(: current-entropy-source (#!optional entropy-source -> entropy-source))
81;
82(define-parameter current-entropy-source DEFAULT-ENTROPY-SOURCE
83  (lambda (x)
84    (cond
85      ((entropy-source? x)
86        x )
87      (else
88        (warning-argument-type 'current-entropy-source x 'entropy-source)
89        (current-entropy-source) ) ) ) )
90
91;;
92
93(: make-entropy-source (#!optional entropy-source --> entropy-source))
94;
95(define (make-entropy-source #!optional (es (current-entropy-source)))
96  (let (
97    (ctor
98      (cond
99        ((entropy-source? es)
100          (@entropy-source-constructor es) )
101        ((symbol? es)
102          (registered-entropy-source es) )
103        (else
104          #f ) ) ) )
105    ;
106    (unless ctor
107      (error-argument-type
108        'make-entropy-source es
109        "valid entropy-source or registered entropy-source name") )
110    (ctor) ) )
111
112(: new-entropy-source (entropy-source --> entropy-source))
113;
114(define (new-entropy-source es)
115  ((@entropy-source-constructor (check-entropy-source 'new-entropy-source es))) )
116
117(: entropy-source-name (entropy-source --> entropy-source-name))
118;
119(define (entropy-source-name es)
120  (*entropy-source-name (check-entropy-source 'entropy-source-name es)) )
121
122(define entropy-source-kind entropy-source-name)
123
124(: entropy-source-name (entropy-source --> symbol))
125;
126(define (entropy-source-documentation es)
127  (*entropy-source-documentation
128    (check-entropy-source 'entropy-source-documentation es)) )
129
130(: entropy-source-u8vector (entropy-source fixnum #!optional u8vector --> u8vector))
131;
132(define (entropy-source-u8vector es n #!optional vec)
133  ((@entropy-source-u8vector (check-entropy-source 'entropy-source-u8vector es))
134    (check-positive-fixnum 'entropy-source-u8vector n)
135    (and vec (check-u8vector 'entropy-source-u8vector vec))) )
136
137(: entropy-source-f64vector (entropy-source fixnum #!optional f64vector --> f64vector))
138;
139(define (entropy-source-f64vector es n #!optional vec)
140  ((@entropy-source-f64vector (check-entropy-source 'entropy-source-f64vector es))
141    (check-positive-fixnum 'entropy-source-f64vector n)
142    (and vec (check-f64vector 'entropy-source-f64vector vec))) )
143
144(: entropy-source-u8 (entropy-source --> random-u8-function))
145;
146(define (entropy-source-u8 es)
147  (@entropy-source-u8 (check-entropy-source 'entropy-source-u8 es)) )
148
149(: entropy-source-f64 (entropy-source --> random-f64-function))
150;
151(define (entropy-source-f64 es)
152  (@entropy-source-f64 (check-entropy-source 'entropy-source-f64 es)) )
153
154;;; Random Source
155
156(define (*random-source-make-u8vectors rs)
157  (let (
158    (*rnd* ((@random-source-make-integers rs))) )
159    (lambda (n)
160      (u8vector-filled!
161        (make-u8vector (check-cardinal-integer 'random-source-make-u8vector n 'length))
162        (lambda () (*rnd* 256))) ) ) )
163
164(define (*random-source-make-f64vectors rs prec)
165  (let (
166    (*rnd* ((@random-source-make-reals rs) prec)) )
167    (lambda (n)
168      (f64vector-filled!
169        (make-f64vector (check-cardinal-integer 'random-source-make-f64vector n 'length))
170        *rnd*) ) ) )
171
172;;
173
174(: default-random-source random-source)
175;
176(define default-random-source (make-random-source-mrg32k3a))
177
178(: random-integer random-integer-function)
179;
180(define random-integer ((@random-source-make-integers default-random-source)))
181
182(: random-real random-real-function)
183;
184(define random-real ((@random-source-make-reals default-random-source) #f))
185
186(: random-u8vector (fixnum --> u8vector))
187;
188(define random-u8vector
189  (let (
190    (*mkv* (*random-source-make-u8vectors default-random-source)) )
191    (lambda (n) (*mkv* n) ) ) )
192
193(: random-f64vector (fixnum --> f64vector))
194;
195(define random-f64vector
196  (let (
197    (*mkv* (*random-source-make-f64vectors default-random-source #f)) )
198    (lambda (n) (*mkv* n) ) ) )
199
200;;
201
202(: current-random-source (#!optional random-source -> random-source))
203;
204(define-parameter current-random-source default-random-source
205  (lambda (x)
206    (cond
207      ((random-source? x)
208        x )
209      (else
210        (warning-argument-type 'current-random-source x 'random-source)
211        (current-random-source) ) ) ) )
212
213(: current-random-integer (--> fixnum))
214;
215(define (current-random-integer)
216  ((@random-source-make-integers (current-random-source))) )
217
218(: current-random-real (--> float))
219;
220(define (current-random-real)
221  ((@random-source-make-reals (current-random-source)) #f) )
222
223(: make-random-source (#!optional random-source --> random-source))
224;
225(define (make-random-source #!optional (rs (current-random-source)))
226  (let (
227    (ctor
228      (cond
229        ((random-source? rs)
230          (@random-source-constructor rs) )
231        ((symbol? rs)
232          (registered-random-source rs) )
233        (else
234          #f ) ) ) )
235    ;
236    (unless ctor
237      (error-argument-type
238        'make-random-source rs
239        "valid random-source or registered random-source name") )
240    (ctor) ) )
241
242(: new-random-source (#!optional random-source --> random-source))
243;
244(define (new-random-source #!optional (rs (current-random-source)))
245  ((@random-source-constructor (check-random-source 'new-random-source rs))) )
246
247(: random-source-name (random-source --> random-source-name))
248;
249(define (random-source-name rs)
250  (*random-source-name
251    (check-random-source 'random-source-name rs)) )
252
253(define random-source-kind random-source-name)
254
255(: random-source-documentation (random-source --> string))
256;
257(define (random-source-documentation rs)
258  (*random-source-documentation
259    (check-random-source 'random-source-documentation rs)) )
260
261(: random-source-log2-period (random-source --> float))
262;
263(define (random-source-log2-period rs)
264  (*random-source-log2-period
265    (check-random-source 'random-source-log2-period rs)) )
266
267(: random-source-maximum-range (random-source --> float))
268;
269(define (random-source-maximum-range rs)
270  (*random-source-maximum-range
271    (check-random-source 'random-source-maximum-range rs)) )
272
273(: random-source-entropy-source (random-source --> (or boolean entropy-source)))
274;
275(define (random-source-entropy-source rs)
276  (*random-source-entropy-source
277    (check-random-source 'random-source-entropy-source rs)) )
278
279(: random-source-entropy-source-set! (random-source (or boolean entropy-source) -> void))
280;
281(define (random-source-entropy-source-set! rs es)
282  (*random-source-entropy-source-set!
283    (check-random-source 'random-source-entropy-source-set! rs)
284    ;#f indicates no set entropy-source
285    (and es (check-entropy-source 'random-source-entropy-source-set! es))) )
286
287(: random-source-state-ref (random-source --> random-source-state))
288;
289(define (random-source-state-ref rs)
290  ((@random-source-state-ref (check-random-source 'random-source-state-ref rs))) )
291
292(: random-source-state-set! (random-source random-source-state -> void))
293;
294(define (random-source-state-set! rs state)
295  ((@random-source-state-set! (check-random-source 'random-source-state-set! rs))
296    state) )
297
298(: random-source-randomize! (random-source #!optional entropy-source -> void))
299;
300(define (random-source-randomize! rs #!optional es)
301  ((@random-source-randomize! (check-random-source 'random-source-randomize! rs))
302    (or
303      (and es (check-entropy-source 'random-source-randomize! es))
304      (*random-source-entropy-source rs)
305      (current-entropy-source))) )
306
307(: random-source-pseudo-randomize! (random-source fixnum fixnum -> void))
308;
309(define (random-source-pseudo-randomize! rs i j)
310  ((@random-source-pseudo-randomize! (check-random-source 'random-source-pseudo-randomize! rs))
311    (check-cardinal-integer 'random-source-pseudo-randomize! i)
312    (check-cardinal-integer 'random-source-pseudo-randomize! j)) )
313
314(: random-source-make-integers (random-source --> random-integer-function))
315;
316(define (random-source-make-integers rs)
317  ((@random-source-make-integers (check-random-source 'random-source-make-integers rs))) )
318
319(: random-source-make-reals (random-source #!optional fixnum --> random-real-function))
320;
321(define (random-source-make-reals rs #!optional prec)
322  ((@random-source-make-reals (check-random-source 'random-source-make-reals rs))
323    (and prec (check-real-precision 'random-source-make-reals prec 'precision))) )
324
325(: random-source-make-u8vectors (random-source --> random-u8vector-function))
326;
327(define (random-source-make-u8vectors rs)
328  (*random-source-make-u8vectors
329    (check-random-source 'random-source-make-u8vectors rs)) )
330
331(: random-source-make-u8vectors (random-source --> random-f64vector-function))
332;
333(define (random-source-make-f64vectors rs #!optional prec)
334  (*random-source-make-f64vectors
335    (check-random-source 'random-source-make-f64vectors rs)
336    (and prec (check-real-precision 'random-source-make-f64vectors prec 'precision))) )
337
338;;;
339
340(: random-integer/current (deprecated current-random-integer))
341(define random-integer/current current-random-integer)
342
343(: random-real/current (deprecated current-random-real))
344(define random-real/current current-random-real)
345
346) ;module srfi-27
Note: See TracBrowser for help on using the repository browser.