diff options
Diffstat (limited to 'array.scm')
| -rw-r--r-- | array.scm | 81 |
1 files changed, 47 insertions, 34 deletions
@@ -1,5 +1,5 @@ ;;;;"array.scm" Arrays for Scheme -; Copyright (C) 2001, 2003, 2005 Aubrey Jaffer +; 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 @@ -110,21 +110,26 @@ (and (pair? obj1) (pair? obj2) (equal? (car obj1) (car obj2)) (equal? (cdr obj1) (cdr obj2)))) - ((or (string? obj1) (string? obj2)) - (and (string? obj1) (string? obj2) - (string=? obj1 obj2))) - ((or (vector? obj1) (vector? obj2)) - (and (vector? obj1) (vector? obj2) - (equal? (vector-length obj1) (vector-length 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))))) - ((or (array? obj1) (array? obj2)) - (and (array? obj1) (array? obj2) - (equal? (array:dimensions obj1) (array:dimensions obj2)) - (equal? (array:store obj1) (array:store obj2)))) + ((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 @@ -155,24 +160,30 @@ ;;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 ((store - (if (string? prototype) - (case (string-length prototype) - ((0) (make-string tcnt)) - (else (make-string tcnt - (string-ref prototype 0)))) - (let ((pdims (array:dimensions prototype))) - (case (apply * pdims) - ((0) (make-vector tcnt)) - (else (make-vector tcnt - (apply array-ref prototype - (map (lambda (x) 0) pdims))))))))) - (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)))) + (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) @@ -203,7 +214,9 @@ (define shape (map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dimensions)) (do ((idx (+ -1 rank) (+ -1 idx)) - (uvt (append (cdr (vector->list (make-vector rank 0))) '(1)) + (uvt (if (zero? rank) + '() + (append (cdr (vector->list (make-vector rank 0))) '(1))) (append (cdr uvt) '(0))) (uvts '() (cons uvt uvts))) ((negative? idx) @@ -269,7 +282,7 @@ (do ((lst '() (cons (ra2l (cdr dims) (cons idx idxs)) lst)) (idx (+ -1 (car dims)) (+ -1 idx))) ((negative? idx) lst)))) - (ra2l (array-dimensions ra) '())) + (ra2l (array:dimensions ra) '())) ;;@args vect proto dim1 @dots{} ;;@1 must be a vector of length equal to the product of exact @@ -312,19 +325,19 @@ ;; @result{} #(ho) ;;@end example (define (array->vector ra) - (define dims (array-dimensions 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) - vect) + (vector-set! vect vdx val)) (do ((idx (+ -1 (car dims)) (+ -1 idx))) ((negative? idx) vect) (ra2v (cdr dims) (cons idx idxs))))) - (ra2v dims '()))) + (ra2v dims '()) + vect)) (define (array:in-bounds? array indices) (do ((bnds (array:dimensions array) (cdr bnds)) |