blob: 369040f62736bddd833b2f605a1916fa3e906cfa (
about) (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
|
;;; ps-vector: vector utilities for Pre-Scheme
;;;
;;; These routines are based on SRFI-43 for Scheme, with some
;;; adjustments to account for the limitations of Pre-Scheme.
;;;
;;; Pre-Scheme's native vectors don't support vector-length at runtime,
;;; so we take an additional length argument, as is common practice in C.
;;;
;;; Pre-Scheme doesn't support variadic functions, so we have a variant
;;; for each arity, as you might do in C. It should be possible to
;;; generate these with a macro, but that's not yet implemented.
;;; vector-unfold
(define-syntax vector-unfold
(syntax-rules ()
((_ proc len)
(vector-unfold0 proc len))
((_ proc len seed)
(vector-unfold1 proc len seed))
((_ proc len seed1 seed2)
(vector-unfold2 proc len seed1 seed2))
((_ proc len seed1 seed2 seed3)
(vector-unfold3 proc len seed1 seed2 seed3))))
(define (vector-unfold0 proc len)
;; FIXME get proc's return type without calling it
(let ((result (make-vector len (proc 0))))
(let loop ((i 0))
(if (= i len)
result
(begin
(vector-set! result i (proc i))
(loop (+ i 1)))))))
(define (vector-unfold1 proc len seed)
(let ((result (receive (val next)
(proc 0 seed)
(make-vector len val))))
(let loop ((i 0) (seed seed))
(if (= i len)
result
(receive (val next)
(proc i seed)
(vector-set! result i val)
(loop (+ i 1) next))))))
(define (vector-unfold2 proc len seed1 seed2)
(let ((result (receive (val next1 next2)
(proc 0 seed1 seed2)
(make-vector len val))))
(let loop ((i 0) (seed1 seed1) (seed2 seed2))
(if (= i len)
result
(receive (val next1 next2)
(proc i seed1 seed2)
(vector-set! result i val)
(loop (+ i 1) next1 next2))))))
(define (vector-unfold3 proc len seed1 seed2 seed3)
(let ((result (receive (val next1 next2 next3)
(proc 0 seed1 seed2 seed3)
(make-vector len val))))
(let loop ((i 0) (seed1 seed1) (seed2 seed2) (seed3 seed3))
(if (= i len)
result
(receive (val next1 next2 next3)
(proc i seed1 seed2 seed3)
(vector-set! result i val)
(loop (+ i 1) next1 next2 next3))))))
;;; vector-fold
(define-syntax vector-fold
(syntax-rules ()
((_ proc init vec len)
(vector-fold1 proc init vec len))
((_ proc init vec1 len1 vec2 len2)
(vector-fold2 proc init vec1 len1 vec2 len2))
((_ proc init vec1 len1 vec2 len2 vec3 len3)
(vector-fold3 proc init vec1 len1 vec2 len2 vec3 len3))))
(define (vector-fold1 proc init vec len)
(let loop ((i 0) (result init))
(if (= i len)
result
(loop (+ i 1) (proc i result (vector-ref vec i))))))
(define (vector-fold2 proc init vec1 len1 vec2 len2)
(let ((len (min len1 len2)))
(let loop ((i 0) (result init))
(if (= i len)
result
(loop (+ i 1) (proc i result
(vector-ref vec1 i)
(vector-ref vec2 i)))))))
(define (vector-fold3 proc init vec1 len1 vec2 len2 vec3 len3)
(let ((len (min len1 len2 len3)))
(let loop ((i 0) (result init))
(if (= i len)
result
(loop (+ i 1) (proc i result
(vector-ref vec1 i)
(vector-ref vec2 i)
(vector-ref vec3 i)))))))
;;; vector-map!
(define-syntax vector-map!
(syntax-rules ()
((_ proc vec len)
(vector-map1! proc vec len))
((_ proc vec1 len1 vec2 len2)
(vector-map2! proc vec1 len1 vec2 len2))
((_ proc vec1 len1 vec2 len2 vec3 len3)
(vector-map3! proc vec1 len1 vec2 len2 vec3 len3))))
(define (vector-map1! proc vec len)
(vector-fold (lambda (i vec val)
(vector-set! vec i (proc i val))
vec)
vec vec len))
(define (vector-map2! proc vec1 len1 vec2 len2)
(vector-fold (lambda (i vec val1 val2)
(vector-set! vec i (proc i val1 val2))
vec)
vec1 vec1 len1 vec2 len2))
(define (vector-map3! proc vec1 len1 vec2 len2 vec3 len3)
(vector-fold (lambda (i vec val1 val2 val3)
(vector-set! vec i (proc i val1 val2 val3))
vec)
vec1 vec1 len1 vec2 len2 vec3 len3))
;;; vector-map1
(define-syntax vector-map
(syntax-rules ()
((_ proc vec len)
(vector-map1 proc vec len))
((_ proc vec1 len1 vec2 len2)
(vector-map2 proc vec1 len1 vec2 len2))
((_ proc vec1 len1 vec2 len2 vec3 len3)
(vector-map3 proc vec1 len1 vec2 len2 vec3 len3))))
(define (vector-map1 proc vec len)
;; FIXME get proc's return type without calling it
(let ((res (make-vector len (proc 0 (vector-ref vec 0)))))
(vector-fold (lambda (i res val)
(vector-set! res i (proc i val))
res)
res vec len)))
(define (vector-map2 proc vec1 len1 vec2 len2)
(let* ((len (min len1 len2))
(res (make-vector len (proc 0
(vector-ref vec1 0)
(vector-ref vec2 0)))))
(vector-fold (lambda (i res val1 val2)
(vector-set! res i (proc i val1 val2))
res)
res vec1 len1 vec2 len2)))
(define (vector-map3 proc vec1 len1 vec2 len2 vec3 len3)
(let* ((len (min len1 len2 len3))
(res (make-vector len (proc 0
(vector-ref vec1 0)
(vector-ref vec2 0)
(vector-ref vec3 0)))))
(vector-fold (lambda (i res val1 val2 val3)
(vector-set! res i (proc i val1 val2 val3))
res)
res vec1 len1 vec2 len2 vec3 len3)))
;;; vector-for-each
(define-syntax vector-for-each
(syntax-rules ()
((_ proc vec len)
(vector-for-each1 proc vec len))
((_ proc vec1 len1 vec2 len2)
(vector-for-each2 proc vec1 len1 vec2 len2))
((_ proc vec1 len1 vec2 len2 vec3 len3)
(vector-for-each3 proc vec1 len1 vec2 len2 vec3 len3))))
(define (vector-for-each1 proc vec len)
(vector-fold (lambda (i res val)
(proc i val)
res)
(unspecific) vec len))
(define (vector-for-each2 proc vec1 len1 vec2 len2)
(vector-fold (lambda (i res val1 val2)
(proc i val1 val2)
res)
(unspecific) vec1 len1 vec2 len2))
(define (vector-for-each3 proc vec1 len1 vec2 len2 vec3 len3)
(vector-fold (lambda (i res val1 val2 val3)
(proc i val1 val2 val3)
res)
(unspecific) vec1 len1 vec2 len2 vec3 len3))
|
