http://t3x.org/s9fes/array.scm.html

# Array type and operations

Location: lib, 136 Lines

```; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2010,2012
; Placed in the Public Domain
;
; (make-array integer ...)                           ==>  array
; (array object ...)                                 ==>  array
; (array? object)                                    ==>  boolean
; (array-dimensions array)                           ==>  list
; (array-map procedure array ...)                    ==>  array
; (array-rank array)                                 ==>  integer
; (array-ref array integer ...)                      ==>  object
; (array-set! array integer ... object)              ==>  unspecific
; (subarray array (list integer1,1 integer1,2) ...)  ==>  array
;
;
; MAKE-ARRAY creates a new array whose rank (number of dimensions)
; equals the number of integers specified. Each integer specifies
; the size of one dimension, e.g.: (make-array 2 3 4) creates an
; array with two elements in the first dimensions, three in the
; second and four in the third.
;
; ARRAY creates a fresh array of rank one and stores the given
; elements in it. Arrays of higher rank can be created by nesting
; applications of ARRAY.
;
; (Array? x) returns #T if X is an array and otherwise #F. The array
; is a subtype of the vector, so (vector? x) follows from (array? x).
;
; ARRAY-DIMENIONS returns a list of the dimensions of the given
; ARRAY. For a zero-dimensional array it returns ().
;
; ARRAY-MAP maps a procedure over the elements of the given arrays.
; The arity of PROCEDURE must match the number of ARRAYs. ARRAY-MAP
; returns a new array in which the elements of the input arrays have
; been tuple-wise combined with PROCEDURE, e.g.:
;
; (new1,1 ... new1,N  =  ((P a1,1,1 ... aK,1,1) ... (P a1,1,N aK,1,N)
;  ...                    ...
;  newM,1 ... newM,N)     (P a1,M,1 ... aK,M,1) ... (P a1,M,N aK,M,N))
;
; where K is the number of arrays, P is the procedure, M is the number
; of rows and N is the number of columns of a matrix. When more than
; two dimensions are involved the number of parameters grows accordingly.
;
; ARRAY-RANK returns the number of dimensions of the given ARRAY.
; Note that a one-dimensional array with one element has a rank
; of 0.
;
; (Array-ref a i1 ... iN) returns element <i1,...,iN> of the array A.
; N must be equal to the rank of A.
;
; (Array-set! a i1 ... iN v) sets element <i1,...,iN> of the array A
; to the value V. N must be equal to the rank of A.
;
; SUBARRAY creates a fresh array with the same rank as the given ARRAY
; and copies the specified elements to the new array. Each INTEGER1
; specifies the first element to copy from the corresponding dimension
; and INTEGER2 specifies the first element not to copy. The dimensions
; of the new array are
; (INTEGER1,2)-(INTEGER1,1) ... (INTEGERn,2)-(INTEGERn,1)
; where N is the rank of the array.
;
; Example:   (let ((a (make-array 3 3 3)))
;              (array-set! a 1 1 1 'foo)
;              (array-ref a 1 1 1))            ==>  foo
;
;            (let ((a (array (array 1 2 3 4)
;                            (array 3 4 5 6)
;                            (array 5 6 7 8))))
;              (list (array-rank a)
;                    (array-dimensions a)))    ==>  (2 (3 4))

(define *array-type-tag* (list 'array))

(define (make-array . dim*)
(if (null? dim*)
(vector *array-type-tag* #f)
(let make ((dim* dim*))
(let ((subvec (make-vector (+ 1 (car dim*)))))
(vector-set! subvec 0 *array-type-tag*)
(if (not (null? (cdr dim*)))
(vector-map! (lambda (x)
(if (not (eq? x *array-type-tag*))
(make (cdr dim*))
x))
subvec))
subvec))))

(define (array? x)
(and (vector? x)
(positive? (vector-length x))
(eq? *array-type-tag* (vector-ref x 0))))

(define (array-ref a . indexes)
(if (not (array? a))
(error "array-ref: expected array, got" a)
(let aref ((a  a)
(i* indexes))
(if (null? i*)
(if (array? a)
(error "array-ref: too few indexes" indexes)
a)
(if (array? a)
(if (< (+ 1 (car i*)) (vector-length a))
(aref (vector-ref a (+ 1 (car i*)))
(cdr i*))
(error "array-ref: index out of range" (car i*)))
(error "array-ref: too many indexes" indexes))))))

(define (array-set! a . indexes+val)
(if (not (array? a))
(error "array-set!: expected array, got" a))
(if (< (length indexes+val) 2)
(error "array-set!: missing indexes"))
(let* ((x    (reverse indexes+val))
(val  (car x))
(ind* (reverse (cdr x))))
(let aset ((a  a)
(i* ind*))
(if (null? (cdr i*))
(if (array? a)
(if (< (+ 1 (car i*)) (vector-length a))
(if (array? (vector-ref a (+ 1 (car i*))))
(error "array-set!: too few indexes" ind*)
(vector-set! a (+ 1 (car i*)) val))
(error "array-set!: index out of range" (car i*)))
(error "array-set!: too many indexes" ind*))
(if (array? a)
(if (< (+ 1 (car i*)) (vector-length a))
(aset (vector-ref a (+ 1 (car i*))) (cdr i*))
(error "array-set!: index out of range" (car i*)))
(error "array-set!: too many indexes" ind*))))))

(define (array . v)
(list->vector (cons *array-type-tag* v)))

(define (subarray ar . co*)
(if (not (array? ar))
(error "subarray: expected array, got" ar)
(let asub ((a   ar)
(co* co*))
(if (null? co*)
(if (array? a)
(error "subarray: too few indexes" ar)
a)
(if (array? a)
(if (or (not (list? (car co*)))
(not (= 2 (length (car co*))))
(not (integer? (caar co*)))
(error "subarray: invalid coordinate" (car co*))
(let ((x0 (+ 1 (caar co*)))
(if (<= 1 x0 xn (vector-length a))
(let ((v (subvector a x0 xn)))
(vector-map! (lambda (sa)
(asub sa (cdr co*)))
v)
(apply array (vector->list v)))
(error "subarray: invalid range" (car co*)))))
(error "subarray: too many indexes" ar))))))

(define (array-rank a)
(cond ((not (array? a))
(error "array-rank: expected array, got" a))
((and (= 2 (vector-length a))
(not (array? (vector-ref a 1))))
0)
(else
(let loop ((a a)
(n 0))
(if (and (array? a)
(> (vector-length a) 1))
(loop (vector-ref a 1)
(+ 1 n))
n)))))

(define (array-dimensions a)
(cond ((not (array? a))
(error "array-dimensions: expected array, got" a))
((and (= 2 (vector-length a))
(not (array? (vector-ref a 1))))
'())
(else
(let loop ((a  a)
(d* '()))
(let ((k (and (array? a)
(- (vector-length a) 1))))
(if (and (array? a)
(positive? k))
(loop (vector-ref a 1) (cons k d*))
(reverse! d*)))))))

(define (array-map f . a*)
(cond ((for-all array? a*)
(apply array (map (lambda (x)
(apply array-map f x))
(transpose
(map (compose cdr vector->list)
a*)))))
(else
(apply f a*))))
```