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

Last change on this file since 17246 was 17246, checked in by Kon Lovett, 10 years ago

Rename of func ref struct fields

File size: 6.3 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    current-entropy-source
27    new-entropy-source
28    make-entropy-source
29    entropy-source?
30    entropy-source-kind
31    entropy-source-documentation
32    entropy-source-u8
33    entropy-source-f64
34    entropy-source-u8vector
35    entropy-source-f64vector
36    ;
37    check-real-unit)
38
39  (import scheme
40          chicken
41          (only data-structures alist-ref alist-update!)
42          (only miscmacros define-parameter)
43          random-source
44          entropy-source
45          type-checks
46          srfi-4-checks
47          (only type-errors error-argument-type)
48          mrg32k3a
49          entropy-clock)
50
51  (require-library
52    data-structures
53    miscmacros
54    random-source entropy-source
55    mrg32k3a entropy-clock
56    type-checks type-errors srfi-4-checks )
57
58;;;
59
60(define (check-real-unit loc obj #!optional argnam)
61  (check-inexact loc obj argnam)
62  (check-real loc obj argnam)
63  (check-open-interval loc obj 0.0 1.0 argnam) )
64
65;;;
66
67(define-parameter current-entropy-source (new-entropy-source #:entropy-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 (checked-entropy-argument loc obj)
75  (cond ((symbol? obj)          obj) ;keyword is-a symbol
76        ((*entropy-source? obj) (*entropy-source-kind obj))
77        (else
78          (error-argument-type loc obj "symbol or entropy-source" 'source))) )
79
80(define (new-entropy-source s)
81  (let ((kind (checked-entropy-argument 'new-entropy-source s)))
82    (cond ((registered-entropy-source kind) => (cut <> kind))
83          (else
84            (error-argument-type 'new-entropy-source kind "registered entropy-source") ) ) ) )
85
86(define make-entropy-source
87  (let ((ess '()))
88    (lambda (#!optional (s (current-entropy-source)))
89      (let* ((kind (checked-entropy-argument 'make-entropy-source s))
90             (es (alist-ref kind ess eq?)) )
91        (or es
92            (let ((es (new-entropy-source s)))
93              (set! ess (alist-update! kind es ess eq?))
94              es ) ) ) ) ) )
95
96(define (entropy-source-kind e)
97  (check-entropy-source 'entropy-source-kind e)
98  (*entropy-source-kind e) )
99
100(define (entropy-source-documentation e)
101  (check-entropy-source 'entropy-source-documentation e)
102  (*entropy-source-documentation e) )
103
104(define (entropy-source-u8vector e n #!optional vec)
105  (check-entropy-source 'entropy-source-u8vector e)
106  (check-positive-fixnum 'entropy-source-u8vector n)
107  (when vec (check-u8vector 'entropy-source-u8vector vec))
108  ((@entropy-source-u8vector e) n vec) )
109
110(define (entropy-source-f64vector e n #!optional vec)
111  (check-entropy-source 'entropy-source-f64vector e)
112  (check-positive-fixnum 'entropy-source-f64vector n)
113  (when vec (check-f64vector 'entropy-source-f64vector vec))
114  ((@entropy-source-f64vector e) n vec) )
115
116(define (entropy-source-u8 e)
117  (check-entropy-source 'entropy-source-u8 e)
118  (@entropy-source-u8 e) )
119
120(define (entropy-source-f64 e)
121  (check-entropy-source 'entropy-source-f64 e)
122  (@entropy-source-f64 e) )
123
124;;;
125
126(define-parameter current-random-source (make-random-source #:MRG32k3a)
127  (lambda (x)
128    (cond ((random-source? x) x)
129          (else
130            (warning-argument-type 'current-random-source x 'random-source)
131            (current-random-source) ) ) ) )
132
133;;
134
135(define default-random-source (current-random-source))
136
137(define random-integer ((@random-source-make-integers default-random-source)))
138
139(define random-real ((@random-source-make-reals default-random-source)))
140
141;;
142
143(define (make-random-source #!optional (s (current-random-source)))
144  (let ((kind (cond ((symbol? s)        s) ;keyword is-a symbol
145                    ((random-source?   s) (*random-source-kind s))
146                    (else
147                      (error-argument-type 'make-random-source
148                                           s "symbol or random-source" 'source)))))
149    (cond ((registered-random-source kind) => (cut <> kind))
150          (else
151            (error-argument-type 'make-random-source kind "registered random-source") ) ) ) )
152
153(define (random-source-kind s)
154  (check-random-source 'random-source-kind s)
155  (*random-source-kind s) )
156
157(define (random-source-documentation s)
158  (check-random-source 'random-source-documentation s)
159  (*random-source-documentation s) )
160
161(define (random-source-log2-period s)
162  (check-random-source 'random-source-log2-period s)
163  (*random-source-log2-period s) )
164
165(define (random-source-maximum-range s)
166  (check-random-source 'random-source-maximum-range s)
167  (*random-source-maximum-range s) )
168
169(define (random-source-maximum-modulus s)
170  (check-random-source 'random-source-maximum-modulus s)
171  (*random-source-maximum-modulus s) )
172
173(define (random-source-state-ref s)
174  (check-random-source 'random-source-state-ref s)
175  ((@random-source-state-ref s)) )
176
177(define (random-source-state-set! s state)
178  (check-random-source 'random-source-state-set! s)
179  ((@random-source-state-set! s) state) )
180
181(define (random-source-randomize! s #!optional (e (current-entropy-source)))
182  (check-random-source 'random-source-randomize! s)
183  (check-entropy-source 'random-source-randomize! e)
184  ((@random-source-randomize! s) e) )
185
186(define (random-source-pseudo-randomize! s i j)
187  (check-random-source 'random-source-pseudo-randomize! s)
188  (check-cardinal-integer 'random-source-pseudo-randomize! i)
189  (check-cardinal-integer 'random-source-pseudo-randomize! j)
190  ((@random-source-pseudo-randomize! s) i j) )
191
192(define (random-source-make-integers s)
193  (check-random-source 'random-source-make-integers s)
194  ((@random-source-make-integers s)) )
195
196(define (random-source-make-reals s #!optional u)
197  (check-random-source 'random-source-make-reals s)
198  (when u (check-real-unit 'random-source-make-reals u 'unit))
199  ((@random-source-make-reals s) u) )
200
201) ;module srfi-27
Note: See TracBrowser for help on using the repository browser.