Import Upstream version 3a1upstream/3a1

1 files changed, 172 insertions, 0 deletions

diff --git a/subarray.scm b/subarray.scm
new file mode 100644
index 0000000..69b18c4
--- /dev/null
+++ b/subarray.scm
@@ -0,0 +1,172 @@
+;;;;"subarray.scm" Scheme array accessory procedures.
+; Copyright (C) 2002 Aubrey Jaffer and Radey Shouman
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1.  Any copy made of this software must include this copyright notice
+;in full.
+;
+;2.  I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3.  In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'array)
+
+;;@code{(require 'subarray)}
+;;@ftindex subarray
+
+;;@body
+;;selects a subset of an array.  For @1 of rank n, there must be at least
+;;n @2 arguments.  For 0 <= @i{j} < n, @2@i{j} is either an integer, a
+;;list of two integers within the range for the @i{j}th index, or #f.
+;;
+;;When @2@i{j} is a list of two integers, then the @i{j}th index is
+;;restricted to that subrange in the returned array.
+;;
+;;When @2@i{j} is #f, then the full range of the @i{j}th index is
+;;accessible in the returned array.  An elided argument is equivalent to #f.
+;;
+;;When @2@i{j} is an integer, then the rank of the returned array is
+;;less than @1, and only elements whose @i{j}th index equals @2@i{j} are
+;;shared.
+;;
+;;@example
+;;> (define ra '#2A((a b c) (d e f)))
+;;#<unspecified>
+;;> (subarray ra 0 #f)
+;;#1A(a b c)
+;;> (subarray ra 1 #f)
+;;#1A(d e f)
+;;> (subarray ra #f 1)
+;;#1A(b e)
+;;> (subarray ra '(0 1) #f)
+;;#2A((a b c) (d e f))
+;;> (subarray ra #f '(0 1))
+;;#2A((a b) (d e))
+;;> (subarray ra #f '(1 2))
+;;#2A((b c) (e f))
+;;@end example
+(define (subarray array . selects)
+  (apply make-shared-array array
+	 (lambda args
+	   (let loop ((sels selects)
+		      (args args)
+		      (lst '()))
+	     (cond ((null? sels)
+                    (if (null? args)
+                        (reverse lst)
+                        (loop sels (cdr args) (cons (car args) lst))))
+		   ((number? (car sels))
+		    (loop (cdr sels) args (cons (car sels) lst)))
+		   (else
+		    (loop (cdr sels) (cdr args) (cons (car args) lst))))))
+         (let loop ((sels selects)
+                    (shp (array-shape array))
+                    (nshp '()))
+           (cond ((null? shp)
+                  (if (null? sels)
+                      (reverse nshp)
+                      (slib:error 'subarray 'rank (array-rank array) 'mismatch selects)))
+                 ((null? sels)
+                  (loop sels (cdr shp) (cons (car shp) nshp)))
+                 ((not (car sels))
+                  (loop (cdr sels) (cdr shp) (cons (car shp) nshp)))
+                 ((integer? (car sels))
+                  (loop (cdr sels) (cdr shp) nshp))
+                 (else
+                  (loop (cdr sels) (cdr shp) (cons (car sels) nshp)))))))
+
+;;@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))))
+
+;;@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
+;;data from the lower end and reduces the upper bound of the result; a
+;;negative @var{s} trims from the upper end and increases the lower
+;;bound.
+;;
+;;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))
+;;
+;;(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)))
+;;
+;;(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))
+;;@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))))