summaryrefslogtreecommitdiffstats
path: root/array.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
commit87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (patch)
tree1eb4f87abd38bea56e08335d939e8171d5e7bfc7 /array.scm
parentbd9733926076885e3417b74de76e4c9c7bc56254 (diff)
downloadslib-87b82b5822ca54228cfa6df29be3ad9d4bc47d16.tar.gz
slib-87b82b5822ca54228cfa6df29be3ad9d4bc47d16.zip
Import Upstream version 2d2upstream/2d2
Diffstat (limited to 'array.scm')
-rw-r--r--array.scm471
1 files changed, 210 insertions, 261 deletions
diff --git a/array.scm b/array.scm
index 08b8114..47df853 100644
--- a/array.scm
+++ b/array.scm
@@ -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!)