diff options
Diffstat (limited to 'subarray.scm')
-rw-r--r-- | subarray.scm | 120 |
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 '()))) |