diff options
Diffstat (limited to 'array.scm')
| -rw-r--r-- | array.scm | 186 |
1 files changed, 150 insertions, 36 deletions
@@ -1,5 +1,5 @@ ;;;;"array.scm" Arrays for Scheme -; Copyright (C) 2001 Aubrey Jaffer +; Copyright (C) 2001, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -30,7 +30,12 @@ store ;data ))) -(define array:shape (record-accessor array:rtd 'shape)) +(define array:shape + (let ((shape (record-accessor array:rtd 'shape))) + (lambda (array) + (cond ((vector? array) (list (list 0 (+ -1 (vector-length array))))) + ((string? array) (list (list 0 (+ -1 (string-length array))))) + (else (shape array)))))) (define array:scales (let ((scales (record-accessor array:rtd 'scales))) @@ -77,7 +82,8 @@ ;;corresponding elements of @1 and @2 are @code{equal?}. ;; ;;@example -;;(array=? (make-array 'foo 3 3) (make-array 'foo '(0 2) '(1 2))) +;;(array=? (create-array '#(foo) 3 3) +;; (create-array '#(foo) '(0 2) '(0 2))) ;; @result{} #t ;;@end example (define (array=? array1 array2) @@ -87,17 +93,133 @@ (define (array:dimensions->shape dims) (map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dims)) -;;@args initial-value bound1 bound2 @dots{} -;;Creates and returns an array with dimensions @var{bound1}, -;;@var{bound2}, @dots{} and filled with @1. -(define (make-array initial-value . dimensions) +;;@args prototype bound1 bound2 @dots{} +;; +;;Creates and returns an array of type @1 with dimensions @2, @3, +;;@dots{} and filled with elements from @1. @1 must be an array, +;;vector, or string. The implementation-dependent type of the returned +;;array will be the same as the type of @1; except if that would be a +;;vector or string with non-zero origin, in which case some variety of +;;array will be returned. +;; +;;If the @1 has no elements, then the initial contents of the returned +;;array are unspecified. Otherwise, the returned array will be filled +;;with the element at the origin of @1. +(define (create-array prototype . dimensions) + (define range2length (lambda (bnd) (- 1 (apply - bnd)))) + ;;(if (not (array? prototype)) (set! prototype (vector prototype))) (let* ((shape (array:dimensions->shape dimensions)) - (dims (map (lambda (bnd) (- 1 (apply - bnd))) shape)) - (scales (reverse (cons 1 (cdr (reverse dims)))))) - (array:construct shape - scales - (- (apply + (map * (map car shape) scales))) - (make-vector (apply * dims) initial-value)))) + (dims (map range2length shape)) + (scales + (do ((dims (reverse (cdr dims)) (cdr dims)) + (scls '(1) (cons (* (car dims) (car scls)) scls))) + ((null? dims) scls)))) + (array:construct + shape + scales + (- (apply + (map * (map car shape) scales))) + (if (string? prototype) + (case (string-length prototype) + ((0) (make-string (apply * dims))) + (else (make-string (apply * dims) + (string-ref prototype 0)))) + (let ((pshape (array:shape prototype))) + (case (apply * (map range2length pshape)) + ((0) (make-vector (apply * dims))) + (else (make-vector (apply * dims) + (apply array-ref prototype + (map car pshape)))))))))) + +;;@noindent +;;These functions return a prototypical uniform-array enclosing the +;;optional argument (which must be of the correct type). If the +;;uniform-array type is supported by the implementation, then it is +;;returned; defaulting to the next larger precision type; resorting +;;finally to vector. + +(define (make-prototype-checker name pred? creator) + (lambda args + (case (length args) + ((1) (if (pred? (car args)) + (creator (car args)) + (slib:error name 'incompatible 'type (car args)))) + ((0) (creator)) + (else (slib:error name 'wrong 'number 'of 'args args))))) + +(define (integer-bytes?? n) + (lambda (obj) + (and (integer? obj) + (exact? obj) + (or (negative? n) (not (negative? obj))) + (do ((num obj (quotient num 256)) + (n (+ -1 (abs n)) (+ -1 n))) + ((or (zero? num) (negative? n)) + (zero? num)))))) + +;;@args z +;;@args +;;Returns a high-precision complex uniform-array prototype. +(define Ac64 (make-prototype-checker 'Ac64 complex? vector)) +;;@args z +;;@args +;;Returns a complex uniform-array prototype. +(define Ac32 (make-prototype-checker 'Ac32 complex? vector)) + +;;@args x +;;@args +;;Returns a high-precision real uniform-array prototype. +(define Ar64 (make-prototype-checker 'Ar64 real? vector)) +;;@args x +;;@args +;;Returns a real uniform-array prototype. +(define Ar32 (make-prototype-checker 'Ar32 real? vector)) + +;;@args n +;;@args +;;Returns an exact signed integer uniform-array prototype with at least +;;64 bits of precision. +(define As64 (make-prototype-checker 'As64 (integer-bytes?? -8) vector)) +;;@args n +;;@args +;;Returns an exact signed integer uniform-array prototype with at least +;;32 bits of precision. +(define As32 (make-prototype-checker 'As32 (integer-bytes?? -4) vector)) +;;@args n +;;@args +;;Returns an exact signed integer uniform-array prototype with at least +;;16 bits of precision. +(define As16 (make-prototype-checker 'As16 (integer-bytes?? -2) vector)) +;;@args n +;;@args +;;Returns an exact signed integer uniform-array prototype with at least +;;8 bits of precision. +(define As8 (make-prototype-checker 'As8 (integer-bytes?? -1) vector)) + +;;@args k +;;@args +;;Returns an exact non-negative integer uniform-array prototype with at +;;least 64 bits of precision. +(define Au64 (make-prototype-checker 'Au64 (integer-bytes?? 8) vector)) +;;@args k +;;@args +;;Returns an exact non-negative integer uniform-array prototype with at +;;least 32 bits of precision. +(define Au32 (make-prototype-checker 'Au32 (integer-bytes?? 4) vector)) +;;@args k +;;@args +;;Returns an exact non-negative integer uniform-array prototype with at +;;least 16 bits of precision. +(define Au16 (make-prototype-checker 'Au16 (integer-bytes?? 2) vector)) +;;@args k +;;@args +;;Returns an exact non-negative integer uniform-array prototype with at +;;least 8 bits of precision. +(define Au8 (make-prototype-checker 'Au8 (integer-bytes?? 1) vector)) + +;;@args bool +;;@args +;;Returns a boolean uniform-array prototype. +(define At1 (make-prototype-checker 'At1 boolean? vector)) ;;@noindent ;;When constructing an array, @var{bound} is either an inclusive range of @@ -105,18 +227,18 @@ ;;a single integer. So ;; ;;@example -;;(make-array 'foo 3 3) @equiv{} (make-array 'foo '(0 2) '(0 2)) +;;(create-array '#(foo) 3 3) @equiv{} (create-array '#(foo) '(0 2) '(0 2)) ;;@end example ;;@args array mapper bound1 bound2 @dots{} -;;@code{make-shared-array} can be used to create shared subarrays of other +;;@0 can be used to create shared subarrays of other ;;arrays. The @var{mapper} is a function that translates coordinates in ;;the new array into coordinates in the old array. A @var{mapper} must be ;;linear, and its range must stay within the bounds of the old array, but ;;it can be otherwise arbitrary. A simple example: ;; ;;@example -;;(define fred (make-array #f 8 8)) +;;(define fred (create-array '#(#f) 8 8)) ;;(define freds-diagonal ;; (make-shared-array fred (lambda (i) (list i i)) 8)) ;;(array-set! freds-diagonal 'foo 3) @@ -153,32 +275,28 @@ ;;Returns the number of dimensions of @1. If @1 is not an array, 0 is ;;returned. (define (array-rank obj) - (if (array? obj) (length (array-shape obj)) 0)) + (if (array? obj) (length (array:shape obj)) 0)) -;;@body +;;@args array ;;Returns a list of inclusive bounds. ;; ;;@example -;;(array-shape (make-array 'foo 3 5)) +;;(array-shape (create-array '#() 3 5)) ;; @result{} ((0 2) (0 4)) ;;@end example -(define array-shape - (lambda (array) - (cond ((vector? array) (list (list 0 (+ -1 (vector-length array))))) - ((string? array) (list (list 0 (+ -1 (string-length array))))) - (else (array:shape array))))) +(define array-shape array:shape) ;;@body ;;@code{array-dimensions} is similar to @code{array-shape} but replaces ;;elements with a 0 minimum with one greater than the maximum. ;; ;;@example -;;(array-dimensions (make-array 'foo 3 5)) +;;(array-dimensions (create-array '#() 3 5)) ;; @result{} (3 5) ;;@end example (define (array-dimensions array) (map (lambda (bnd) (if (zero? (car bnd)) (+ 1 (cadr bnd)) bnd)) - (array-shape array))) + (array:shape array))) (define (array:in-bounds? array indices) (do ((bnds (array:shape array) (cdr bnds)) @@ -217,12 +335,8 @@ ;;; Legacy functions -;; These procedures are fast versions of @code{array-ref} and -;; @code{array-set!} for non-string arrays; they take a fixed number of -;; arguments and perform no bounds checking. -(define array-1d-ref array-ref) -(define array-2d-ref array-ref) -(define array-3d-ref array-ref) -(define array-1d-set! array-set!) -(define array-2d-set! array-set!) -(define array-3d-set! array-set!) +;; ;;@args initial-value bound1 bound2 @dots{} +;; ;;Creates and returns an array with dimensions @2, +;; ;;@3, @dots{} and filled with @1. +;; (define (make-array initial-value . dimensions) +;; (apply create-array (vector initial-value) dimensions)) |