Import Upstream version 3a2upstream/3a2

1 files changed, 43 insertions, 77 deletions

diff --git a/subarray.scm b/subarray.scm
index 69b18c4..152ccbb 100644
--- a/subarray.scm
+++ b/subarray.scm
@@ -65,64 +65,39 @@
                         (loop sels (cdr args) (cons (car args) lst))))
 		   ((number? (car sels))
 		    (loop (cdr sels) args (cons (car sels) lst)))
+		   ((list? (car sels))
+		    (loop (cdr sels)
+			  (cdr args)
+			  (cons (+ (car args) (caar sels)) lst)))
 		   (else
 		    (loop (cdr sels) (cdr args) (cons (car args) lst))))))
          (let loop ((sels selects)
-                    (shp (array-shape array))
-                    (nshp '()))
-           (cond ((null? shp)
+                    (dims (array-dimensions array))
+                    (ndims '()))
+           (cond ((null? dims)
                   (if (null? sels)
-                      (reverse nshp)
-                      (slib:error 'subarray 'rank (array-rank array) 'mismatch selects)))
+                      (reverse ndims)
+                      (slib:error
+		       'subarray 'rank (array-rank array) 'mismatch selects)))
                  ((null? sels)
-                  (loop sels (cdr shp) (cons (car shp) nshp)))
+                  (loop sels (cdr dims) (cons (car dims) ndims)))
+                 ((number? (car sels))
+                  (loop (cdr sels) (cdr dims) ndims))
                  ((not (car sels))
-                  (loop (cdr sels) (cdr shp) (cons (car shp) nshp)))
-                 ((integer? (car sels))
-                  (loop (cdr sels) (cdr shp) nshp))
+                  (loop (cdr sels) (cdr dims) (cons (car dims) ndims)))
+		 ((list? (car sels))
+		  (loop (cdr sels)
+			(cdr dims)
+			(cons (list 0 (- (cadar sels) (caar sels))) ndims)))
                  (else
-                  (loop (cdr sels) (cdr shp) (cons (car sels) nshp)))))))
+                  (loop (cdr sels) (cdr dims) (cons (car sels) ndims)))))))
 
 ;;@body
-;;Behaves like @r{subarray}, but @r{align}s the returned array origin to
-;;0 @dots{}.
-(define (subarray0 array . selects)
-  (define ra (apply subarray array selects))
-  (apply array-align ra (map (lambda (x) 0) (array-shape ra))))
+;;Legacy alias for @r{subarray}.
+(define subarray0 subarray)
 
 ;;@body
 ;;
-;;Returns an array shared with @1 but with a different origin.  The @2
-;;are the exact integer coordinates of the new origin.  Indexes
-;;corresponding to missing or #f coordinates are not realigned.
-;;
-;;For example:
-;;@example
-;;(define ra2 (create-array '#(5) '(5 9) '(-4 0)))
-;;(array-shape ra2)                       @result{} ((5 9) (-4 0))
-;;(array-shape (array-align ra2 0 0))     @result{} ((0 4) (0 4))
-;;(array-shape (array-align ra2 0))       @result{} ((0 4) (-4 0))
-;;(array-shape (array-align ra2))         @result{} ((5 9) (-4 0))
-;;(array-shape (array-align ra2 0 #f))    @result{} ((0 4) (-4 0))
-;;(array-shape (array-align ra2 #f 0))    @result{} ((5 9) (0 4))
-;;@end example
-(define (array-align array . coords)
-  (let* ((shape (array-shape array))
-	 (offs (let recur ((shp shape)
-			   (crd coords))
-		 (cond ((null? shp) '())
-		       ((null? crd) (map (lambda (x) 0) shp))
-		       ((not (car crd)) (cons 0 (recur (cdr shp) (cdr crd))))
-		       (else (cons (- (car crd) (caar shp))
-				   (recur (cdr shp) (cdr crd))))))))
-    (apply make-shared-array
-	   array (lambda inds (map - inds offs))
-	   (map (lambda (spec off)
-		  (list (+ (car spec) off) (+ (cadr spec) off)))
-		shape offs))))
-  
-;;@body
-;;
 ;;Returns a subarray sharing contents with @1 except for slices removed
 ;;from either side of each dimension.  Each of the @2 is an exact
 ;;integer indicating how much to trim.  A positive @var{s} trims the
@@ -132,41 +107,32 @@
 ;;
 ;;For example:
 ;;@example
-;;(array-trim '#(0 1 2 3 4) 1)  @result{} #1A(1 2 3 4) ;; shape is ((0 3))
-;;(array-trim '#(0 1 2 3 4) -1) @result{} #1A(0 1 2 3) ;; shape is ((1 4))
+;;(array-trim '#(0 1 2 3 4) 1)  @result{} #1A(1 2 3 4)
+;;(array-trim '#(0 1 2 3 4) -1) @result{} #1A(0 1 2 3)
 ;;
 ;;(require 'array-for-each)
 ;;(define (centered-difference ra)
-;;  (array-map - (array-trim ra 1) (array-trim ra -1)))
-;;(define (forward-difference ra)
-;;  (array-map - (array-trim ra 1) ra))
-;;(define (backward-difference ra)
-;;  (array-map - ra (array-trim ra -1)))
+;;  (array-map ra - (array-trim ra 1) (array-trim ra -1)))
 ;;
 ;;(centered-difference '#(0 1 3 5 9 22))
-;;  @result{} #1A(3 4 6 17) ;;shape is ((1 4))
-;;(backward-difference '#(0 1 3 5 9 22))
-;;  @result{} #1A(1 2 2 4 13) ;; shape is ((1 5))
-;;(forward-difference '#(0 1 3 5 9 22))
-;;  @result{} #(1 2 2 4 13)  ;; shape is ((0 4))
+;;  @result{} #(1 2 2 4 13)
 ;;@end example
 (define (array-trim array . trims)
-  (let* ((shape (array-shape array))
-	 (trims (let recur ((shp shape)
-			     (ss trims))
-		   (cond ((null? shp) '())
-			 ((null? ss) (map (lambda (x) 0) shp))
-			 ((integer? (car ss))
-			  (cons (car ss) (recur (cdr shp) (cdr ss))))
-			 (else
-			  (slib:error 'array-trim 'bad 'trim (car ss)))))))
-    (apply make-shared-array
-	   array
-	   (lambda inds (map + inds trims))
-	   (map (lambda (spec trim)
-		  (cond ((negative? trim)
-			 (cons (- (car spec) trim) (cdr spec)))
-			((positive? trim)
-			 (list (car spec) (- (cadr spec) trim)))
-			(else spec)))
-		shape trims))))
+  (define (loop dims trims shps)
+    (cond ((null? trims)
+	   (if (null? dims)
+	       (reverse shps)
+	       (loop (cdr dims)
+		     '()
+		     (cons (list 0 (+ -1 (car dims))) shps))))
+	  ((null? dims)
+	   (slib:error 'array-trim 'too 'many 'trims trims))
+	  ((negative? (car trims))
+	   (loop (cdr dims)
+		 (cdr trims)
+		 (cons (list 0 (+ (car trims) (car dims) -1)) shps)))
+	  (else
+	   (loop (cdr dims)
+		 (cdr trims)
+		 (cons (list (car trims) (+ -1 (car dims))) shps)))))
+  (apply subarray array (loop (array-dimensions array) trims '())))