676 lines
20 KiB
Scheme
676 lines
20 KiB
Scheme
;; SRFI-25: Array implementation
|
||
;;; 1997 - 2001 Jussi Piitulainen
|
||
|
||
;;; --- Intro ---
|
||
|
||
;;; This interface to arrays is based on Alan Bawden's array.scm of
|
||
;;; 1993 (earlier version in the Internet Repository and another
|
||
;;; version in SLIB). This is a complete rewrite, to be consistent
|
||
;;; with the rest of Scheme and to make arrays independent of lists.
|
||
|
||
;;; Some modifications are due to discussion in srfi-25 mailing list.
|
||
|
||
;;; (array? obj)
|
||
;;; (make-array shape [obj]) changed arguments
|
||
;;; (shape bound ...) new
|
||
;;; (array shape obj ...) new
|
||
;;; (array-rank array) changed name back
|
||
;;; (array-start array dimension) new
|
||
;;; (array-end array dimension) new
|
||
;;; (array-ref array k ...)
|
||
;;; (array-ref array index) new variant
|
||
;;; (array-set! array k ... obj) changed argument order
|
||
;;; (array-set! array index obj) new variant
|
||
;;; (share-array array shape proc) changed arguments
|
||
|
||
;;; All other variables in this file have names in "array:".
|
||
|
||
;;; Should there be a way to make arrays with initial values mapped
|
||
;;; from indices? Sure. The current "initial object" is lame.
|
||
;;;
|
||
;;; Removed (array-shape array) from here. There is a new version
|
||
;;; in arlib though.
|
||
|
||
;;; --- Representation type dependencies ---
|
||
|
||
;;; The mapping from array indices to the index to the underlying vector
|
||
;;; is whatever array:optimize returns. The file "opt" provides three
|
||
;;; representations:
|
||
;;;
|
||
;;; mbda) mapping is a procedure that allows an optional argument
|
||
;;; tter) mapping is two procedures that takes exactly the indices
|
||
;;; ctor) mapping is a vector of a constant term and coefficients
|
||
;;;
|
||
;;; Choose one in "opt" to make the optimizer. Then choose the matching
|
||
;;; implementation of array-ref and array-set!.
|
||
;;;
|
||
;;; These should be made macros to inline them. Or have a good compiler
|
||
;;; and plant the package as a module.
|
||
|
||
;;; 1. Pick an optimizer.
|
||
;;; 2. Pick matching index representation.
|
||
;;; 3. Pick a record implementation; as-procedure is generic; syntax inlines.
|
||
;;; 3. This file is otherwise portable.
|
||
|
||
;;; --- Portable R5RS (R4RS and multiple values) ---
|
||
|
||
|
||
(module array mzscheme
|
||
(require srfi/9;; record-types
|
||
)
|
||
(provide array? make-array shape array array-rank
|
||
array-start array-end array-ref array-set! share-array
|
||
;; FIXME: should we export all these?
|
||
;; Array library: high level implementation of useful procedures
|
||
array-shape array-length array-size array-equal?
|
||
shape-for-each array-for-each-index
|
||
tabulate-array array-retabulate! array-map array-map!
|
||
array->vector share-array/prefix share-array/origin
|
||
array-append transpose share-nths)
|
||
;; As defined in as-srfi-9-record.scm in the reference implementation:
|
||
(define-record-type
|
||
array:srfi-9-record-type-descriptor
|
||
(array:make vec ind shp)
|
||
array:array?
|
||
(vec array:vector)
|
||
(ind array:index)
|
||
(shp array:shape))
|
||
|
||
;; Using SRFI-25 ctor based index representation
|
||
(require mzlib/include)
|
||
(include "ix-ctor.scm")
|
||
(include "op-ctor.scm")
|
||
|
||
;;; --- Portable R5RS (R4RS and multiple values) ---
|
||
|
||
;;; (array? obj)
|
||
;;; returns #t if `obj' is an array and #t or #f otherwise.
|
||
|
||
(define (array? obj)
|
||
(array:array? obj))
|
||
|
||
;;; (make-array shape)
|
||
;;; (make-array shape obj)
|
||
;;; makes array of `shape' with each cell containing `obj' initially.
|
||
|
||
(define (make-array shape . rest)
|
||
(or (array:good-shape? shape)
|
||
(error "make-array: shape is not a shape"))
|
||
(apply array:make-array shape rest))
|
||
|
||
(define (array:make-array shape . rest)
|
||
(let ((size (array:size shape)))
|
||
(array:make
|
||
(if (pair? rest)
|
||
(apply (lambda (o) (make-vector size o)) rest)
|
||
(make-vector size))
|
||
(if (= size 0)
|
||
(array:optimize-empty
|
||
(vector-ref (array:shape shape) 1))
|
||
(array:optimize
|
||
(array:make-index shape)
|
||
(vector-ref (array:shape shape) 1)))
|
||
(array:shape->vector shape))))
|
||
|
||
;;; (shape bound ...)
|
||
;;; makes a shape. Bounds must be an even number of exact, pairwise
|
||
;;; non-decreasing integers. Note that any such array can be a shape.
|
||
|
||
(define (shape . bounds)
|
||
(let ((v (list->vector bounds)))
|
||
(or (even? (vector-length v))
|
||
(error (string-append "shape: uneven number of bounds: "
|
||
(array:list->string bounds))))
|
||
(let ((shp (array:make
|
||
v
|
||
(if (pair? bounds)
|
||
(array:shape-index)
|
||
(array:empty-shape-index))
|
||
(vector 0 (quotient (vector-length v) 2)
|
||
0 2))))
|
||
(or (array:good-shape? shp)
|
||
(error (string-append "shape: bounds are not pairwise "
|
||
"non-decreasing exact integers: "
|
||
(array:list->string bounds))))
|
||
shp)))
|
||
|
||
;;; (array shape obj ...)
|
||
;;; is analogous to `vector'.
|
||
|
||
(define (array shape . elts)
|
||
(or (array:good-shape? shape)
|
||
(error (string-append "array: shape " (array:thing->string shape)
|
||
" is not a shape")))
|
||
(let ((size (array:size shape)))
|
||
(let ((vector (list->vector elts)))
|
||
(or (= (vector-length vector) size)
|
||
(error (string-append "array: an array of shape "
|
||
(array:shape-vector->string
|
||
(array:vector shape))
|
||
" has "
|
||
(number->string size)
|
||
" elements but got "
|
||
(number->string (vector-length vector))
|
||
" values: "
|
||
(array:list->string elts))))
|
||
(array:make
|
||
vector
|
||
(if (= size 0)
|
||
(array:optimize-empty
|
||
(vector-ref (array:shape shape) 1))
|
||
(array:optimize
|
||
(array:make-index shape)
|
||
(vector-ref (array:shape shape) 1)))
|
||
(array:shape->vector shape)))))
|
||
|
||
;;; (array-rank array)
|
||
;;; returns the number of dimensions of `array'.
|
||
|
||
(define (array-rank array)
|
||
(quotient (vector-length (array:shape array)) 2))
|
||
|
||
;;; (array-start array k)
|
||
;;; returns the lower bound index of array along dimension k. This is
|
||
;;; the least valid index along that dimension if the dimension is not
|
||
;;; empty.
|
||
|
||
(define (array-start array d)
|
||
(vector-ref (array:shape array) (+ d d)))
|
||
|
||
;;; (array-end array k)
|
||
;;; returns the upper bound index of array along dimension k. This is
|
||
;;; not a valid index. If the dimension is empty, this is the same as
|
||
;;; the lower bound along it.
|
||
|
||
(define (array-end array d)
|
||
(vector-ref (array:shape array) (+ d d 1)))
|
||
|
||
;;; (share-array array shape proc)
|
||
;;; makes an array that shares elements of `array' at shape `shape'.
|
||
;;; The arguments to `proc' are indices of the result. The values of
|
||
;;; `proc' are indices of `array'.
|
||
|
||
;;; Todo: in the error message, should recognise the mapping and show it.
|
||
|
||
(define (share-array array subshape f)
|
||
(or (array:good-shape? subshape)
|
||
(error (string-append "share-array: shape "
|
||
(array:thing->string subshape)
|
||
" is not a shape")))
|
||
(let ((subsize (array:size subshape)))
|
||
(or (array:good-share? subshape subsize f (array:shape array))
|
||
(error (string-append "share-array: subshape "
|
||
(array:shape-vector->string
|
||
(array:vector subshape))
|
||
" does not map into supershape "
|
||
(array:shape-vector->string
|
||
(array:shape array))
|
||
" under mapping "
|
||
(array:map->string
|
||
f
|
||
(vector-ref (array:shape subshape) 1)))))
|
||
(let ((g (array:index array)))
|
||
(array:make
|
||
(array:vector array)
|
||
(if (= subsize 0)
|
||
(array:optimize-empty
|
||
(vector-ref (array:shape subshape) 1))
|
||
(array:optimize
|
||
(lambda ks
|
||
(call-with-values
|
||
(lambda () (apply f ks))
|
||
(lambda ks (array:vector-index g ks))))
|
||
(vector-ref (array:shape subshape) 1)))
|
||
(array:shape->vector subshape)))))
|
||
|
||
;;; --- Hrmph ---
|
||
|
||
;;; (array:share/index! ...)
|
||
;;; reuses a user supplied index object when recognising the
|
||
;;; mapping. The mind balks at the very nasty side effect that
|
||
;;; exposes the implementation. So this is not in the spec.
|
||
;;; But letting index objects in at all creates a pressure
|
||
;;; to go the whole hog. Arf.
|
||
|
||
;;; Use array:optimize-empty for an empty array to get a
|
||
;;; clearly invalid vector index.
|
||
|
||
;;; Surely it's perverse to use an actor for index here? But
|
||
;;; the possibility is provided for completeness.
|
||
|
||
(define (array:share/index! array subshape proc index)
|
||
(array:make
|
||
(array:vector array)
|
||
(if (= (array:size subshape) 0)
|
||
(array:optimize-empty
|
||
(quotient (vector-length (array:shape array)) 2))
|
||
((if (vector? index)
|
||
array:optimize/vector
|
||
array:optimize/actor)
|
||
(lambda (subindex)
|
||
(let ((superindex (proc subindex)))
|
||
(if (vector? superindex)
|
||
(array:index/vector
|
||
(quotient (vector-length (array:shape array)) 2)
|
||
(array:index array)
|
||
superindex)
|
||
(array:index/array
|
||
(quotient (vector-length (array:shape array)) 2)
|
||
(array:index array)
|
||
(array:vector superindex)
|
||
(array:index superindex)))))
|
||
index))
|
||
(array:shape->vector subshape)))
|
||
|
||
(define (array:optimize/vector f v)
|
||
(let ((r (vector-length v)))
|
||
(do ((k 0 (+ k 1)))
|
||
((= k r))
|
||
(vector-set! v k 0))
|
||
(let ((n0 (f v))
|
||
(cs (make-vector (+ r 1)))
|
||
(apply (array:applier-to-vector (+ r 1))))
|
||
(vector-set! cs 0 n0)
|
||
(let wok ((k 0))
|
||
(if (< k r)
|
||
(let ((k1 (+ k 1)))
|
||
(vector-set! v k 1)
|
||
(let ((nk (- (f v) n0)))
|
||
(vector-set! v k 0)
|
||
(vector-set! cs k1 nk)
|
||
(wok k1)))))
|
||
(apply (array:maker r) cs))))
|
||
|
||
(define (array:optimize/actor f a)
|
||
(let ((r (array-end a 0))
|
||
(v (array:vector a))
|
||
(i (array:index a)))
|
||
(do ((k 0 (+ k 1)))
|
||
((= k r))
|
||
(vector-set! v (array:actor-index i k) 0))
|
||
(let ((n0 (f a))
|
||
(cs (make-vector (+ r 1)))
|
||
(apply (array:applier-to-vector (+ r 1))))
|
||
(vector-set! cs 0 n0)
|
||
(let wok ((k 0))
|
||
(if (< k r)
|
||
(let ((k1 (+ k 1))
|
||
(t (array:actor-index i k)))
|
||
(vector-set! v t 1)
|
||
(let ((nk (- (f a) n0)))
|
||
(vector-set! v t 0)
|
||
(vector-set! cs k1 nk)
|
||
(wok k1)))))
|
||
(apply (array:maker r) cs))))
|
||
|
||
;;; --- Internals ---
|
||
|
||
(define (array:shape->vector shape)
|
||
(let ((idx (array:index shape))
|
||
(shv (array:vector shape))
|
||
(rnk (vector-ref (array:shape shape) 1)))
|
||
(let ((vec (make-vector (* rnk 2))))
|
||
(do ((k 0 (+ k 1)))
|
||
((= k rnk)
|
||
vec)
|
||
(vector-set! vec (+ k k)
|
||
(vector-ref shv (array:shape-vector-index idx k 0)))
|
||
(vector-set! vec (+ k k 1)
|
||
(vector-ref shv (array:shape-vector-index idx k 1)))))))
|
||
|
||
;;; (array:size shape)
|
||
;;; returns the number of elements in arrays of shape `shape'.
|
||
|
||
(define (array:size shape)
|
||
(let ((idx (array:index shape))
|
||
(shv (array:vector shape))
|
||
(rnk (vector-ref (array:shape shape) 1)))
|
||
(do ((k 0 (+ k 1))
|
||
(s 1 (* s
|
||
(- (vector-ref shv (array:shape-vector-index idx k 1))
|
||
(vector-ref shv (array:shape-vector-index idx k 0))))))
|
||
((= k rnk) s))))
|
||
|
||
;;; (array:make-index shape)
|
||
;;; returns an index function for arrays of shape `shape'. This is a
|
||
;;; runtime composition of several variable arity procedures, to be
|
||
;;; passed to array:optimize for recognition as an affine function of
|
||
;;; as many variables as there are dimensions in arrays of this shape.
|
||
|
||
(define (array:make-index shape)
|
||
(let ((idx (array:index shape))
|
||
(shv (array:vector shape))
|
||
(rnk (vector-ref (array:shape shape) 1)))
|
||
(do ((f (lambda () 0)
|
||
(lambda (k . ks)
|
||
(+ (* s (- k (vector-ref
|
||
shv
|
||
(array:shape-vector-index idx (- j 1) 0))))
|
||
(apply f ks))))
|
||
(s 1 (* s (- (vector-ref
|
||
shv
|
||
(array:shape-vector-index idx (- j 1) 1))
|
||
(vector-ref
|
||
shv
|
||
(array:shape-vector-index idx (- j 1) 0)))))
|
||
(j rnk (- j 1)))
|
||
((= j 0)
|
||
f))))
|
||
|
||
|
||
;;; --- Error checking ---
|
||
|
||
;;; (array:good-shape? shape)
|
||
;;; returns true if `shape' is an array of the right shape and its
|
||
;;; elements are exact integers that pairwise bound intervals `[lo..hi)<29>.
|
||
|
||
(define (array:good-shape? shape)
|
||
(and (array:array? shape)
|
||
(let ((u (array:shape shape))
|
||
(v (array:vector shape))
|
||
(x (array:index shape)))
|
||
(and (= (vector-length u) 4)
|
||
(= (vector-ref u 0) 0)
|
||
(= (vector-ref u 2) 0)
|
||
(= (vector-ref u 3) 2))
|
||
(let ((p (vector-ref u 1)))
|
||
(do ((k 0 (+ k 1))
|
||
(true #t (let ((lo (vector-ref
|
||
v
|
||
(array:shape-vector-index x k 0)))
|
||
(hi (vector-ref
|
||
v
|
||
(array:shape-vector-index x k 1))))
|
||
(and true
|
||
(integer? lo)
|
||
(exact? lo)
|
||
(integer? hi)
|
||
(exact? hi)
|
||
(<= lo hi)))))
|
||
((= k p) true))))))
|
||
|
||
;;; (array:good-share? subv subsize mapping superv)
|
||
;;; returns true if the extreme indices in the subshape vector map
|
||
;;; into the bounds in the supershape vector.
|
||
|
||
;;; If some interval in `subv' is empty, then `subv' is empty and its
|
||
;;; image under `f' is empty and it is trivially alright. One must
|
||
;;; not call `f', though.
|
||
|
||
(define (array:good-share? subshape subsize f super)
|
||
(or (zero? subsize)
|
||
(letrec
|
||
((sub (array:vector subshape))
|
||
(dex (array:index subshape))
|
||
(ck (lambda (k ks)
|
||
(if (zero? k)
|
||
(call-with-values
|
||
(lambda () (apply f ks))
|
||
(lambda qs (array:good-indices? qs super)))
|
||
(and (ck (- k 1)
|
||
(cons (vector-ref
|
||
sub
|
||
(array:shape-vector-index
|
||
dex
|
||
(- k 1)
|
||
0))
|
||
ks))
|
||
(ck (- k 1)
|
||
(cons (- (vector-ref
|
||
sub
|
||
(array:shape-vector-index
|
||
dex
|
||
(- k 1)
|
||
1))
|
||
1)
|
||
ks)))))))
|
||
(let ((rnk (vector-ref (array:shape subshape) 1)))
|
||
(or (array:unchecked-share-depth? rnk)
|
||
(ck rnk '()))))))
|
||
|
||
;;; Check good-share on 10 dimensions at most. The trouble is,
|
||
;;; the cost of this check is exponential in the number of dimensions.
|
||
|
||
(define (array:unchecked-share-depth? rank)
|
||
(if (> rank 10)
|
||
(begin
|
||
(display `(warning: unchecked depth in share:
|
||
,rank subdimensions))
|
||
(newline)
|
||
#t)
|
||
#f))
|
||
|
||
;;; (array:check-indices caller indices shape-vector)
|
||
;;; (array:check-indices.o caller indices shape-vector)
|
||
;;; (array:check-index-vector caller index-vector shape-vector)
|
||
;;; return if the index is in bounds, else signal error.
|
||
;;;
|
||
;;; Shape-vector is the internal representation, with
|
||
;;; b and e for dimension k at 2k and 2k + 1.
|
||
|
||
(define (array:check-indices who ks shv)
|
||
(or (array:good-indices? ks shv)
|
||
(error (array:not-in who ks shv))))
|
||
|
||
(define (array:check-indices.o who ks shv)
|
||
(or (array:good-indices.o? ks shv)
|
||
(error (array:not-in who (reverse (cdr (reverse ks))) shv))))
|
||
|
||
(define (array:check-index-vector who ks shv)
|
||
(or (array:good-index-vector? ks shv)
|
||
(error (array:not-in who (vector->list ks) shv))))
|
||
|
||
(define (array:check-index-actor who ks shv)
|
||
(let ((shape (array:shape ks)))
|
||
(or (and (= (vector-length shape) 2)
|
||
(= (vector-ref shape 0) 0))
|
||
(error "not an actor"))
|
||
(or (array:good-index-actor?
|
||
(vector-ref shape 1)
|
||
(array:vector ks)
|
||
(array:index ks)
|
||
shv)
|
||
(array:not-in who (do ((k (vector-ref shape 1) (- k 1))
|
||
(m '() (cons (vector-ref
|
||
(array:vector ks)
|
||
(array:actor-index
|
||
(array:index ks)
|
||
(- k 1)))
|
||
m)))
|
||
((= k 0) m))
|
||
shv))))
|
||
|
||
(define (array:good-indices? ks shv)
|
||
(let ((d2 (vector-length shv)))
|
||
(do ((kp ks (if (pair? kp)
|
||
(cdr kp)))
|
||
(k 0 (+ k 2))
|
||
(true #t (and true (pair? kp)
|
||
(array:good-index? (car kp) shv k))))
|
||
((= k d2)
|
||
(and true (null? kp))))))
|
||
|
||
(define (array:good-indices.o? ks.o shv)
|
||
(let ((d2 (vector-length shv)))
|
||
(do ((kp ks.o (if (pair? kp)
|
||
(cdr kp)))
|
||
(k 0 (+ k 2))
|
||
(true #t (and true (pair? kp)
|
||
(array:good-index? (car kp) shv k))))
|
||
((= k d2)
|
||
(and true (pair? kp) (null? (cdr kp)))))))
|
||
|
||
(define (array:good-index-vector? ks shv)
|
||
(let ((r2 (vector-length shv)))
|
||
(and (= (* 2 (vector-length ks)) r2)
|
||
(do ((j 0 (+ j 1))
|
||
(k 0 (+ k 2))
|
||
(true #t (and true
|
||
(array:good-index? (vector-ref ks j) shv k))))
|
||
((= k r2) true)))))
|
||
|
||
(define (array:good-index-actor? r v i shv)
|
||
(and (= (* 2 r) (vector-length shv))
|
||
(do ((j 0 (+ j 1))
|
||
(k 0 (+ k 2))
|
||
(true #t (and true
|
||
(array:good-index? (vector-ref
|
||
v
|
||
(array:actor-index i j))
|
||
shv
|
||
k))))
|
||
((= j r) true))))
|
||
|
||
;;; (array:good-index? index shape-vector 2d)
|
||
;;; returns true if index is within bounds for dimension 2d/2.
|
||
|
||
(define (array:good-index? w shv k)
|
||
(and (integer? w)
|
||
(exact? w)
|
||
(<= (vector-ref shv k) w)
|
||
(< w (vector-ref shv (+ k 1)))))
|
||
|
||
(define (array:not-in who ks shv)
|
||
(let ((index (array:list->string ks))
|
||
(bounds (array:shape-vector->string shv)))
|
||
(error (string-append who
|
||
": index " index
|
||
" not in bounds " bounds))))
|
||
|
||
(define (array:list->string ks)
|
||
(do ((index "" (string-append index (array:thing->string (car ks)) " "))
|
||
(ks ks (cdr ks)))
|
||
((null? ks) index)))
|
||
|
||
(define (array:shape-vector->string shv)
|
||
(do ((bounds "" (string-append bounds
|
||
"["
|
||
(number->string (vector-ref shv t))
|
||
".."
|
||
(number->string (vector-ref shv (+ t 1)))
|
||
")"
|
||
" "))
|
||
(t 0 (+ t 2)))
|
||
((= t (vector-length shv)) bounds)))
|
||
|
||
(define (array:thing->string thing)
|
||
(cond
|
||
((number? thing) (number->string thing))
|
||
((symbol? thing) (string-append "#<symbol>" (symbol->string thing)))
|
||
((char? thing) "#<char>")
|
||
((string? thing) "#<string>")
|
||
((list? thing) (string-append "#" (number->string (length thing))
|
||
"<list>"))
|
||
|
||
((pair? thing) "#<pair>")
|
||
((array? thing) "#<array>")
|
||
((vector? thing) (string-append "#" (number->string
|
||
(vector-length thing))
|
||
"<vector>"))
|
||
((procedure? thing) "#<procedure>")
|
||
(else
|
||
(case thing
|
||
((()) "()")
|
||
((#t) "#t")
|
||
((#f) "#f")
|
||
(else
|
||
"#<whatsit>")))))
|
||
|
||
;;; And to grok an affine map, vector->vector type. Column k of arr
|
||
;;; will contain coefficients n0 ... nm of 1 k1 ... km for kth value.
|
||
;;;
|
||
;;; These are for the error message when share fails.
|
||
|
||
(define (array:index-ref ind k)
|
||
(if (vector? ind)
|
||
(vector-ref ind k)
|
||
(vector-ref
|
||
(array:vector ind)
|
||
(array:actor-index (array:index ind) k))))
|
||
|
||
(define (array:index-set! ind k o)
|
||
(if (vector? ind)
|
||
(vector-set! ind k o)
|
||
(vector-set!
|
||
(array:vector ind)
|
||
(array:actor-index (array:index ind) k)
|
||
o)))
|
||
|
||
(define (array:index-length ind)
|
||
(if (vector? ind)
|
||
(vector-length ind)
|
||
(vector-ref (array:shape ind) 1)))
|
||
|
||
(define (array:map->string proc r)
|
||
(let* ((m (array:grok/arguments proc r))
|
||
(s (vector-ref (array:shape m) 3)))
|
||
(do ((i "" (string-append i c "k" (number->string k)))
|
||
(c "" ", ")
|
||
(k 1 (+ k 1)))
|
||
((< r k)
|
||
(do ((o "" (string-append o c (array:map-column->string m r k)))
|
||
(c "" ", ")
|
||
(k 0 (+ k 1)))
|
||
((= k s)
|
||
(string-append i " => " o)))))))
|
||
|
||
(define (array:map-column->string m r k)
|
||
(let ((v (array:vector m))
|
||
(i (array:index m)))
|
||
(let ((n0 (vector-ref v (array:vector-index i (list 0 k)))))
|
||
(let wok ((j 1)
|
||
(e (if (= n0 0) "" (number->string n0))))
|
||
(if (<= j r)
|
||
(let ((nj (vector-ref v (array:vector-index i (list j k)))))
|
||
(if (= nj 0)
|
||
(wok (+ j 1) e)
|
||
(let* ((nj (if (= nj 1) ""
|
||
(if (= nj -1) "-"
|
||
(string-append (number->string nj)
|
||
" "))))
|
||
(njkj (string-append nj "k" (number->string j))))
|
||
(if (string=? e "")
|
||
(wok (+ j 1) njkj)
|
||
(wok (+ j 1) (string-append e " + " njkj))))))
|
||
(if (string=? e "") "0" e))))))
|
||
|
||
(define (array:grok/arguments proc r)
|
||
(array:grok/index!
|
||
(lambda (vec)
|
||
(call-with-values
|
||
(lambda ()
|
||
(array:apply-to-vector r proc vec))
|
||
vector))
|
||
(make-vector r)))
|
||
|
||
(define (array:grok/index! proc in)
|
||
(let ((m (array:index-length in)))
|
||
(do ((k 0 (+ k 1)))
|
||
((= k m))
|
||
(array:index-set! in k 0))
|
||
(let* ((n0 (proc in))
|
||
(n (array:index-length n0)))
|
||
(let ((arr (make-array (shape 0 (+ m 1) 0 n)))) ; (*)
|
||
(do ((k 0 (+ k 1)))
|
||
((= k n))
|
||
(array-set! arr 0 k (array:index-ref n0 k))) ; (**)
|
||
(do ((j 0 (+ j 1)))
|
||
((= j m))
|
||
(array:index-set! in j 1)
|
||
(let ((nj (proc in)))
|
||
(array:index-set! in j 0)
|
||
(do ((k 0 (+ k 1)))
|
||
((= k n))
|
||
(array-set! arr (+ j 1) k (- (array:index-ref nj k) ; (**)
|
||
(array:index-ref n0 k))))))
|
||
arr))))
|
||
;; (*) Should not use `make-array' and `shape' here
|
||
;; (**) Should not use `array-set!' here
|
||
;; Should use something internal to the library instead: either lower
|
||
;; level code (preferable but complex) or alternative names to these same.
|
||
|
||
;; The array library:
|
||
(include "arlib.scm")
|
||
|
||
)
|