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

Last change on this file since 35456 was 35456, checked in by Kon Lovett, 17 months ago

begin typing, dep /

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