summaryrefslogtreecommitdiffstats
path: root/subarray.scm
diff options
context:
space:
mode:
authorThomas Bushnell, BSG <tb@debian.org>2005-11-02 14:55:21 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:32 -0800
commit34c54a22ff7818bb8b38ef4d9c87dbbcb221ba73 (patch)
tree1189d06a81277bcf8539b0260a69a19f6038effb /subarray.scm
parent611b3db17894e5fdc0db3d49eaf6743d27b44233 (diff)
parent5145dd3aa0c02c9fc496d1432fc4410674206e1d (diff)
downloadslib-34c54a22ff7818bb8b38ef4d9c87dbbcb221ba73.tar.gz
slib-34c54a22ff7818bb8b38ef4d9c87dbbcb221ba73.zip
Import Debian changes 3a2-1debian/3a2-1
slib (3a2-1) unstable; urgency=low * New upstream release. * Acknowledge NMU. (Closes: #281809) * Makefile: Don't hack Makefile; use rules instead. * debian/rules: Set on make invocations: prefix, htmldir, TEXI2HTML. * debian/rules (clean): Clean more stuff here. * Makefile: Comment out old rule for $(htmldir)slib_toc.html. Instead, specify directly that the texi2html invocation produces that file. * debian/rules (binary-indep): Find web files in slib subdir. * debian/control (Build-Depends-Indep): Go back to using scm.
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 '())))