summaryrefslogtreecommitdiffstats
path: root/subarray.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:31 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:31 -0800
commit5145dd3aa0c02c9fc496d1432fc4410674206e1d (patch)
tree540afc30c51da085f5bd8ec3f4c89f6496e7900d /subarray.scm
parent8466d8cfa486fb30d1755c4261b781135083787b (diff)
downloadslib-5145dd3aa0c02c9fc496d1432fc4410674206e1d.tar.gz
slib-5145dd3aa0c02c9fc496d1432fc4410674206e1d.zip
Import Upstream version 3a2upstream/3a2
Diffstat (limited to 'subarray.scm')
-rw-r--r--subarray.scm120
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 '())))