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

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

add vector & registration types

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