diff options
author | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:28 -0800 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:28 -0800 |
commit | 87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (patch) | |
tree | 1eb4f87abd38bea56e08335d939e8171d5e7bfc7 /array.scm | |
parent | bd9733926076885e3417b74de76e4c9c7bc56254 (diff) | |
download | slib-upstream/2d2.tar.gz slib-upstream/2d2.zip |
Import Upstream version 2d2upstream/2d2
Diffstat (limited to 'array.scm')
-rw-r--r-- | array.scm | 471 |
1 files changed, 210 insertions, 261 deletions
@@ -1,279 +1,228 @@ ;;;;"array.scm" Arrays for Scheme -; Copyright (C) 1993 Alan Bawden +; Copyright (C) 2001 Aubrey Jaffer ; -; Permission to copy this software, to redistribute it, and to use it -; for any purpose is granted, subject to the following restrictions and -; understandings. +;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. +;1. Any copy made of this software must include this copyright notice +;in full. ; -; 2. Users of this software agree to make their best efforts (a) to -; return to me any improvements or extensions that they make, so that -; these may be included in future releases; and (b) to inform me of -; noteworthy uses of this software. +;2. I have made no warrantee 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. I have made no warrantee 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. -; -; 4. 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. -; -; Alan Bawden -; MIT Room NE43-510 -; 545 Tech. Sq. -; Cambridge, MA 02139 -; Alan@LCS.MIT.EDU +;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. -(require 'record) +;;@code{(require 'array)} +;;@ftindex array -;(declare (usual-integrations)) +(require 'record) (define array:rtd - (make-record-type "Array" - '(indexer ; Must be a -linear- function! - shape ; Inclusive bounds: ((lower upper) ...) - vector ; The actual contents - ))) - -(define array:indexer (record-accessor array:rtd 'indexer)) -(define array-shape (record-accessor array:rtd 'shape)) -(define array:vector (record-accessor array:rtd 'vector)) - -(define array? (record-predicate array:rtd)) + (make-record-type "array" + '(shape + scales ;list of dimension scales + offset ;exact integer + store ;data + ))) + +(define array:shape (record-accessor array:rtd 'shape)) + +(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 '(shape 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. Strings +;;and vectors 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 shape and the +;;corresponding elements of @1 and @2 are @code{equal?}. +;; +;;@example +;;(array=? (make-array 'foo 3 3) (make-array 'foo '(0 2) '(1 2))) +;; @result{} #t +;;@end example +(define (array=? array1 array2) + (and (equal? (array:shape array1) (array:shape array2)) + (equal? (array:store array1) (array:store array2)))) + +(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) + (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)))) + +;;@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 +;;(make-array 'foo 3 3) @equiv{} (make-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 +;;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 (array:dimensions->shape 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))) + (array:construct + shape + scales + (- (apply + (array:offset array) + (map * odl (apply mapper (map car shape)))) + (apply + (map * (map car shape) scales))) + (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)) -(define (array-dimensions ra) - (map (lambda (ind) (if (zero? (car ind)) (+ 1 (cadr ind)) ind)) - (array-shape ra))) - -(define array:construct - (record-constructor array:rtd '(shape vector indexer))) - -(define (array:compute-shape specs) - (map (lambda (spec) - (cond ((and (integer? spec) - (< 0 spec)) - (list 0 (- spec 1))) - ((and (pair? spec) - (pair? (cdr spec)) - (null? (cddr spec)) - (integer? (car spec)) - (integer? (cadr spec)) - (<= (car spec) (cadr spec))) - spec) - (else (slib:error "array: Bad array dimension: " spec)))) - specs)) - -(define (make-array initial-value . specs) - (let ((shape (array:compute-shape specs))) - (let loop ((size 1) - (indexer (lambda () 0)) - (l (reverse shape))) - (if (null? l) - (array:construct shape - (make-vector size initial-value) - (array:optimize-linear-function indexer shape)) - (loop (* size (+ 1 (- (cadar l) (caar l)))) - (lambda (first-index . rest-of-indices) - (+ (* size (- first-index (caar l))) - (apply indexer rest-of-indices))) - (cdr l)))))) - -(define (make-shared-array array mapping . specs) - (let ((new-shape (array:compute-shape specs)) - (old-indexer (array:indexer array))) - (let check ((indices '()) - (bounds (reverse new-shape))) - (cond ((null? bounds) - (array:check-bounds array (apply mapping indices))) - (else - (check (cons (caar bounds) indices) (cdr bounds)) - (check (cons (cadar bounds) indices) (cdr bounds))))) - (array:construct new-shape - (array:vector array) - (array:optimize-linear-function - (lambda indices - (apply old-indexer (apply mapping indices))) - new-shape)))) +;;@body +;;Returns a list of inclusive bounds. +;; +;;@example +;;(array-shape (make-array 'foo 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))))) + +;;@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)) +;; @result{} (3 5) +;;@end example +(define (array-dimensions array) + (map (lambda (bnd) (if (zero? (car bnd)) (+ 1 (cadr bnd)) bnd)) + (array-shape array))) (define (array:in-bounds? array indices) - (let loop ((indices indices) - (shape (array-shape array))) - (if (null? indices) - (null? shape) - (let ((index (car indices))) - (and (not (null? shape)) - (integer? index) - (<= (caar shape) index (cadar shape)) - (loop (cdr indices) (cdr shape))))))) - -(define (array:check-bounds array indices) - (or (array:in-bounds? array indices) - (slib:error "array: Bad indices for " array indices))) - -(define (array-ref array . indices) - (array:check-bounds array indices) - (vector-ref (array:vector array) - (apply (array:indexer array) indices))) - -(define (array-set! array new-value . indices) - (array:check-bounds array indices) - (vector-set! (array:vector array) - (apply (array:indexer array) indices) - new-value)) - + (do ((bnds (array:shape array) (cdr bnds)) + (idxs indices (cdr idxs))) + ((or (null? bnds) + (null? idxs) + (not (integer? (car idxs))) + (not (<= (caar bnds) (car idxs) (cadar bnds)))) + (and (null? bnds) (null? idxs))))) + +;;@args array index1 index2 @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)) -; Fast versions of ARRAY-REF and ARRAY-SET! that do no error checking, -; and don't cons intermediate lists of indices: - -(define (array-1d-ref a i0) - (vector-ref (array:vector a) ((array:indexer a) i0))) - -(define (array-2d-ref a i0 i1) - (vector-ref (array:vector a) ((array:indexer a) i0 i1))) - -(define (array-3d-ref a i0 i1 i2) - (vector-ref (array:vector a) ((array:indexer a) i0 i1 i2))) - -(define (array-1d-set! a v i0) - (vector-set! (array:vector a) ((array:indexer a) i0) v)) - -(define (array-2d-set! a v i0 i1) - (vector-set! (array:vector a) ((array:indexer a) i0 i1) v)) - -(define (array-3d-set! a v i0 i1 i2) - (vector-set! (array:vector a) ((array:indexer a) i0 i1 i2) v)) - -; STOP! Do not read beyond this point on your first reading of -; this code -- you should simply assume that the rest of this file -; contains only the following single definition: -; -; (define (array:optimize-linear-function f l) f) -; -; Of course everything would be pretty inefficient if this were really the -; case, but it isn't. The following code takes advantage of the fact that -; you can learn everything there is to know from a linear function by -; simply probing around in its domain and observing its values -- then a -; more efficient equivalent can be constructed. - -(define (array:optimize-linear-function f l) - (let ((d (length l))) - (cond - ((= d 0) - (array:0d-c (f))) - ((= d 1) - (let ((c (f 0))) - (array:1d-c0 c (- (f 1) c)))) - ((= d 2) - (let ((c (f 0 0))) - (array:2d-c01 c (- (f 1 0) c) (- (f 0 1) c)))) - ((= d 3) - (let ((c (f 0 0 0))) - (array:3d-c012 c (- (f 1 0 0) c) (- (f 0 1 0) c) (- (f 0 0 1) c)))) - (else - (let* ((v (map (lambda (x) 0) l)) - (c (apply f v))) - (let loop ((p v) - (old-val c) - (coefs '())) - (cond ((null? p) - (array:Nd-c* c (reverse coefs))) - (else - (set-car! p 1) - (let ((new-val (apply f v))) - (loop (cdr p) - new-val - (cons (- new-val old-val) coefs))))))))))) - -; 0D cases: - -(define (array:0d-c c) - (lambda () c)) - -; 1D cases: - -(define (array:1d-c c) - (lambda (i0) (+ c i0))) - -(define (array:1d-0 n0) - (cond ((= 1 n0) +) - (else (lambda (i0) (* n0 i0))))) - -(define (array:1d-c0 c n0) - (cond ((= 0 c) (array:1d-0 n0)) - ((= 1 n0) (array:1d-c c)) - (else (lambda (i0) (+ c (* n0 i0)))))) - -; 2D cases: - -(define (array:2d-0 n0) - (lambda (i0 i1) (+ (* n0 i0) i1))) - -(define (array:2d-1 n1) - (lambda (i0 i1) (+ i0 (* n1 i1)))) - -(define (array:2d-c0 c n0) - (lambda (i0 i1) (+ c (* n0 i0) i1))) - -(define (array:2d-c1 c n1) - (lambda (i0 i1) (+ c i0 (* n1 i1)))) - -(define (array:2d-01 n0 n1) - (cond ((= 1 n0) (array:2d-1 n1)) - ((= 1 n1) (array:2d-0 n0)) - (else (lambda (i0 i1) (+ (* n0 i0) (* n1 i1)))))) - -(define (array:2d-c01 c n0 n1) - (cond ((= 0 c) (array:2d-01 n0 n1)) - ((= 1 n0) (array:2d-c1 c n1)) - ((= 1 n1) (array:2d-c0 c n0)) - (else (lambda (i0 i1) (+ c (* n0 i0) (* n1 i1)))))) - -; 3D cases: - -(define (array:3d-01 n0 n1) - (lambda (i0 i1 i2) (+ (* n0 i0) (* n1 i1) i2))) - -(define (array:3d-02 n0 n2) - (lambda (i0 i1 i2) (+ (* n0 i0) i1 (* n2 i2)))) - -(define (array:3d-12 n1 n2) - (lambda (i0 i1 i2) (+ i0 (* n1 i1) (* n2 i2)))) - -(define (array:3d-c12 c n1 n2) - (lambda (i0 i1 i2) (+ c i0 (* n1 i1) (* n2 i2)))) - -(define (array:3d-c02 c n0 n2) - (lambda (i0 i1 i2) (+ c (* n0 i0) i1 (* n2 i2)))) - -(define (array:3d-c01 c n0 n1) - (lambda (i0 i1 i2) (+ c (* n0 i0) (* n1 i1) i2))) - -(define (array:3d-012 n0 n1 n2) - (cond ((= 1 n0) (array:3d-12 n1 n2)) - ((= 1 n1) (array:3d-02 n0 n2)) - ((= 1 n2) (array:3d-01 n0 n1)) - (else (lambda (i0 i1 i2) (+ (* n0 i0) (* n1 i1) (* n2 i2)))))) - -(define (array:3d-c012 c n0 n1 n2) - (cond ((= 0 c) (array:3d-012 n0 n1 n2)) - ((= 1 n0) (array:3d-c12 c n1 n2)) - ((= 1 n1) (array:3d-c02 c n0 n2)) - ((= 1 n2) (array:3d-c01 c n0 n1)) - (else (lambda (i0 i1 i2) (+ c (* n0 i0) (* n1 i1) (* n2 i2)))))) - -; ND cases: - -(define (array:Nd-* coefs) - (lambda indices (apply + (map * coefs indices)))) - -(define (array:Nd-c* c coefs) - (cond ((= 0 c) (array:Nd-* coefs)) - (else (lambda indices (apply + c (map * coefs indices)))))) +;;@args array index1 index2 @dots{} +;;Returns the (@2, @3, @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 index1 index2 @dots{} +;;Stores @2 in the (@3, @4, @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)) + +;;; 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!) |