diff options
Diffstat (limited to 'array.scm')
| -rw-r--r-- | array.scm | 528 |
1 files changed, 334 insertions, 194 deletions
@@ -1,5 +1,5 @@ ;;;;"array.scm" Arrays for Scheme -; Copyright (C) 2001, 2003 Aubrey Jaffer +; Copyright (C) 2001, 2003, 2005 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 @@ -17,25 +17,25 @@ ;promotional, or sales literature without prior written consent in ;each case. -;;@code{(require 'array)} +;;@code{(require 'array)} or @code{(require 'srfi-63)} ;;@ftindex array (require 'record) (define array:rtd (make-record-type "array" - '(shape + '(dimensions scales ;list of dimension scales offset ;exact integer store ;data ))) -(define array:shape - (let ((shape (record-accessor array:rtd 'shape))) +(define array:dimensions + (let ((dimensions (record-accessor array:rtd 'dimensions))) (lambda (array) - (cond ((vector? array) (list (list 0 (+ -1 (vector-length array))))) - ((string? array) (list (list 0 (+ -1 (string-length array))))) - (else (shape array)))))) + (cond ((vector? array) (list (vector-length array))) + ((string? array) (list (string-length array))) + (else (dimensions array)))))) (define array:scales (let ((scales (record-accessor array:rtd 'scales))) @@ -59,7 +59,7 @@ (else (offset obj)))))) (define array:construct - (record-constructor array:rtd '(shape scales offset store))) + (record-constructor array:rtd '(dimensions scales offset store))) ;;@args obj ;;Returns @code{#t} if the @1 is an array, and @code{#f} if not. @@ -68,9 +68,9 @@ (lambda (obj) (or (string? obj) (vector? obj) (array:array? obj))))) ;;@noindent -;;@emph{Note:} Arrays are not disjoint from other Scheme types. Strings -;;and vectors also satisfy @code{array?}. A disjoint array predicate can -;;be written: +;;@emph{Note:} Arrays are not disjoint from other Scheme types. +;;Vectors and possibly strings also satisfy @code{array?}. +;;A disjoint array predicate can be written: ;; ;;@example ;;(define (strict-array? obj) @@ -78,159 +78,106 @@ ;;@end example ;;@body -;;Returns @code{#t} if @1 and @2 have the same rank and shape and the +;;Returns @code{#t} if @1 and @2 have the same rank and dimensions and the ;;corresponding elements of @1 and @2 are @code{equal?}. + +;;@body +;;@0 recursively compares the contents of pairs, vectors, strings, and +;;@emph{arrays}, applying @code{eqv?} on other objects such as numbers +;;and symbols. A rule of thumb is that objects are generally @0 if +;;they print the same. @0 may fail to terminate if its arguments are +;;circular data structures. ;; ;;@example -;;(array=? (create-array '#(foo) 3 3) -;; (create-array '#(foo) '(0 2) '(0 2))) -;; @result{} #t +;;(equal? 'a 'a) @result{} #t +;;(equal? '(a) '(a)) @result{} #t +;;(equal? '(a (b) c) +;; '(a (b) c)) @result{} #t +;;(equal? "abc" "abc") @result{} #t +;;(equal? 2 2) @result{} #t +;;(equal? (make-vector 5 'a) +;; (make-vector 5 'a)) @result{} #t +;;(equal? (make-array (A:fixN32b 4) 5 3) +;; (make-array (A:fixN32b 4) 5 3)) @result{} #t +;;(equal? (make-array '#(foo) 3 3) +;; (make-array '#(foo) 3 3)) @result{} #t +;;(equal? (lambda (x) x) +;; (lambda (y) y)) @result{} @emph{unspecified} ;;@end example -(define (array=? array1 array2) - (and (equal? (array:shape array1) (array:shape array2)) - (equal? (array:store array1) (array:store array2)))) +(define (equal? obj1 obj2) + (cond ((eqv? obj1 obj2) #t) + ((or (pair? obj1) (pair? obj2)) + (and (pair? obj1) (pair? obj2) + (equal? (car obj1) (car obj2)) + (equal? (cdr obj1) (cdr obj2)))) + ((or (string? obj1) (string? obj2)) + (and (string? obj1) (string? obj2) + (string=? obj1 obj2))) + ((or (vector? obj1) (vector? obj2)) + (and (vector? obj1) (vector? obj2) + (equal? (vector-length obj1) (vector-length obj2)) + (do ((idx (+ -1 (vector-length obj1)) (+ -1 idx))) + ((or (negative? idx) + (not (equal? (vector-ref obj1 idx) + (vector-ref obj2 idx)))) + (negative? idx))))) + ((or (array? obj1) (array? obj2)) + (and (array? obj1) (array? obj2) + (equal? (array:dimensions obj1) (array:dimensions obj2)) + (equal? (array:store obj1) (array:store obj2)))) + (else #f))) -(define (array:dimensions->shape dims) - (map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dims)) +;;@body +;;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:dimensions obj)) 0)) + +;;@args array +;;Returns a list of dimensions. +;; +;;@example +;;(array-dimensions (make-array '#() 3 5)) +;; @result{} (3 5) +;;@end example +(define array-dimensions array:dimensions) -;;@args prototype bound1 bound2 @dots{} +;;@args prototype k1 @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 +;;Creates and returns an array of type @1 with dimensions @2, @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 rank not equal to one, 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 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 -;;indices expressed as a two element list, or an upper bound expressed as -;;a single integer. So -;; -;;@example -;;(create-array '#(foo) 3 3) @equiv{} (create-array '#(foo) '(0 2) '(0 2)) -;;@end example - -;;@args array mapper bound1 bound2 @dots{} +(define (make-array prototype . dimensions) + (define tcnt (apply * dimensions)) + (let ((store + (if (string? prototype) + (case (string-length prototype) + ((0) (make-string tcnt)) + (else (make-string tcnt + (string-ref prototype 0)))) + (let ((pdims (array:dimensions prototype))) + (case (apply * pdims) + ((0) (make-vector tcnt)) + (else (make-vector tcnt + (apply array-ref prototype + (map (lambda (x) 0) pdims))))))))) + (define (loop dims scales) + (if (null? dims) + (array:construct dimensions (cdr scales) 0 store) + (loop (cdr dims) (cons (* (car dims) (car scales)) scales)))) + (loop (reverse dimensions) '(1)))) +;;@args prototype k1 @dots{} +;;@0 is an alias for @code{make-array}. +(define create-array make-array) + +;;@args array mapper k1 @dots{} ;;@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 @@ -238,7 +185,7 @@ ;;it can be otherwise arbitrary. A simple example: ;; ;;@example -;;(define fred (create-array '#(#f) 8 8)) +;;(define fred (make-array '#(#f) 8 8)) ;;(define freds-diagonal ;; (make-shared-array fred (lambda (i) (list i i)) 8)) ;;(array-set! freds-diagonal 'foo 3) @@ -253,68 +200,149 @@ (define (make-shared-array array mapper . dimensions) (define odl (array:scales array)) (define rank (length dimensions)) - (define shape (array:dimensions->shape dimensions)) + (define shape + (map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dimensions)) (do ((idx (+ -1 rank) (+ -1 idx)) (uvt (append (cdr (vector->list (make-vector rank 0))) '(1)) (append (cdr uvt) '(0))) (uvts '() (cons uvt uvts))) ((negative? idx) - (let* ((ker0 (apply + (map * odl (apply mapper uvt)))) - (scales (map (lambda (uvt) - (- (apply + (map * odl (apply mapper uvt))) ker0)) - uvts))) + (let ((ker0 (apply + (map * odl (apply mapper uvt))))) (array:construct - shape - scales - (- (apply + (array:offset array) - (map * odl (apply mapper (map car shape)))) - (apply + (map * (map car shape) scales))) + (map (lambda (dim) (+ 1 (- (cadr dim) (car dim)))) shape) + (map (lambda (uvt) (- (apply + (map * odl (apply mapper uvt))) ker0)) + uvts) + (apply + + (array:offset array) + (map * odl (apply mapper (map car shape)))) (array:store array)))))) -;;@body -;;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)) +;;@args rank proto list +;;@3 must be a rank-nested list consisting of all the elements, in +;;row-major order, of the array to be created. +;; +;;@0 returns an array of rank @1 and type @2 consisting of all the +;;elements, in row-major order, of @3. When @1 is 0, @3 is the lone +;;array element; not necessarily a list. +;; +;;@example +;;(list->array 2 '#() '((1 2) (3 4))) +;; @result{} #2A((1 2) (3 4)) +;;(list->array 0 '#() 3) +;; @result{} #0A 3 +;;@end example +(define (list->array rank proto lst) + (define dimensions + (do ((shp '() (cons (length row) shp)) + (row lst (car lst)) + (rnk (+ -1 rank) (+ -1 rnk))) + ((negative? rnk) (reverse shp)))) + (let ((nra (apply make-array proto dimensions))) + (define (l2ra dims idxs row) + (cond ((null? dims) + (apply array-set! nra row (reverse idxs))) + ((if (not (eqv? (car dims) (length row))) + (slib:error 'list->array + 'non-rectangular 'array dims dimensions)) + (do ((idx 0 (+ 1 idx)) + (row row (cdr row))) + ((>= idx (car dims))) + (l2ra (cdr dims) (cons idx idxs) (car row)))))) + (l2ra dimensions '() lst) + nra)) ;;@args array -;;Returns a list of inclusive bounds. +;;Returns a rank-nested list consisting of all the elements, in +;;row-major order, of @1. In the case of a rank-0 array, @0 returns +;;the single element. +;; +;;@example +;;(array->list #2A((ho ho ho) (ho oh oh))) +;; @result{} ((ho ho ho) (ho oh oh)) +;;(array->list #0A ho) +;; @result{} ho +;;@end example +(define (array->list ra) + (define (ra2l dims idxs) + (if (null? dims) + (apply array-ref ra (reverse idxs)) + (do ((lst '() (cons (ra2l (cdr dims) (cons idx idxs)) lst)) + (idx (+ -1 (car dims)) (+ -1 idx))) + ((negative? idx) lst)))) + (ra2l (array-dimensions ra) '())) + +;;@args vect proto dim1 @dots{} +;;@1 must be a vector of length equal to the product of exact +;;nonnegative integers @3, @dots{}. +;; +;;@0 returns an array of type @2 consisting of all the elements, in +;;row-major order, of @1. In the case of a rank-0 array, @1 has a +;;single element. ;; ;;@example -;;(array-shape (create-array '#() 3 5)) -;; @result{} ((0 2) (0 4)) +;;(vector->array #(1 2 3 4) #() 2 2) +;; @result{} #2A((1 2) (3 4)) +;;(vector->array '#(3) '#()) +;; @result{} #0A 3 ;;@end example -(define array-shape array:shape) +(define (vector->array vect prototype . dimensions) + (define vdx (vector-length vect)) + (if (not (eqv? vdx (apply * dimensions))) + (slib:error 'vector->array vdx '<> (cons '* dimensions))) + (let ((ra (apply make-array prototype dimensions))) + (define (v2ra dims idxs) + (cond ((null? dims) + (set! vdx (+ -1 vdx)) + (apply array-set! ra (vector-ref vect vdx) (reverse idxs))) + (else + (do ((idx (+ -1 (car dims)) (+ -1 idx))) + ((negative? idx) vect) + (v2ra (cdr dims) (cons idx idxs)))))) + (v2ra dimensions '()) + ra)) -;;@body -;;@code{array-dimensions} is similar to @code{array-shape} but replaces -;;elements with a 0 minimum with one greater than the maximum. +;;@args array +;;Returns a new vector consisting of all the elements of @1 in +;;row-major order. ;; ;;@example -;;(array-dimensions (create-array '#() 3 5)) -;; @result{} (3 5) +;;(array->vector #2A ((1 2)( 3 4))) +;; @result{} #(1 2 3 4) +;;(array->vector #0A ho) +;; @result{} #(ho) ;;@end example -(define (array-dimensions array) - (map (lambda (bnd) (if (zero? (car bnd)) (+ 1 (cadr bnd)) bnd)) - (array:shape array))) +(define (array->vector ra) + (define dims (array-dimensions ra)) + (let* ((vdx (apply * dims)) + (vect (make-vector vdx))) + (define (ra2v dims idxs) + (if (null? dims) + (let ((val (apply array-ref ra (reverse idxs)))) + (set! vdx (+ -1 vdx)) + (vector-set! vect vdx val) + vect) + (do ((idx (+ -1 (car dims)) (+ -1 idx))) + ((negative? idx) vect) + (ra2v (cdr dims) (cons idx idxs))))) + (ra2v dims '()))) (define (array:in-bounds? array indices) - (do ((bnds (array:shape array) (cdr bnds)) + (do ((bnds (array:dimensions array) (cdr bnds)) (idxs indices (cdr idxs))) ((or (null? bnds) (null? idxs) (not (integer? (car idxs))) - (not (<= (caar bnds) (car idxs) (cadar bnds)))) + (not (< -1 (car idxs) (car bnds)))) (and (null? bnds) (null? idxs))))) -;;@args array index1 index2 @dots{} +;;@args array index1 @dots{} ;;Returns @code{#t} if its arguments would be acceptable to ;;@code{array-ref}. (define (array-in-bounds? array . indices) (array:in-bounds? array indices)) -;;@args array index1 index2 @dots{} -;;Returns the (@2, @3, @dots{}) element of @1. +;;@args array k1 @dots{} +;;Returns the (@2, @dots{}) element of @1. (define (array-ref array . indices) (define store (array:store array)) (or (array:in-bounds? array indices) @@ -322,8 +350,8 @@ ((if (string? store) string-ref vector-ref) store (apply + (array:offset array) (map * (array:scales array) indices)))) -;;@args array obj index1 index2 @dots{} -;;Stores @2 in the (@3, @4, @dots{}) element of @1. The value returned +;;@args array obj k1 @dots{} +;;Stores @2 in the (@3, @dots{}) element of @1. The value returned ;;by @0 is unspecified. (define (array-set! array obj . indices) (define store (array:store array)) @@ -333,10 +361,122 @@ store (apply + (array:offset array) (map * (array:scales array) indices)) obj)) -;;; Legacy functions +;;@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 an inexact 128.bit flonum complex uniform-array prototype. +(define A:floC128b (make-prototype-checker 'A:floC128b complex? vector)) +;;@args z +;;@args +;;Returns an inexact 64.bit flonum complex uniform-array prototype. +(define A:floC64b (make-prototype-checker 'A:floC64b complex? vector)) +;;@args z +;;@args +;;Returns an inexact 32.bit flonum complex uniform-array prototype. +(define A:floC32b (make-prototype-checker 'A:floC32b complex? vector)) +;;@args z +;;@args +;;Returns an inexact 16.bit flonum complex uniform-array prototype. +(define A:floC16b (make-prototype-checker 'A:floC16b complex? vector)) + +;;@args z +;;@args +;;Returns an inexact 128.bit flonum real uniform-array prototype. +(define A:floR128b (make-prototype-checker 'A:floR128b real? vector)) +;;@args z +;;@args +;;Returns an inexact 64.bit flonum real uniform-array prototype. +(define A:floR64b (make-prototype-checker 'A:floR64b real? vector)) +;;@args z +;;@args +;;Returns an inexact 32.bit flonum real uniform-array prototype. +(define A:floR32b (make-prototype-checker 'A:floR32b real? vector)) +;;@args z +;;@args +;;Returns an inexact 16.bit flonum real uniform-array prototype. +(define A:floR16b (make-prototype-checker 'A:floR16b real? vector)) + +;;@args z +;;@args +;;Returns an exact 128.bit decimal flonum rational uniform-array prototype. +(define A:floR128b (make-prototype-checker 'A:floR128b real? vector)) +;;@args z +;;@args +;;Returns an exact 64.bit decimal flonum rational uniform-array prototype. +(define A:floR64b (make-prototype-checker 'A:floR64b real? vector)) +;;@args z +;;@args +;;Returns an exact 32.bit decimal flonum rational uniform-array prototype. +(define A:floR32b (make-prototype-checker 'A:floR32b real? vector)) + +;;@args n +;;@args +;;Returns an exact binary fixnum uniform-array prototype with at least +;;64 bits of precision. +(define A:fixZ64b (make-prototype-checker 'A:fixZ64b (integer-bytes?? -8) vector)) +;;@args n +;;@args +;;Returns an exact binary fixnum uniform-array prototype with at least +;;32 bits of precision. +(define A:fixZ32b (make-prototype-checker 'A:fixZ32b (integer-bytes?? -4) vector)) +;;@args n +;;@args +;;Returns an exact binary fixnum uniform-array prototype with at least +;;16 bits of precision. +(define A:fixZ16b (make-prototype-checker 'A:fixZ16b (integer-bytes?? -2) vector)) +;;@args n +;;@args +;;Returns an exact binary fixnum uniform-array prototype with at least +;;8 bits of precision. +(define A:fixZ8b (make-prototype-checker 'A:fixZ8b (integer-bytes?? -1) vector)) + +;;@args k +;;@args +;;Returns an exact non-negative binary fixnum uniform-array prototype with at +;;least 64 bits of precision. +(define A:fixN64b (make-prototype-checker 'A:fixN64b (integer-bytes?? 8) vector)) +;;@args k +;;@args +;;Returns an exact non-negative binary fixnum uniform-array prototype with at +;;least 32 bits of precision. +(define A:fixN32b (make-prototype-checker 'A:fixN32b (integer-bytes?? 4) vector)) +;;@args k +;;@args +;;Returns an exact non-negative binary fixnum uniform-array prototype with at +;;least 16 bits of precision. +(define A:fixN16b (make-prototype-checker 'A:fixN16b (integer-bytes?? 2) vector)) +;;@args k +;;@args +;;Returns an exact non-negative binary fixnum uniform-array prototype with at +;;least 8 bits of precision. +(define A:fixN8b (make-prototype-checker 'A:fixN8b (integer-bytes?? 1) vector)) -;; ;;@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)) +;;@args bool +;;@args +;;Returns a boolean uniform-array prototype. +(define A:bool (make-prototype-checker 'A:bool boolean? vector)) |