summaryrefslogtreecommitdiffstats
path: root/array.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:36 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:36 -0800
commit5bea21e81ed516440e34e480f2c33ca41aa8c597 (patch)
tree653ace1b8fe0a9916d861d35ff8f611b46c80d37 /array.scm
parent237c6e380aebdcbc70bd1c9ecf7d3f6effca2752 (diff)
downloadslib-5bea21e81ed516440e34e480f2c33ca41aa8c597.tar.gz
slib-5bea21e81ed516440e34e480f2c33ca41aa8c597.zip
Import Upstream version 3a4upstream/3a4
Diffstat (limited to 'array.scm')
-rw-r--r--array.scm81
1 files changed, 47 insertions, 34 deletions
diff --git a/array.scm b/array.scm
index 5f87b98..ff05fd0 100644
--- a/array.scm
+++ b/array.scm
@@ -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))