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

Last change on this file since 17374 was 17374, checked in by Kon Lovett, 9 years ago

Stopped use of keyword "kinds". tests need 'numbers' egg.

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