/[slib]/slib/array.scm
ViewVC logotype

Contents of /slib/array.scm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.46 - (show annotations) (download)
Sat Oct 22 14:47:55 2022 UTC (17 months, 3 weeks ago) by jaffer
Branch: MAIN
CVS Tags: slib-3b7, slib-3c1, HEAD
Changes since 1.45: +9 -9 lines
Summary: (A:floQ128d, A:floQ64d, A:floQ32d): floR --> floQ.

* array.scm (A:floQ128d, A:floQ64d, A:floQ32d): floR --> floQ.

1 ;;;;"array.scm" Arrays for Scheme
2 ; Copyright (C) 2001, 2003, 2005, 2006 Aubrey Jaffer
3 ;
4 ;Permission to copy this software, to modify it, to redistribute it,
5 ;to distribute modified versions, and to use it for any purpose is
6 ;granted, subject to the following restrictions and understandings.
7 ;
8 ;1. Any copy made of this software must include this copyright notice
9 ;in full.
10 ;
11 ;2. I have made no warranty or representation that the operation of
12 ;this software will be error-free, and I am under no obligation to
13 ;provide any services, by way of maintenance, update, or otherwise.
14 ;
15 ;3. In conjunction with products arising from the use of this
16 ;material, there shall be no use of my name in any advertising,
17 ;promotional, or sales literature without prior written consent in
18 ;each case.
19
20 ;;@code{(require 'array)} or @code{(require 'srfi-63)}
21 ;;@ftindex array
22
23 (require 'record)
24 (require 'multiarg-apply)
25
26 (define array:rtd
27 (make-record-type "array"
28 '(dimensions
29 scales ;list of dimension scales
30 offset ;exact integer
31 store ;data
32 )))
33
34 (define array:dimensions
35 (let ((dimensions (record-accessor array:rtd 'dimensions)))
36 (lambda (array)
37 (cond ((vector? array) (list (vector-length array)))
38 ((string? array) (list (string-length array)))
39 (else (dimensions array))))))
40
41 (define array:scales
42 (let ((scales (record-accessor array:rtd 'scales)))
43 (lambda (obj)
44 (cond ((string? obj) '(1))
45 ((vector? obj) '(1))
46 (else (scales obj))))))
47
48 (define array:store
49 (let ((store (record-accessor array:rtd 'store)))
50 (lambda (obj)
51 (cond ((string? obj) obj)
52 ((vector? obj) obj)
53 (else (store obj))))))
54
55 (define array:offset
56 (let ((offset (record-accessor array:rtd 'offset)))
57 (lambda (obj)
58 (cond ((string? obj) 0)
59 ((vector? obj) 0)
60 (else (offset obj))))))
61
62 (define array:construct
63 (record-constructor array:rtd '(dimensions scales offset store)))
64
65 ;;@args obj
66 ;;Returns @code{#t} if the @1 is an array, and @code{#f} if not.
67 (define array?
68 (let ((array:array? (record-predicate array:rtd)))
69 (lambda (obj) (or (string? obj) (vector? obj) (array:array? obj)))))
70
71 ;;@noindent
72 ;;@emph{Note:} Arrays are not disjoint from other Scheme types.
73 ;;Vectors and possibly strings also satisfy @code{array?}.
74 ;;A disjoint array predicate can be written:
75 ;;
76 ;;@example
77 ;;(define (strict-array? obj)
78 ;; (and (array? obj) (not (string? obj)) (not (vector? obj))))
79 ;;@end example
80
81 ;;@body
82 ;;Returns @code{#t} if @1 and @2 have the same rank and dimensions and the
83 ;;corresponding elements of @1 and @2 are @code{equal?}.
84
85 ;;@body
86 ;;@0 recursively compares the contents of pairs, vectors, strings, and
87 ;;@emph{arrays}, applying @code{eqv?} on other objects such as numbers
88 ;;and symbols. A rule of thumb is that objects are generally @0 if
89 ;;they print the same. @0 may fail to terminate if its arguments are
90 ;;circular data structures.
91 ;;
92 ;;@example
93 ;;(equal? 'a 'a) @result{} #t
94 ;;(equal? '(a) '(a)) @result{} #t
95 ;;(equal? '(a (b) c)
96 ;; '(a (b) c)) @result{} #t
97 ;;(equal? "abc" "abc") @result{} #t
98 ;;(equal? 2 2) @result{} #t
99 ;;(equal? (make-vector 5 'a)
100 ;; (make-vector 5 'a)) @result{} #t
101 ;;(equal? (make-array (A:fixN32b 4) 5 3)
102 ;; (make-array (A:fixN32b 4) 5 3)) @result{} #t
103 ;;(equal? (make-array '#(foo) 3 3)
104 ;; (make-array '#(foo) 3 3)) @result{} #t
105 ;;(equal? (lambda (x) x)
106 ;; (lambda (y) y)) @result{} @emph{unspecified}
107 ;;@end example
108 (define (equal? obj1 obj2)
109 (cond ((eqv? obj1 obj2) #t)
110 ((or (pair? obj1) (pair? obj2))
111 (and (pair? obj1) (pair? obj2)
112 (equal? (car obj1) (car obj2))
113 (equal? (cdr obj1) (cdr obj2))))
114 ((and (string? obj1) (string? obj2))
115 (string=? obj1 obj2))
116 ((and (vector? obj1) (vector? obj2))
117 (and (equal? (vector-length obj1) (vector-length obj2))
118 (do ((idx (+ -1 (vector-length obj1)) (+ -1 idx)))
119 ((or (negative? idx)
120 (not (equal? (vector-ref obj1 idx)
121 (vector-ref obj2 idx))))
122 (negative? idx)))))
123 ((and (array? obj1) (array? obj2))
124 (and (equal? (array:dimensions obj1) (array:dimensions obj2))
125 (letrec ((rascan
126 (lambda (dims idxs)
127 (if (null? dims)
128 (equal? (apply array-ref obj1 idxs)
129 (apply array-ref obj2 idxs))
130 (do ((res #t (rascan (cdr dims) (cons idx idxs)))
131 (idx (+ -1 (car dims)) (+ -1 idx)))
132 ((or (not res) (negative? idx)) res))))))
133 (rascan (reverse (array:dimensions obj1)) '()))))
134 (else #f)))
135
136 ;;@body
137 ;;Returns the number of dimensions of @1. If @1 is not an array, 0 is
138 ;;returned.
139 (define (array-rank obj)
140 (if (array? obj) (length (array:dimensions obj)) 0))
141
142 ;;@args array
143 ;;Returns a list of dimensions.
144 ;;
145 ;;@example
146 ;;(array-dimensions (make-array '#() 3 5))
147 ;; @result{} (3 5)
148 ;;@end example
149 (define array-dimensions array:dimensions)
150
151 ;;@args prototype k1 @dots{}
152 ;;
153 ;;Creates and returns an array of type @1 with dimensions @2, @dots{}
154 ;;and filled with elements from @1. @1 must be an array, vector, or
155 ;;string. The implementation-dependent type of the returned array
156 ;;will be the same as the type of @1; except if that would be a vector
157 ;;or string with rank not equal to one, in which case some variety of
158 ;;array will be returned.
159 ;;
160 ;;If the @1 has no elements, then the initial contents of the returned
161 ;;array are unspecified. Otherwise, the returned array will be filled
162 ;;with the element at the origin of @1.
163 (define (make-array prototype . dimensions)
164 (define prot (array:store prototype))
165 (define pdims (array:dimensions prototype))
166 (define onedim? (eqv? 1 (length dimensions)))
167 (define tcnt (apply * dimensions))
168 (let ((initializer
169 (if (zero? (apply * pdims)) '()
170 (list
171 (apply array-ref
172 prototype
173 (map (lambda (x) 0) pdims))))))
174 (cond ((and onedim? (string? prot))
175 (apply make-string (car dimensions) initializer))
176 ((and onedim? (vector? prot))
177 (apply make-vector (car dimensions) initializer))
178 (else
179 (let ((store
180 (if (string? prot)
181 (apply make-string tcnt initializer)
182 (apply make-vector tcnt initializer))))
183 (define (loop dims scales)
184 (if (null? dims)
185 (array:construct dimensions (cdr scales) 0 store)
186 (loop (cdr dims)
187 (cons (* (car dims) (car scales)) scales))))
188 (loop (reverse dimensions) '(1)))))))
189 ;;@args prototype k1 @dots{}
190 ;;@0 is an alias for @code{make-array}.
191 (define create-array make-array)
192
193 ;;@args array mapper k1 @dots{}
194 ;;@0 can be used to create shared subarrays of other
195 ;;arrays. The @var{mapper} is a function that translates coordinates in
196 ;;the new array into coordinates in the old array. A @var{mapper} must be
197 ;;linear, and its range must stay within the bounds of the old array, but
198 ;;it can be otherwise arbitrary. A simple example:
199 ;;
200 ;;@example
201 ;;(define fred (make-array '#(#f) 8 8))
202 ;;(define freds-diagonal
203 ;; (make-shared-array fred (lambda (i) (list i i)) 8))
204 ;;(array-set! freds-diagonal 'foo 3)
205 ;;(array-ref fred 3 3)
206 ;; @result{} FOO
207 ;;(define freds-center
208 ;; (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j)))
209 ;; 2 2))
210 ;;(array-ref freds-center 0 0)
211 ;; @result{} FOO
212 ;;@end example
213 (define (make-shared-array array mapper . dimensions)
214 (define odl (array:scales array))
215 (define rank (length dimensions))
216 (define shape
217 (map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dimensions))
218 (do ((idx (+ -1 rank) (+ -1 idx))
219 (uvt (if (zero? rank)
220 '()
221 (append (cdr (vector->list (make-vector rank 0))) '(1)))
222 (append (cdr uvt) '(0)))
223 (uvts '() (cons uvt uvts)))
224 ((negative? idx)
225 (let ((ker0 (apply + (map * odl (apply mapper uvt)))))
226 (array:construct
227 (map (lambda (dim) (+ 1 (- (cadr dim) (car dim)))) shape)
228 (map (lambda (uvt) (- (apply + (map * odl (apply mapper uvt))) ker0))
229 uvts)
230 (apply +
231 (array:offset array)
232 (map * odl (apply mapper (map car shape))))
233 (array:store array))))))
234
235 ;;@args rank proto list
236 ;;@3 must be a rank-nested list consisting of all the elements, in
237 ;;row-major order, of the array to be created.
238 ;;
239 ;;@0 returns an array of rank @1 and type @2 consisting of all the
240 ;;elements, in row-major order, of @3. When @1 is 0, @3 is the lone
241 ;;array element; not necessarily a list.
242 ;;
243 ;;@example
244 ;;(list->array 2 '#() '((1 2) (3 4)))
245 ;; @result{} #2A((1 2) (3 4))
246 ;;(list->array 0 '#() 3)
247 ;; @result{} #0A 3
248 ;;@end example
249 (define (list->array rank proto lst)
250 (define dimensions
251 (do ((shp '() (cons (length row) shp))
252 (row lst (car lst))
253 (rnk (+ -1 rank) (+ -1 rnk)))
254 ((negative? rnk) (reverse shp))))
255 (let ((nra (apply make-array proto dimensions)))
256 (define (l2ra dims idxs row)
257 (cond ((null? dims)
258 (apply array-set! nra row (reverse idxs)))
259 ((if (not (eqv? (car dims) (length row)))
260 (slib:error 'list->array
261 'non-rectangular 'array dims dimensions))
262 (do ((idx 0 (+ 1 idx))
263 (row row (cdr row)))
264 ((>= idx (car dims)))
265 (l2ra (cdr dims) (cons idx idxs) (car row))))))
266 (l2ra dimensions '() lst)
267 nra))
268
269 ;;@args array
270 ;;Returns a rank-nested list consisting of all the elements, in
271 ;;row-major order, of @1. In the case of a rank-0 array, @0 returns
272 ;;the single element.
273 ;;
274 ;;@example
275 ;;(array->list #2A((ho ho ho) (ho oh oh)))
276 ;; @result{} ((ho ho ho) (ho oh oh))
277 ;;(array->list #0A ho)
278 ;; @result{} ho
279 ;;@end example
280 (define (array->list ra)
281 (define (ra2l dims idxs)
282 (if (null? dims)
283 (apply array-ref ra (reverse idxs))
284 (do ((lst '() (cons (ra2l (cdr dims) (cons idx idxs)) lst))
285 (idx (+ -1 (car dims)) (+ -1 idx)))
286 ((negative? idx) lst))))
287 (ra2l (array:dimensions ra) '()))
288
289 ;;@args vect proto dim1 @dots{}
290 ;;@1 must be a vector of length equal to the product of exact
291 ;;nonnegative integers @3, @dots{}.
292 ;;
293 ;;@0 returns an array of type @2 consisting of all the elements, in
294 ;;row-major order, of @1. In the case of a rank-0 array, @1 has a
295 ;;single element.
296 ;;
297 ;;@example
298 ;;(vector->array #(1 2 3 4) #() 2 2)
299 ;; @result{} #2A((1 2) (3 4))
300 ;;(vector->array '#(3) '#())
301 ;; @result{} #0A 3
302 ;;@end example
303 (define (vector->array vect prototype . dimensions)
304 (define vdx (vector-length vect))
305 (if (not (eqv? vdx (apply * dimensions)))
306 (slib:error 'vector->array vdx '<> (cons '* dimensions)))
307 (let ((ra (apply make-array prototype dimensions)))
308 (define (v2ra dims idxs)
309 (cond ((null? dims)
310 (set! vdx (+ -1 vdx))
311 (apply array-set! ra (vector-ref vect vdx) (reverse idxs)))
312 (else
313 (do ((idx (+ -1 (car dims)) (+ -1 idx)))
314 ((negative? idx) vect)
315 (v2ra (cdr dims) (cons idx idxs))))))
316 (v2ra dimensions '())
317 ra))
318
319 ;;@args array
320 ;;Returns a new vector consisting of all the elements of @1 in
321 ;;row-major order.
322 ;;
323 ;;@example
324 ;;(array->vector #2A ((1 2)( 3 4)))
325 ;; @result{} #(1 2 3 4)
326 ;;(array->vector #0A ho)
327 ;; @result{} #(ho)
328 ;;@end example
329 (define (array->vector ra)
330 (define dims (array:dimensions ra))
331 (let* ((vdx (apply * dims))
332 (vect (make-vector vdx)))
333 (define (ra2v dims idxs)
334 (if (null? dims)
335 (let ((val (apply array-ref ra (reverse idxs))))
336 (set! vdx (+ -1 vdx))
337 (vector-set! vect vdx val))
338 (do ((idx (+ -1 (car dims)) (+ -1 idx)))
339 ((negative? idx) vect)
340 (ra2v (cdr dims) (cons idx idxs)))))
341 (ra2v dims '())
342 vect))
343
344 (define (array:in-bounds? array indices)
345 (do ((bnds (array:dimensions array) (cdr bnds))
346 (idxs indices (cdr idxs)))
347 ((or (null? bnds)
348 (null? idxs)
349 (not (integer? (car idxs)))
350 (not (< -1 (car idxs) (car bnds))))
351 (and (null? bnds) (null? idxs)))))
352
353 ;;@args array index1 @dots{}
354 ;;Returns @code{#t} if its arguments would be acceptable to
355 ;;@code{array-ref}.
356 (define (array-in-bounds? array . indices)
357 (array:in-bounds? array indices))
358
359 ;;@args array k1 @dots{}
360 ;;Returns the (@2, @dots{}) element of @1.
361 (define (array-ref array . indices)
362 (define store (array:store array))
363 (or (array:in-bounds? array indices)
364 (slib:error 'array-ref 'bad-indices indices))
365 ((if (string? store) string-ref vector-ref)
366 store (apply + (array:offset array) (map * (array:scales array) indices))))
367
368 ;;@args array obj k1 @dots{}
369 ;;Stores @2 in the (@3, @dots{}) element of @1. The value returned
370 ;;by @0 is unspecified.
371 (define (array-set! array obj . indices)
372 (define store (array:store array))
373 (or (array:in-bounds? array indices)
374 (slib:error 'array-set! 'bad-indices indices))
375 ((if (string? store) string-set! vector-set!)
376 store (apply + (array:offset array) (map * (array:scales array) indices))
377 obj))
378
379 ;;@noindent
380 ;;These functions return a prototypical uniform-array enclosing the
381 ;;optional argument (which must be of the correct type). If the
382 ;;uniform-array type is supported by the implementation, then it is
383 ;;returned; defaulting to the next larger precision type; resorting
384 ;;finally to vector.
385
386 (define (make-prototype-checker name pred? creator)
387 (lambda args
388 (case (length args)
389 ((1) (if (pred? (car args))
390 (creator (car args))
391 (slib:error name 'incompatible 'type (car args))))
392 ((0) (creator))
393 (else (slib:error name 'wrong 'number 'of 'args args)))))
394
395 (define (integer-bytes?? n)
396 (lambda (obj)
397 (and (integer? obj)
398 (exact? obj)
399 (or (negative? n) (not (negative? obj)))
400 (do ((num obj (quotient num 256))
401 (n (+ -1 (abs n)) (+ -1 n)))
402 ((or (zero? num) (negative? n))
403 (zero? num))))))
404
405 ;;@defun A:floC128b z
406 ;;@defunx A:floC128b
407 ;;Returns an inexact 128.bit flonum complex uniform-array prototype.
408 ;;@end defun
409 (define A:floC128b (make-prototype-checker 'A:floC128b complex? vector))
410 ;;@defun A:floC64b z
411 ;;@defunx A:floC64b
412 ;;Returns an inexact 64.bit flonum complex uniform-array prototype.
413 ;;@end defun
414 (define A:floC64b (make-prototype-checker 'A:floC64b complex? vector))
415 ;;@defun A:floC32b z
416 ;;@defunx A:floC32b
417 ;;Returns an inexact 32.bit flonum complex uniform-array prototype.
418 ;;@end defun
419 (define A:floC32b (make-prototype-checker 'A:floC32b complex? vector))
420 ;;@defun A:floC16b z
421 ;;@defunx A:floC16b
422 ;;Returns an inexact 16.bit flonum complex uniform-array prototype.
423 ;;@end defun
424 (define A:floC16b (make-prototype-checker 'A:floC16b complex? vector))
425
426 ;;@defun A:floR128b x
427 ;;@defunx A:floR128b
428 ;;Returns an inexact 128.bit flonum real uniform-array prototype.
429 ;;@end defun
430 (define A:floR128b (make-prototype-checker 'A:floR128b real? vector))
431 ;;@defun A:floR64b x
432 ;;@defunx A:floR64b
433 ;;Returns an inexact 64.bit flonum real uniform-array prototype.
434 ;;@end defun
435 (define A:floR64b (make-prototype-checker 'A:floR64b real? vector))
436 ;;@defun A:floR32b x
437 ;;@defunx A:floR32b
438 ;;Returns an inexact 32.bit flonum real uniform-array prototype.
439 ;;@end defun
440 (define A:floR32b (make-prototype-checker 'A:floR32b real? vector))
441 ;;@defun A:floR16b x
442 ;;@defunx A:floR16b
443 ;;Returns an inexact 16.bit flonum real uniform-array prototype.
444 ;;@end defun
445 (define A:floR16b (make-prototype-checker 'A:floR16b real? vector))
446
447 ;;@defun A:floQ128d q
448 ;;@defunx A:floQ128d
449 ;;Returns an exact 128.bit decimal flonum rational uniform-array prototype.
450 ;;@end defun
451 (define A:floQ128d (make-prototype-checker 'A:floQ128d rational? vector))
452 ;;@defun A:floQ64d q
453 ;;@defunx A:floQ64d
454 ;;Returns an exact 64.bit decimal flonum rational uniform-array prototype.
455 ;;@end defun
456 (define A:floQ64d (make-prototype-checker 'A:floQ64d rational? vector))
457 ;;@defun A:floQ32d q
458 ;;@defunx A:floQ32d
459 ;;Returns an exact 32.bit decimal flonum rational uniform-array prototype.
460 ;;@end defun
461 (define A:floQ32d (make-prototype-checker 'A:floQ32d rational? vector))
462
463 ;;@defun A:fixZ64b n
464 ;;@defunx A:fixZ64b
465 ;;Returns an exact binary fixnum uniform-array prototype with at least
466 ;;64 bits of precision.
467 ;;@end defun
468 (define A:fixZ64b (make-prototype-checker 'A:fixZ64b (integer-bytes?? -8) vector))
469 ;;@defun A:fixZ32b n
470 ;;@defunx A:fixZ32b
471 ;;Returns an exact binary fixnum uniform-array prototype with at least
472 ;;32 bits of precision.
473 ;;@end defun
474 (define A:fixZ32b (make-prototype-checker 'A:fixZ32b (integer-bytes?? -4) vector))
475 ;;@defun A:fixZ16b n
476 ;;@defunx A:fixZ16b
477 ;;Returns an exact binary fixnum uniform-array prototype with at least
478 ;;16 bits of precision.
479 ;;@end defun
480 (define A:fixZ16b (make-prototype-checker 'A:fixZ16b (integer-bytes?? -2) vector))
481 ;;@defun A:fixZ8b n
482 ;;@defunx A:fixZ8b
483 ;;Returns an exact binary fixnum uniform-array prototype with at least
484 ;;8 bits of precision.
485 ;;@end defun
486 (define A:fixZ8b (make-prototype-checker 'A:fixZ8b (integer-bytes?? -1) vector))
487
488 ;;@defun A:fixN64b k
489 ;;@defunx A:fixN64b
490 ;;Returns an exact non-negative binary fixnum uniform-array prototype with at
491 ;;least 64 bits of precision.
492 ;;@end defun
493 (define A:fixN64b (make-prototype-checker 'A:fixN64b (integer-bytes?? 8) vector))
494 ;;@defun A:fixN32b k
495 ;;@defunx A:fixN32b
496 ;;Returns an exact non-negative binary fixnum uniform-array prototype with at
497 ;;least 32 bits of precision.
498 ;;@end defun
499 (define A:fixN32b (make-prototype-checker 'A:fixN32b (integer-bytes?? 4) vector))
500 ;;@defun A:fixN16b k
501 ;;@defunx A:fixN16b
502 ;;Returns an exact non-negative binary fixnum uniform-array prototype with at
503 ;;least 16 bits of precision.
504 ;;@end defun
505 (define A:fixN16b (make-prototype-checker 'A:fixN16b (integer-bytes?? 2) vector))
506 ;;@defun A:fixN8b k
507 ;;@defunx A:fixN8b
508 ;;Returns an exact non-negative binary fixnum uniform-array prototype with at
509 ;;least 8 bits of precision.
510 ;;@end defun
511 (define A:fixN8b (make-prototype-checker 'A:fixN8b (integer-bytes?? 1) vector))
512
513 ;;@defun A:bool bool
514 ;;@defunx A:bool
515 ;;Returns a boolean uniform-array prototype.
516 ;;@end defun
517 (define A:bool (make-prototype-checker 'A:bool boolean? vector))

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26