summaryrefslogtreecommitdiffstats
path: root/array.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commit8466d8cfa486fb30d1755c4261b781135083787b (patch)
treec8c12c67246f543c3cc4f64d1c07e003cb1d45ae /array.scm
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-8466d8cfa486fb30d1755c4261b781135083787b.tar.gz
slib-8466d8cfa486fb30d1755c4261b781135083787b.zip
Import Upstream version 3a1upstream/3a1
Diffstat (limited to 'array.scm')
-rw-r--r--array.scm186
1 files changed, 150 insertions, 36 deletions
diff --git a/array.scm b/array.scm
index 47df853..417e137 100644
--- a/array.scm
+++ b/array.scm
@@ -1,5 +1,5 @@
;;;;"array.scm" Arrays for Scheme
-; Copyright (C) 2001 Aubrey Jaffer
+; Copyright (C) 2001, 2003 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;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.
;
@@ -30,7 +30,12 @@
store ;data
)))
-(define array:shape (record-accessor array:rtd 'shape))
+(define array:shape
+ (let ((shape (record-accessor array:rtd 'shape)))
+ (lambda (array)
+ (cond ((vector? array) (list (list 0 (+ -1 (vector-length array)))))
+ ((string? array) (list (list 0 (+ -1 (string-length array)))))
+ (else (shape array))))))
(define array:scales
(let ((scales (record-accessor array:rtd 'scales)))
@@ -77,7 +82,8 @@
;;corresponding elements of @1 and @2 are @code{equal?}.
;;
;;@example
-;;(array=? (make-array 'foo 3 3) (make-array 'foo '(0 2) '(1 2)))
+;;(array=? (create-array '#(foo) 3 3)
+;; (create-array '#(foo) '(0 2) '(0 2)))
;; @result{} #t
;;@end example
(define (array=? array1 array2)
@@ -87,17 +93,133 @@
(define (array:dimensions->shape dims)
(map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dims))
-;;@args initial-value bound1 bound2 @dots{}
-;;Creates and returns an array with dimensions @var{bound1},
-;;@var{bound2}, @dots{} and filled with @1.
-(define (make-array initial-value . dimensions)
+;;@args prototype bound1 bound2 @dots{}
+;;
+;;Creates and returns an array of type @1 with dimensions @2, @3,
+;;@dots{} and filled with elements from @1. @1 must be an array,
+;;vector, or string. The implementation-dependent type of the returned
+;;array will be the same as the type of @1; except if that would be a
+;;vector or string with non-zero origin, in which case some variety of
+;;array will be returned.
+;;
+;;If the @1 has no elements, then the initial contents of the returned
+;;array are unspecified. Otherwise, the returned array will be filled
+;;with the element at the origin of @1.
+(define (create-array prototype . dimensions)
+ (define range2length (lambda (bnd) (- 1 (apply - bnd))))
+ ;;(if (not (array? prototype)) (set! prototype (vector prototype)))
(let* ((shape (array:dimensions->shape dimensions))
- (dims (map (lambda (bnd) (- 1 (apply - bnd))) shape))
- (scales (reverse (cons 1 (cdr (reverse dims))))))
- (array:construct shape
- scales
- (- (apply + (map * (map car shape) scales)))
- (make-vector (apply * dims) initial-value))))
+ (dims (map range2length shape))
+ (scales
+ (do ((dims (reverse (cdr dims)) (cdr dims))
+ (scls '(1) (cons (* (car dims) (car scls)) scls)))
+ ((null? dims) scls))))
+ (array:construct
+ shape
+ scales
+ (- (apply + (map * (map car shape) scales)))
+ (if (string? prototype)
+ (case (string-length prototype)
+ ((0) (make-string (apply * dims)))
+ (else (make-string (apply * dims)
+ (string-ref prototype 0))))
+ (let ((pshape (array:shape prototype)))
+ (case (apply * (map range2length pshape))
+ ((0) (make-vector (apply * dims)))
+ (else (make-vector (apply * dims)
+ (apply array-ref prototype
+ (map car pshape))))))))))
+
+;;@noindent
+;;These functions return a prototypical uniform-array enclosing the
+;;optional argument (which must be of the correct type). If the
+;;uniform-array type is supported by the implementation, then it is
+;;returned; defaulting to the next larger precision type; resorting
+;;finally to vector.
+
+(define (make-prototype-checker name pred? creator)
+ (lambda args
+ (case (length args)
+ ((1) (if (pred? (car args))
+ (creator (car args))
+ (slib:error name 'incompatible 'type (car args))))
+ ((0) (creator))
+ (else (slib:error name 'wrong 'number 'of 'args args)))))
+
+(define (integer-bytes?? n)
+ (lambda (obj)
+ (and (integer? obj)
+ (exact? obj)
+ (or (negative? n) (not (negative? obj)))
+ (do ((num obj (quotient num 256))
+ (n (+ -1 (abs n)) (+ -1 n)))
+ ((or (zero? num) (negative? n))
+ (zero? num))))))
+
+;;@args z
+;;@args
+;;Returns a high-precision complex uniform-array prototype.
+(define Ac64 (make-prototype-checker 'Ac64 complex? vector))
+;;@args z
+;;@args
+;;Returns a complex uniform-array prototype.
+(define Ac32 (make-prototype-checker 'Ac32 complex? vector))
+
+;;@args x
+;;@args
+;;Returns a high-precision real uniform-array prototype.
+(define Ar64 (make-prototype-checker 'Ar64 real? vector))
+;;@args x
+;;@args
+;;Returns a real uniform-array prototype.
+(define Ar32 (make-prototype-checker 'Ar32 real? vector))
+
+;;@args n
+;;@args
+;;Returns an exact signed integer uniform-array prototype with at least
+;;64 bits of precision.
+(define As64 (make-prototype-checker 'As64 (integer-bytes?? -8) vector))
+;;@args n
+;;@args
+;;Returns an exact signed integer uniform-array prototype with at least
+;;32 bits of precision.
+(define As32 (make-prototype-checker 'As32 (integer-bytes?? -4) vector))
+;;@args n
+;;@args
+;;Returns an exact signed integer uniform-array prototype with at least
+;;16 bits of precision.
+(define As16 (make-prototype-checker 'As16 (integer-bytes?? -2) vector))
+;;@args n
+;;@args
+;;Returns an exact signed integer uniform-array prototype with at least
+;;8 bits of precision.
+(define As8 (make-prototype-checker 'As8 (integer-bytes?? -1) vector))
+
+;;@args k
+;;@args
+;;Returns an exact non-negative integer uniform-array prototype with at
+;;least 64 bits of precision.
+(define Au64 (make-prototype-checker 'Au64 (integer-bytes?? 8) vector))
+;;@args k
+;;@args
+;;Returns an exact non-negative integer uniform-array prototype with at
+;;least 32 bits of precision.
+(define Au32 (make-prototype-checker 'Au32 (integer-bytes?? 4) vector))
+;;@args k
+;;@args
+;;Returns an exact non-negative integer uniform-array prototype with at
+;;least 16 bits of precision.
+(define Au16 (make-prototype-checker 'Au16 (integer-bytes?? 2) vector))
+;;@args k
+;;@args
+;;Returns an exact non-negative integer uniform-array prototype with at
+;;least 8 bits of precision.
+(define Au8 (make-prototype-checker 'Au8 (integer-bytes?? 1) vector))
+
+;;@args bool
+;;@args
+;;Returns a boolean uniform-array prototype.
+(define At1 (make-prototype-checker 'At1 boolean? vector))
;;@noindent
;;When constructing an array, @var{bound} is either an inclusive range of
@@ -105,18 +227,18 @@
;;a single integer. So
;;
;;@example
-;;(make-array 'foo 3 3) @equiv{} (make-array 'foo '(0 2) '(0 2))
+;;(create-array '#(foo) 3 3) @equiv{} (create-array '#(foo) '(0 2) '(0 2))
;;@end example
;;@args array mapper bound1 bound2 @dots{}
-;;@code{make-shared-array} can be used to create shared subarrays of other
+;;@0 can be used to create shared subarrays of other
;;arrays. The @var{mapper} is a function that translates coordinates in
;;the new array into coordinates in the old array. A @var{mapper} must be
;;linear, and its range must stay within the bounds of the old array, but
;;it can be otherwise arbitrary. A simple example:
;;
;;@example
-;;(define fred (make-array #f 8 8))
+;;(define fred (create-array '#(#f) 8 8))
;;(define freds-diagonal
;; (make-shared-array fred (lambda (i) (list i i)) 8))
;;(array-set! freds-diagonal 'foo 3)
@@ -153,32 +275,28 @@
;;Returns the number of dimensions of @1. If @1 is not an array, 0 is
;;returned.
(define (array-rank obj)
- (if (array? obj) (length (array-shape obj)) 0))
+ (if (array? obj) (length (array:shape obj)) 0))
-;;@body
+;;@args array
;;Returns a list of inclusive bounds.
;;
;;@example
-;;(array-shape (make-array 'foo 3 5))
+;;(array-shape (create-array '#() 3 5))
;; @result{} ((0 2) (0 4))
;;@end example
-(define array-shape
- (lambda (array)
- (cond ((vector? array) (list (list 0 (+ -1 (vector-length array)))))
- ((string? array) (list (list 0 (+ -1 (string-length array)))))
- (else (array:shape array)))))
+(define array-shape array:shape)
;;@body
;;@code{array-dimensions} is similar to @code{array-shape} but replaces
;;elements with a 0 minimum with one greater than the maximum.
;;
;;@example
-;;(array-dimensions (make-array 'foo 3 5))
+;;(array-dimensions (create-array '#() 3 5))
;; @result{} (3 5)
;;@end example
(define (array-dimensions array)
(map (lambda (bnd) (if (zero? (car bnd)) (+ 1 (cadr bnd)) bnd))
- (array-shape array)))
+ (array:shape array)))
(define (array:in-bounds? array indices)
(do ((bnds (array:shape array) (cdr bnds))
@@ -217,12 +335,8 @@
;;; Legacy functions
-;; These procedures are fast versions of @code{array-ref} and
-;; @code{array-set!} for non-string arrays; they take a fixed number of
-;; arguments and perform no bounds checking.
-(define array-1d-ref array-ref)
-(define array-2d-ref array-ref)
-(define array-3d-ref array-ref)
-(define array-1d-set! array-set!)
-(define array-2d-set! array-set!)
-(define array-3d-set! array-set!)
+;; ;;@args initial-value bound1 bound2 @dots{}
+;; ;;Creates and returns an array with dimensions @2,
+;; ;;@3, @dots{} and filled with @1.
+;; (define (make-array initial-value . dimensions)
+;; (apply create-array (vector initial-value) dimensions))