;;;;"array.scm" Arrays for Scheme ; Copyright (C) 2001, 2003, 2005, 2006 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 ;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;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. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;;@code{(require 'array)} or @code{(require 'srfi-63)} ;;@ftindex array (require 'record) (define array:rtd (make-record-type "array" '(dimensions scales ;list of dimension scales offset ;exact integer store ;data ))) (define array:dimensions (let ((dimensions (record-accessor array:rtd 'dimensions))) (lambda (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))) (lambda (obj) (cond ((string? obj) '(1)) ((vector? obj) '(1)) (else (scales obj)))))) (define array:store (let ((store (record-accessor array:rtd 'store))) (lambda (obj) (cond ((string? obj) obj) ((vector? obj) obj) (else (store obj)))))) (define array:offset (let ((offset (record-accessor array:rtd 'offset))) (lambda (obj) (cond ((string? obj) 0) ((vector? obj) 0) (else (offset obj)))))) (define array:construct (record-constructor array:rtd '(dimensions scales offset store))) ;;@args obj ;;Returns @code{#t} if the @1 is an array, and @code{#f} if not. (define array? (let ((array:array? (record-predicate array:rtd))) (lambda (obj) (or (string? obj) (vector? obj) (array:array? obj))))) ;;@noindent ;;@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) ;; (and (array? obj) (not (string? obj)) (not (vector? obj)))) ;;@end example ;;@body ;;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 ;;(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 (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)))) ((and (string? obj1) (string? obj2)) (string=? obj1 obj2)) ((and (vector? obj1) (vector? obj2)) (and (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))))) ((and (array? obj1) (array? obj2)) (and (equal? (array:dimensions obj1) (array:dimensions obj2)) (letrec ((rascan (lambda (dims idxs) (if (null? dims) (equal? (apply array-ref obj1 idxs) (apply array-ref obj2 idxs)) (do ((res #t (rascan (cdr dims) (cons idx idxs))) (idx (+ -1 (car dims)) (+ -1 idx))) ((or (not res) (negative? idx)) res)))))) (rascan (reverse (array:dimensions obj1)) '())))) (else #f))) ;;@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 k1 @dots{} ;; ;;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 (make-array prototype . dimensions) (define prot (array:store prototype)) (define pdims (array:dimensions prototype)) (define onedim? (eqv? 1 (length dimensions))) (define tcnt (apply * dimensions)) (let ((initializer (if (zero? (apply * pdims)) '() (list (apply array-ref prototype (map (lambda (x) 0) pdims)))))) (cond ((and onedim? (string? prot)) (apply make-string (car dimensions) initializer)) ((and onedim? (vector? prot)) (apply make-vector (car dimensions) initializer)) (else (let ((store (if (string? prot) (apply make-string tcnt initializer) (apply make-vector tcnt initializer)))) (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 ;;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 freds-diagonal ;; (make-shared-array fred (lambda (i) (list i i)) 8)) ;;(array-set! freds-diagonal 'foo 3) ;;(array-ref fred 3 3) ;; @result{} FOO ;;(define freds-center ;; (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) ;; 2 2)) ;;(array-ref freds-center 0 0) ;; @result{} FOO ;;@end example (define (make-shared-array array mapper . dimensions) (define odl (array:scales array)) (define rank (length dimensions)) (define shape (map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dimensions)) (do ((idx (+ -1 rank) (+ -1 idx)) (uvt (if (zero? rank) '() (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))))) (array:construct (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)))))) ;;@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 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 ;;(vector->array #(1 2 3 4) #() 2 2) ;; @result{} #2A((1 2) (3 4)) ;;(vector->array '#(3) '#()) ;; @result{} #0A 3 ;;@end example (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)) ;;@args array ;;Returns a new vector consisting of all the elements of @1 in ;;row-major order. ;; ;;@example ;;(array->vector #2A ((1 2)( 3 4))) ;; @result{} #(1 2 3 4) ;;(array->vector #0A ho) ;; @result{} #(ho) ;;@end example (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)) (do ((idx (+ -1 (car dims)) (+ -1 idx))) ((negative? idx) vect) (ra2v (cdr dims) (cons idx idxs))))) (ra2v dims '()) vect)) (define (array:in-bounds? array indices) (do ((bnds (array:dimensions array) (cdr bnds)) (idxs indices (cdr idxs))) ((or (null? bnds) (null? idxs) (not (integer? (car idxs))) (not (< -1 (car idxs) (car bnds)))) (and (null? bnds) (null? idxs))))) ;;@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 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) (slib:error 'array-ref 'bad-indices indices)) ((if (string? store) string-ref vector-ref) store (apply + (array:offset array) (map * (array:scales array) indices)))) ;;@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)) (or (array:in-bounds? array indices) (slib:error 'array-set! 'bad-indices indices)) ((if (string? store) string-set! vector-set!) store (apply + (array:offset array) (map * (array:scales array) indices)) obj)) ;;@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)))))) ;;@defun A:floC128b z ;;@defunx A:floC128b ;;Returns an inexact 128.bit flonum complex uniform-array prototype. ;;@end defun (define A:floC128b (make-prototype-checker 'A:floC128b complex? vector)) ;;@defun A:floC64b z ;;@defunx A:floC64b ;;Returns an inexact 64.bit flonum complex uniform-array prototype. ;;@end defun (define A:floC64b (make-prototype-checker 'A:floC64b complex? vector)) ;;@defun A:floC32b z ;;@defunx A:floC32b ;;Returns an inexact 32.bit flonum complex uniform-array prototype. ;;@end defun (define A:floC32b (make-prototype-checker 'A:floC32b complex? vector)) ;;@defun A:floC16b z ;;@defunx A:floC16b ;;Returns an inexact 16.bit flonum complex uniform-array prototype. ;;@end defun (define A:floC16b (make-prototype-checker 'A:floC16b complex? vector)) ;;@defun A:floR128b x ;;@defunx A:floR128b ;;Returns an inexact 128.bit flonum real uniform-array prototype. ;;@end defun (define A:floR128b (make-prototype-checker 'A:floR128b real? vector)) ;;@defun A:floR64b x ;;@defunx A:floR64b ;;Returns an inexact 64.bit flonum real uniform-array prototype. ;;@end defun (define A:floR64b (make-prototype-checker 'A:floR64b real? vector)) ;;@defun A:floR32b x ;;@defunx A:floR32b ;;Returns an inexact 32.bit flonum real uniform-array prototype. ;;@end defun (define A:floR32b (make-prototype-checker 'A:floR32b real? vector)) ;;@defun A:floR16b x ;;@defunx A:floR16b ;;Returns an inexact 16.bit flonum real uniform-array prototype. ;;@end defun (define A:floR16b (make-prototype-checker 'A:floR16b real? vector)) ;;@defun A:floR128d q ;;@defunx A:floR128d ;;Returns an exact 128.bit decimal flonum rational uniform-array prototype. ;;@end defun (define A:floR128d (make-prototype-checker 'A:floR128d real? vector)) ;;@defun A:floR64d q ;;@defunx A:floR64d ;;Returns an exact 64.bit decimal flonum rational uniform-array prototype. ;;@end defun (define A:floR64d (make-prototype-checker 'A:floR64d real? vector)) ;;@defun A:floR32d q ;;@defunx A:floR32d ;;Returns an exact 32.bit decimal flonum rational uniform-array prototype. ;;@end defun (define A:floR32d (make-prototype-checker 'A:floR32d real? vector)) ;;@defun A:fixZ64b n ;;@defunx A:fixZ64b ;;Returns an exact binary fixnum uniform-array prototype with at least ;;64 bits of precision. ;;@end defun (define A:fixZ64b (make-prototype-checker 'A:fixZ64b (integer-bytes?? -8) vector)) ;;@defun A:fixZ32b n ;;@defunx A:fixZ32b ;;Returns an exact binary fixnum uniform-array prototype with at least ;;32 bits of precision. ;;@end defun (define A:fixZ32b (make-prototype-checker 'A:fixZ32b (integer-bytes?? -4) vector)) ;;@defun A:fixZ16b n ;;@defunx A:fixZ16b ;;Returns an exact binary fixnum uniform-array prototype with at least ;;16 bits of precision. ;;@end defun (define A:fixZ16b (make-prototype-checker 'A:fixZ16b (integer-bytes?? -2) vector)) ;;@defun A:fixZ8b n ;;@defunx A:fixZ8b ;;Returns an exact binary fixnum uniform-array prototype with at least ;;8 bits of precision. ;;@end defun (define A:fixZ8b (make-prototype-checker 'A:fixZ8b (integer-bytes?? -1) vector)) ;;@defun A:fixN64b k ;;@defunx A:fixN64b ;;Returns an exact non-negative binary fixnum uniform-array prototype with at ;;least 64 bits of precision. ;;@end defun (define A:fixN64b (make-prototype-checker 'A:fixN64b (integer-bytes?? 8) vector)) ;;@defun A:fixN32b k ;;@defunx A:fixN32b ;;Returns an exact non-negative binary fixnum uniform-array prototype with at ;;least 32 bits of precision. ;;@end defun (define A:fixN32b (make-prototype-checker 'A:fixN32b (integer-bytes?? 4) vector)) ;;@defun A:fixN16b k ;;@defunx A:fixN16b ;;Returns an exact non-negative binary fixnum uniform-array prototype with at ;;least 16 bits of precision. ;;@end defun (define A:fixN16b (make-prototype-checker 'A:fixN16b (integer-bytes?? 2) vector)) ;;@defun A:fixN8b k ;;@defunx A:fixN8b ;;Returns an exact non-negative binary fixnum uniform-array prototype with at ;;least 8 bits of precision. ;;@end defun (define A:fixN8b (make-prototype-checker 'A:fixN8b (integer-bytes?? 1) vector)) ;;@defun A:bool bool ;;@defunx A:bool ;;Returns a boolean uniform-array prototype. ;;@end defun (define A:bool (make-prototype-checker 'A:bool boolean? vector))