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

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

Most doc. Generalizing the `vector' operations - on going.

File size: 7.2 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? check-random-source error-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-entropy-source random-source-entropy-source-set!
26    random-source-make-u8vectors
27    random-source-make-f64vectors
28    random-u8vector
29    random-f64vector
30    ;
31    current-entropy-source
32    make-entropy-source
33    entropy-source? check-entropy-source error-entropy-source
34    entropy-source-kind
35    entropy-source-documentation
36    entropy-source-u8
37    entropy-source-f64
38    entropy-source-u8vector
39    entropy-source-f64vector)
40
41  (import
42    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;;; Entropy Source
66
67;;
68
69(define default-entropy-source (make-entropy-source-system-clock))
70
71;;
72
73(define-parameter current-entropy-source default-entropy-source
74  (lambda (x)
75    (cond ((entropy-source? x) x)
76          (else
77            (warning-argument-type 'current-entropy-source x 'entropy-source)
78            (current-entropy-source) ) ) ) )
79
80(define (make-entropy-source #!optional (es (current-entropy-source)))
81  (let ((kind (if (entropy-source? es) (*entropy-source-kind es) es)))
82    (let ((maker (registered-entropy-source kind)))
83      (if maker (maker)
84          (error-argument-type 'make-entropy-source kind "registered entropy-source") ) ) ) )
85
86(define (entropy-source-kind es)
87  (check-entropy-source 'entropy-source-kind es)
88  (*entropy-source-kind es) )
89
90(define (entropy-source-documentation es)
91  (check-entropy-source 'entropy-source-documentation es)
92  (*entropy-source-documentation es) )
93
94(define (entropy-source-u8vector es n #!optional vec)
95  (check-entropy-source 'entropy-source-u8vector es)
96  (check-positive-fixnum 'entropy-source-u8vector n)
97  (when vec (check-u8vector 'entropy-source-u8vector vec))
98  ((@entropy-source-u8vector es) n vec) )
99
100(define (entropy-source-f64vector es n #!optional vec)
101  (check-entropy-source 'entropy-source-f64vector es)
102  (check-positive-fixnum 'entropy-source-f64vector n)
103  (when vec (check-f64vector 'entropy-source-f64vector vec))
104  ((@entropy-source-f64vector es) n vec) )
105
106(define (entropy-source-u8 es)
107  (check-entropy-source 'entropy-source-u8 es)
108  (@entropy-source-u8 es) )
109
110(define (entropy-source-f64 es)
111  (check-entropy-source 'entropy-source-f64 es)
112  (@entropy-source-f64 es) )
113
114;;; Random Source
115
116(define (*random-source-make-u8vectors rs)
117  (let ((rndint ((@random-source-make-integers rs))))
118    (lambda (n)
119      (check-cardinal-integer 'make-u8vector n 'length)
120      (u8vector-filled! (make-u8vector n) (lambda () (modulo (rndint) 256))) ) ) )
121
122(define (*random-source-make-f64vectors rs prec)
123  (let ((rnd ((@random-source-make-reals rs) prec)))
124    (lambda (n)
125      (check-cardinal-integer 'make-f64vector n 'length)
126      (f64vector-filled! (make-f64vector n) rnd) ) ) )
127
128;;
129
130(define default-random-source (make-random-source-mrg32k3a))
131
132(define random-integer ((@random-source-make-integers default-random-source)))
133
134(define random-real ((@random-source-make-reals default-random-source) #f))
135
136(define random-u8vector
137  (let ((mkv (*random-source-make-u8vectors default-random-source)))
138    (lambda (n) (mkv n) ) ) )
139
140(define random-f64vector
141  (let ((mkv (*random-source-make-f64vectors default-random-source #f)))
142    (lambda (n) (mkv n) ) ) )
143
144;;
145
146(define-parameter current-random-source default-random-source
147  (lambda (x)
148    (cond ((random-source? x) x)
149          (else
150            (warning-argument-type 'current-random-source x 'random-source)
151            (current-random-source) ) ) ) )
152
153(define (make-random-source #!optional (rs (current-random-source)))
154  (let ((kind (if (random-source? rs) (*random-source-kind rs) rs)))
155    (let ((maker (registered-random-source kind)))
156      (if maker (maker)
157          (error-argument-type 'make-random-source kind "registered random-source") ) ) ) )
158
159(define (random-source-kind rs)
160  (check-random-source 'random-source-kind rs)
161  (*random-source-kind rs) )
162
163(define (random-source-documentation rs)
164  (check-random-source 'random-source-documentation rs)
165  (*random-source-documentation rs) )
166
167(define (random-source-log2-period rs)
168  (check-random-source 'random-source-log2-period rs)
169  (*random-source-log2-period rs) )
170
171(define (random-source-maximum-range rs)
172  (check-random-source 'random-source-maximum-range rs)
173  (*random-source-maximum-range rs) )
174
175(define (random-source-entropy-source rs)
176  (check-random-source 'random-source-entropy-source rs)
177  (*random-source-entropy-source rs) )
178
179(define (random-source-entropy-source-set! rs es)
180  (check-random-source 'random-source-entropy-source-set! rs)
181  (check-entropy-source 'random-source-entropy-source-set! es)
182  (*random-source-entropy-source-set! rs es) )
183
184(define (random-source-state-ref rs)
185  (check-random-source 'random-source-state-ref rs)
186  ((@random-source-state-ref rs)) )
187
188(define (random-source-state-set! rs state)
189  (check-random-source 'random-source-state-set! rs)
190  ((@random-source-state-set! rs) state) )
191
192(define (random-source-randomize! rs #!optional es)
193  (check-random-source 'random-source-randomize! rs)
194  (when es (check-entropy-source 'random-source-randomize! es))
195  ((@random-source-randomize! rs)
196    (or es (*random-source-entropy-source rs) (current-entropy-source))) )
197
198(define (random-source-pseudo-randomize! rs i j)
199  (check-random-source 'random-source-pseudo-randomize! rs)
200  (check-cardinal-integer 'random-source-pseudo-randomize! i)
201  (check-cardinal-integer 'random-source-pseudo-randomize! j)
202  ((@random-source-pseudo-randomize! rs) i j) )
203
204(define (random-source-make-integers rs)
205  (check-random-source 'random-source-make-integers rs)
206  ((@random-source-make-integers rs)) )
207
208(define (random-source-make-reals rs #!optional prec)
209  (check-random-source 'random-source-make-reals rs)
210  (when prec (check-real-precision 'random-source-make-reals prec 'precision))
211  ((@random-source-make-reals rs) prec) )
212
213(define (random-source-make-u8vectors rs)
214  (check-random-source 'random-source-make-u8vectors rs)
215  (*random-source-make-u8vectors rs) )
216
217(define (random-source-make-f64vectors rs #!optional prec)
218  (check-random-source 'random-source-make-f64vectors rs)
219  (when prec (check-real-precision 'random-source-make-f64vectors prec 'precision))
220  (*random-source-make-f64vectors rs prec) )
221
222) ;module srfi-27
Note: See TracBrowser for help on using the repository browser.