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

Last change on this file since 35456 was 35456, checked in by kon, 12 months ago

begin typing, dep /

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  current-random-integer
49  current-random-real)
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-integer (deprecated current-random-integer))
219(define current-random-integer current-random-integer)
220
221(: current-random-real (--> float))
222;
223(define (current-random-real)
224  ((@random-source-make-reals (current-random-source)) #f) )
225
226(: current-random-real (deprecated current-random-real))
227(define current-random-real current-random-real)
228
229(: make-random-source (#!optional random-source --> random-source))
230;
231(define (make-random-source #!optional (rs (current-random-source)))
232  (let (
233    (ctor
234      (cond
235        ((random-source? rs)
236          (@random-source-constructor rs) )
237        ((symbol? rs)
238          (registered-random-source rs) )
239        (else
240          #f ) ) ) )
241    ;
242    (unless ctor
243      (error-argument-type
244        'make-random-source rs
245        "valid random-source or registered random-source name") )
246    (ctor) ) )
247
248(: new-random-source (#!optional random-source --> random-source))
249;
250(define (new-random-source #!optional (rs (current-random-source)))
251  ((@random-source-constructor (check-random-source 'new-random-source rs))) )
252
253(: random-source-name (random-source --> random-source-name))
254;
255(define (random-source-name rs)
256  (*random-source-name
257    (check-random-source 'random-source-name rs)) )
258
259(define random-source-kind random-source-name)
260
261(: random-source-documentation (random-source --> string))
262;
263(define (random-source-documentation rs)
264  (*random-source-documentation
265    (check-random-source 'random-source-documentation rs)) )
266
267(: random-source-log2-period (random-source --> float))
268;
269(define (random-source-log2-period rs)
270  (*random-source-log2-period
271    (check-random-source 'random-source-log2-period rs)) )
272
273(: random-source-maximum-range (random-source --> float))
274;
275(define (random-source-maximum-range rs)
276  (*random-source-maximum-range
277    (check-random-source 'random-source-maximum-range rs)) )
278
279(: random-source-entropy-source (random-source --> (or boolean entropy-source)))
280;
281(define (random-source-entropy-source rs)
282  (*random-source-entropy-source
283    (check-random-source 'random-source-entropy-source rs)) )
284
285(: random-source-entropy-source-set! (random-source (or boolean entropy-source) -> void))
286;
287(define (random-source-entropy-source-set! rs es)
288  (*random-source-entropy-source-set!
289    (check-random-source 'random-source-entropy-source-set! rs)
290    ;#f indicates no set entropy-source
291    (and es (check-entropy-source 'random-source-entropy-source-set! es))) )
292
293(: random-source-state-ref (random-source --> random-source-state))
294;
295(define (random-source-state-ref rs)
296  ((@random-source-state-ref (check-random-source 'random-source-state-ref rs))) )
297
298(: random-source-state-set! (random-source random-source-state -> void))
299;
300(define (random-source-state-set! rs state)
301  ((@random-source-state-set! (check-random-source 'random-source-state-set! rs))
302    state) )
303
304(: random-source-randomize! (random-source #!optional entropy-source -> void))
305;
306(define (random-source-randomize! rs #!optional es)
307  ((@random-source-randomize! (check-random-source 'random-source-randomize! rs))
308    (or
309      (and es (check-entropy-source 'random-source-randomize! es))
310      (*random-source-entropy-source rs)
311      (current-entropy-source))) )
312
313(: random-source-pseudo-randomize! (random-source fixnum fixnum -> void))
314;
315(define (random-source-pseudo-randomize! rs i j)
316  ((@random-source-pseudo-randomize! (check-random-source 'random-source-pseudo-randomize! rs))
317    (check-cardinal-integer 'random-source-pseudo-randomize! i)
318    (check-cardinal-integer 'random-source-pseudo-randomize! j)) )
319
320(: random-source-make-integers (random-source --> random-integer-function))
321;
322(define (random-source-make-integers rs)
323  ((@random-source-make-integers (check-random-source 'random-source-make-integers rs))) )
324
325(: random-source-make-integers (random-source #!optional fixnum --> random-real-function))
326;
327(define (random-source-make-reals rs #!optional prec)
328  ((@random-source-make-reals (check-random-source 'random-source-make-reals rs))
329    (and prec (check-real-precision 'random-source-make-reals prec 'precision))) )
330
331(: random-source-make-u8vectors (random-source --> random-u8vector-function))
332;
333(define (random-source-make-u8vectors rs)
334  (*random-source-make-u8vectors
335    (check-random-source 'random-source-make-u8vectors rs)) )
336
337(: random-source-make-u8vectors (random-source --> random-f64vector-function))
338;
339(define (random-source-make-f64vectors rs #!optional prec)
340  (*random-source-make-f64vectors
341    (check-random-source 'random-source-make-f64vectors rs)
342    (and prec (check-real-precision 'random-source-make-f64vectors prec 'precision))) )
343
344) ;module srfi-27
Note: See TracBrowser for help on using the repository browser.