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

Last change on this file since 35477 was 35477, checked in by kon, 5 months ago

fix distribution generator type

File size: 4.5 KB
Line 
1;;;; srfi-27-vector.scm
2;;;; Kon Lovett, Feb '10
3
4; Chicken Generic Arithmetic!
5
6(module srfi-27-vector
7
8(;export
9  ;
10  make-random-permutations
11  make-random-vector
12  make-random-hollow-sphere
13  make-random-solid-sphere
14  ;
15  random-permutation!
16  random-vector!
17  random-hollow-sphere!
18  random-solid-sphere!)
19
20(import scheme chicken)
21
22(use
23  (only type-checks check-cardinal-integer check-vector check-procedure)
24  (only type-errors error-vector)
25  random-source
26  srfi-27-distributions
27  srfi-27-vector-support
28  srfi-27
29  srfi-27-distributions-support)
30
31;;;
32
33#;
34(define (vector-iota n)
35  (import (only vector-lib vector-unfold))
36  (vector-unfold values n) )
37
38(define (vector-iota! vec n)
39  (do ((i 0 (fx+ i 1)))
40      ((fx= i n) vec)
41    (vector-set! vec i i) ) )
42
43;;;
44
45;;
46
47;Knuth's "The Art of Computer Programming", Vol. II, 2nd ed., Algorithm P of
48;Section 3.4.2
49;
50(define (*random-permutation! vec rndint)
51  (let ((n (vector-length vec)))
52    (vector-iota! vec n)
53    (do ((k n (fx- k 1)))
54        ((fx= k 1)
55          vec )
56      ;random-swap
57      (let* (
58        (i (fx- k 1))
59        (j (rndint n))
60        (xi (vector-ref vec i))
61        (xj (vector-ref vec j)) )
62        (vector-set! vec i xj)
63        (vector-set! vec j xi) ) ) ) )
64
65(define (make-random-permutations #!key (randoms (current-random-integer)))
66  (lambda (n)
67    (*random-permutation!
68      (make-vector
69        (check-cardinal-integer 'make-random-permutations n 'length)
70        0)
71      (check-procedure 'make-random-permutations randoms 'randoms))) )
72
73(define (random-permutation! vec #!key (randoms (current-random-integer)))
74  (*random-permutation!
75    (check-vector 'random-permutation! vec)
76    (check-procedure 'random-permutation! randoms 'randoms)) )
77
78;;
79
80(define (make-random-vector #!key (randoms (current-random-real)))
81  (lambda (n)
82    (vector-filled!
83      (make-vector
84        (check-cardinal-integer 'random-vector n 'length))
85      (check-procedure 'make-random-vector randoms 'randoms))) )
86
87(define (random-vector! vec #!key (randoms (current-random-real)))
88  (vector%-filled!
89    (check-vector% 'random-vector! vec)
90    (check-procedure 'random-vector! randoms 'randoms)) )
91
92;;; Normal vectors
93
94;;
95
96; Fills vect with inexact real random numbers the sum of whose
97; squares is equal to 1.0.  Thinking of vect as coordinates in space
98; of dimension n = (vector-length vect), the coordinates are
99; uniformly distributed over the surface of the unit n-sphere.
100
101(define (**random-hollow-sphere! vec norms)
102  (vector%-filled! vec norms)
103  (vector%-scale! vec (*reciprocal (sqrt (vector%-sum-squares vec))))
104  vec )
105
106(define (*random-hollow-sphere! vec mu sigma randoms)
107  (let-values (
108      ((norms pl)
109        (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
110    (**random-hollow-sphere! vec norms) ) )
111
112(define (make-random-hollow-sphere #!key (mu 0.0) (sigma 1.0) (randoms (current-random-real)))
113  (let-values (
114      ((norms pl)
115        (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
116    (lambda (n)
117      (**random-hollow-sphere!
118        (make-vector (check-cardinal-integer 'random-hollow-sphere n 'length))
119        norms) ) ) )
120
121(define (random-hollow-sphere! vec #!key (mu 0.0) (sigma 1.0) (randoms (current-random-real)))
122  (*random-hollow-sphere!
123    (check-vector% 'random-hollow-sphere! vec)
124    mu sigma randoms) )
125
126;;
127
128; Fills vect with inexact real random numbers the sum of whose
129; squares is less than 1.0.  Thinking of vect as coordinates in
130; space of dimension n = (vector-length vect), the coordinates are
131; uniformly distributed within the unit n-sphere.
132
133(define (**random-solid-sphere! vec randoms norms)
134  (**random-hollow-sphere! vec norms)
135  (vector%-scale! vec (expt (randoms) (*reciprocal (vector%-length vec))))
136  vec )
137
138(define (*random-solid-sphere! vec mu sigma randoms)
139  (let-values (
140      ((norms pl)
141        (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
142    (**random-solid-sphere! vec randoms norms) ) )
143
144(define (make-random-solid-sphere #!key (mu 0.0) (sigma 1.0) (randoms (current-random-real)))
145  (let-values (
146      ((norms pl)
147        (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
148    (lambda (n)
149      (**random-solid-sphere!
150        (make-vector (check-cardinal-integer 'random-solid-sphere n 'length))
151        randoms norms) ) ) )
152
153(define (random-solid-sphere! vec #!key (mu 0.0) (sigma 1.0) (randoms (current-random-real)))
154  (*random-solid-sphere!
155    (check-vector% 'random-solid-sphere! vec)
156    mu sigma randoms) )
157
158) ;module srfi-27-vector
Note: See TracBrowser for help on using the repository browser.