From 87b82b5822ca54228cfa6df29be3ad9d4bc47d16 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:28 -0800
Subject: Import Upstream version 2d2

---
 array.scm | 471 ++++++++++++++++++++++++++++----------------------------------
 1 file changed, 210 insertions(+), 261 deletions(-)

(limited to 'array.scm')

diff --git a/array.scm b/array.scm
index 08b8114..47df853 100644
--- a/array.scm
+++ b/array.scm
@@ -1,279 +1,228 @@
 ;;;;"array.scm" Arrays for Scheme
-; Copyright (C) 1993 Alan Bawden
+; Copyright (C) 2001 Aubrey Jaffer
 ;
-; Permission to copy this software, to redistribute it, and to use it
-; for any purpose is granted, subject to the following restrictions and
-; understandings.
+;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.
+;1.  Any copy made of this software must include this copyright notice
+;in full.
 ;
-; 2.  Users of this software agree to make their best efforts (a) to
-; return to me any improvements or extensions that they make, so that
-; these may be included in future releases; and (b) to inform me of
-; noteworthy uses of this software.
+;2.  I have made no warrantee 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.  I have made no warrantee 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.
-;
-; 4.  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.
-;
-; Alan Bawden
-; MIT Room NE43-510
-; 545 Tech. Sq.
-; Cambridge, MA 02139
-; Alan@LCS.MIT.EDU
+;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 'record)
+;;@code{(require 'array)}
+;;@ftindex array
 
-;(declare (usual-integrations))
+(require 'record)
 
 (define array:rtd
-  (make-record-type "Array"
-    '(indexer		; Must be a -linear- function!
-      shape		; Inclusive bounds: ((lower upper) ...)
-      vector		; The actual contents
-      )))
-
-(define array:indexer (record-accessor array:rtd 'indexer))
-(define array-shape (record-accessor array:rtd 'shape))
-(define array:vector (record-accessor array:rtd 'vector))
-
-(define array? (record-predicate array:rtd))
+  (make-record-type "array"
+		    '(shape
+		      scales		;list of dimension scales
+		      offset		;exact integer
+		      store		;data
+		      )))
+
+(define array:shape (record-accessor array:rtd 'shape))
+
+(define array:scales
+  (let ((scales (record-accessor array:rtd 'scales)))
+    (lambda (obj)
+      (cond ((string? obj) '(1))
+	    ((vector? obj) '(1))
+	    (else (scales obj))))))
+
+(define array:store
+  (let ((store (record-accessor array:rtd 'store)))
+    (lambda (obj)
+      (cond ((string? obj) obj)
+	    ((vector? obj) obj)
+	    (else (store obj))))))
+
+(define array:offset
+  (let ((offset (record-accessor array:rtd 'offset)))
+    (lambda (obj)
+      (cond ((string? obj) 0)
+	    ((vector? obj) 0)
+	    (else (offset obj))))))
 
+(define array:construct
+  (record-constructor array:rtd '(shape scales offset store)))
+
+;;@args obj
+;;Returns @code{#t} if the @1 is an array, and @code{#f} if not.
+(define array?
+  (let ((array:array? (record-predicate array:rtd)))
+    (lambda (obj) (or (string? obj) (vector? obj) (array:array? obj)))))
+
+;;@noindent
+;;@emph{Note:} Arrays are not disjoint from other Scheme types.  Strings
+;;and vectors also satisfy @code{array?}.  A disjoint array predicate can
+;;be written:
+;;
+;;@example
+;;(define (strict-array? obj)
+;;  (and (array? obj) (not (string? obj)) (not (vector? obj))))
+;;@end example
+
+;;@body
+;;Returns @code{#t} if @1 and @2 have the same rank and shape and the
+;;corresponding elements of @1 and @2 are @code{equal?}.
+;;
+;;@example
+;;(array=? (make-array 'foo 3 3) (make-array 'foo '(0 2) '(1 2)))
+;;  @result{} #t
+;;@end example
+(define (array=? array1 array2)
+  (and (equal? (array:shape array1) (array:shape array2))
+       (equal? (array:store array1) (array:store array2))))
+
+(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)
+  (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))))
+
+;;@noindent
+;;When constructing an array, @var{bound} is either an inclusive range of
+;;indices expressed as a two element list, or an upper bound expressed as
+;;a single integer.  So
+;;
+;;@example
+;;(make-array 'foo 3 3) @equiv{} (make-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
+;;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 freds-diagonal
+;;  (make-shared-array fred (lambda (i) (list i i)) 8))
+;;(array-set! freds-diagonal 'foo 3)
+;;(array-ref fred 3 3)
+;;   @result{} FOO
+;;(define freds-center
+;;  (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j)))
+;;                     2 2))
+;;(array-ref freds-center 0 0)
+;;   @result{} FOO
+;;@end example
+(define (make-shared-array array mapper . dimensions)
+  (define odl (array:scales array))
+  (define rank (length dimensions))
+  (define shape (array:dimensions->shape dimensions))
+  (do ((idx (+ -1 rank) (+ -1 idx))
+       (uvt (append (cdr (vector->list (make-vector rank 0))) '(1))
+	    (append (cdr uvt) '(0)))
+       (uvts '() (cons uvt uvts)))
+      ((negative? idx)
+       (let* ((ker0 (apply + (map * odl (apply mapper uvt))))
+	      (scales (map (lambda (uvt)
+			     (- (apply + (map * odl (apply mapper uvt))) ker0))
+			   uvts)))
+	 (array:construct
+	  shape
+	  scales
+	  (- (apply + (array:offset array)
+		    (map * odl (apply mapper (map car shape))))
+	     (apply + (map * (map car shape) scales)))
+	  (array:store array))))))
+
+;;@body
+;;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))
 
-(define (array-dimensions ra)
-  (map (lambda (ind) (if (zero? (car ind)) (+ 1 (cadr ind)) ind))
-       (array-shape ra)))
-
-(define array:construct
-  (record-constructor array:rtd '(shape vector indexer)))
-
-(define (array:compute-shape specs)
-  (map (lambda (spec)
-	 (cond ((and (integer? spec)
-		     (< 0 spec))
-		(list 0 (- spec 1)))
-	       ((and (pair? spec)
-		     (pair? (cdr spec))
-		     (null? (cddr spec))
-		     (integer? (car spec))
-		     (integer? (cadr spec))
-		     (<= (car spec) (cadr spec)))
-		spec)
-	       (else (slib:error "array: Bad array dimension: " spec))))
-       specs))
-
-(define (make-array initial-value . specs)
-  (let ((shape (array:compute-shape specs)))
-    (let loop ((size 1)
-	       (indexer (lambda () 0))
-	       (l (reverse shape)))
-      (if (null? l)
-	  (array:construct shape
-			   (make-vector size initial-value)
-			   (array:optimize-linear-function indexer shape))
-	  (loop (* size (+ 1 (- (cadar l) (caar l))))
-		(lambda (first-index . rest-of-indices)
-		  (+ (* size (- first-index (caar l)))
-		     (apply indexer rest-of-indices)))
-		(cdr l))))))
-
-(define (make-shared-array array mapping . specs)
-  (let ((new-shape (array:compute-shape specs))
-	(old-indexer (array:indexer array)))
-    (let check ((indices '())
-		(bounds (reverse new-shape)))
-      (cond ((null? bounds)
-	     (array:check-bounds array (apply mapping indices)))
-	    (else
-	     (check (cons (caar bounds) indices) (cdr bounds))
-	     (check (cons (cadar bounds) indices) (cdr bounds)))))
-    (array:construct new-shape
-		     (array:vector array)
-		     (array:optimize-linear-function
-		       (lambda indices
-			 (apply old-indexer (apply mapping indices)))
-		       new-shape))))
+;;@body
+;;Returns a list of inclusive bounds.
+;;
+;;@example
+;;(array-shape (make-array 'foo 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)))))
+
+;;@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))
+;;   @result{} (3 5)
+;;@end example
+(define (array-dimensions array)
+  (map (lambda (bnd) (if (zero? (car bnd)) (+ 1 (cadr bnd)) bnd))
+       (array-shape array)))
 
 (define (array:in-bounds? array indices)
-  (let loop ((indices indices)
-	     (shape (array-shape array)))
-    (if (null? indices)
-	(null? shape)
-	(let ((index (car indices)))
-	  (and (not (null? shape))
-	       (integer? index)
-	       (<= (caar shape) index (cadar shape))
-	       (loop (cdr indices) (cdr shape)))))))
-
-(define (array:check-bounds array indices)
-  (or (array:in-bounds? array indices)
-      (slib:error "array: Bad indices for " array indices)))
-
-(define (array-ref array . indices)
-  (array:check-bounds array indices)
-  (vector-ref (array:vector array)
-	      (apply (array:indexer array) indices)))
-
-(define (array-set! array new-value . indices)
-  (array:check-bounds array indices)
-  (vector-set! (array:vector array)
-	       (apply (array:indexer array) indices)
-	       new-value))
-
+  (do ((bnds (array:shape array) (cdr bnds))
+       (idxs indices (cdr idxs)))
+      ((or (null? bnds)
+	   (null? idxs)
+	   (not (integer? (car idxs)))
+	   (not (<= (caar bnds) (car idxs) (cadar bnds))))
+       (and (null? bnds) (null? idxs)))))
+
+;;@args array index1 index2 @dots{}
+;;Returns @code{#t} if its arguments would be acceptable to
+;;@code{array-ref}.
 (define (array-in-bounds? array . indices)
   (array:in-bounds? array indices))
 
-; Fast versions of ARRAY-REF and ARRAY-SET! that do no error checking,
-; and don't cons intermediate lists of indices:
-
-(define (array-1d-ref a i0)
-  (vector-ref (array:vector a) ((array:indexer a) i0)))
-
-(define (array-2d-ref a i0 i1)
-  (vector-ref (array:vector a) ((array:indexer a) i0 i1)))
-
-(define (array-3d-ref a i0 i1 i2)
-  (vector-ref (array:vector a) ((array:indexer a) i0 i1 i2)))
-
-(define (array-1d-set! a v i0)
-  (vector-set! (array:vector a) ((array:indexer a) i0) v))
-
-(define (array-2d-set! a v i0 i1)
-  (vector-set! (array:vector a) ((array:indexer a) i0 i1) v))
-
-(define (array-3d-set! a v i0 i1 i2)
-  (vector-set! (array:vector a) ((array:indexer a) i0 i1 i2) v))
-
-; STOP!  Do not read beyond this point on your first reading of
-; this code -- you should simply assume that the rest of this file
-; contains only the following single definition:
-;
-;   (define (array:optimize-linear-function f l) f)
-;
-; Of course everything would be pretty inefficient if this were really the
-; case, but it isn't.  The following code takes advantage of the fact that
-; you can learn everything there is to know from a linear function by
-; simply probing around in its domain and observing its values -- then a
-; more efficient equivalent can be constructed.
-
-(define (array:optimize-linear-function f l)
-  (let ((d (length l)))
-    (cond
-     ((= d 0)
-      (array:0d-c (f)))
-     ((= d 1)
-      (let ((c (f 0)))
-	(array:1d-c0 c (- (f 1) c))))
-     ((= d 2)
-      (let ((c (f 0 0)))
-	(array:2d-c01 c (- (f 1 0) c) (- (f 0 1) c))))
-     ((= d 3)
-      (let ((c (f 0 0 0)))
-	(array:3d-c012 c (- (f 1 0 0) c) (- (f 0 1 0) c) (- (f 0 0 1) c))))
-     (else
-      (let* ((v (map (lambda (x) 0) l))
-	     (c (apply f v)))
-	(let loop ((p v)
-		   (old-val c)
-		   (coefs '()))
-	  (cond ((null? p)
-		 (array:Nd-c* c (reverse coefs)))
-		(else
-		 (set-car! p 1)
-		 (let ((new-val (apply f v)))
-		   (loop (cdr p)
-			 new-val
-			 (cons (- new-val old-val) coefs)))))))))))
-
-; 0D cases:
-
-(define (array:0d-c c)
-  (lambda () c))
-
-; 1D cases:
-
-(define (array:1d-c c)
-  (lambda (i0) (+ c i0)))
-
-(define (array:1d-0 n0)
-  (cond ((= 1 n0) +)
-	(else (lambda (i0) (* n0 i0)))))
-
-(define (array:1d-c0 c n0)
-  (cond ((= 0 c) (array:1d-0 n0))
-	((= 1 n0) (array:1d-c c))
-	(else (lambda (i0) (+ c (* n0 i0))))))
-
-; 2D cases:
-
-(define (array:2d-0 n0)
-  (lambda (i0 i1) (+ (* n0 i0) i1)))
-
-(define (array:2d-1 n1)
-  (lambda (i0 i1) (+ i0 (* n1 i1))))
-
-(define (array:2d-c0 c n0)
-  (lambda (i0 i1) (+ c (* n0 i0) i1)))
-
-(define (array:2d-c1 c n1)
-  (lambda (i0 i1) (+ c i0 (* n1 i1))))
-
-(define (array:2d-01 n0 n1)
-  (cond ((= 1 n0) (array:2d-1 n1))
-	((= 1 n1) (array:2d-0 n0))
-	(else (lambda (i0 i1) (+ (* n0 i0) (* n1 i1))))))
-
-(define (array:2d-c01 c n0 n1)
-  (cond ((= 0 c) (array:2d-01 n0 n1))
-	((= 1 n0) (array:2d-c1 c n1))
-	((= 1 n1) (array:2d-c0 c n0))
-	(else (lambda (i0 i1) (+ c (* n0 i0) (* n1 i1))))))
-
-; 3D cases:
-
-(define (array:3d-01 n0 n1)
-  (lambda (i0 i1 i2) (+ (* n0 i0) (* n1 i1) i2)))
-
-(define (array:3d-02 n0 n2)
-  (lambda (i0 i1 i2) (+ (* n0 i0) i1 (* n2 i2))))
-
-(define (array:3d-12 n1 n2)
-  (lambda (i0 i1 i2) (+ i0 (* n1 i1) (* n2 i2))))
-
-(define (array:3d-c12 c n1 n2)
-  (lambda (i0 i1 i2) (+ c i0 (* n1 i1) (* n2 i2))))
-
-(define (array:3d-c02 c n0 n2)
-  (lambda (i0 i1 i2) (+ c (* n0 i0) i1 (* n2 i2))))
-
-(define (array:3d-c01 c n0 n1)
-  (lambda (i0 i1 i2) (+ c (* n0 i0) (* n1 i1) i2)))
-
-(define (array:3d-012 n0 n1 n2)
-  (cond ((= 1 n0) (array:3d-12 n1 n2))
-	((= 1 n1) (array:3d-02 n0 n2))
-	((= 1 n2) (array:3d-01 n0 n1))
-	(else (lambda (i0 i1 i2) (+ (* n0 i0) (* n1 i1) (* n2 i2))))))
-
-(define (array:3d-c012 c n0 n1 n2)
-  (cond ((= 0 c) (array:3d-012 n0 n1 n2))
-	((= 1 n0) (array:3d-c12 c n1 n2))
-	((= 1 n1) (array:3d-c02 c n0 n2))
-	((= 1 n2) (array:3d-c01 c n0 n1))
-	(else (lambda (i0 i1 i2) (+ c (* n0 i0) (* n1 i1) (* n2 i2))))))
-
-; ND cases:
-
-(define (array:Nd-* coefs)
-  (lambda indices (apply + (map * coefs indices))))
-
-(define (array:Nd-c* c coefs)
-  (cond ((= 0 c) (array:Nd-* coefs))
-	(else (lambda indices (apply + c (map * coefs indices))))))
+;;@args array index1 index2 @dots{}
+;;Returns the (@2, @3, @dots{}) element of @1.
+(define (array-ref array . indices)
+  (define store (array:store array))
+  (or (array:in-bounds? array indices)
+      (slib:error 'array-ref 'bad-indices indices))
+  ((if (string? store) string-ref vector-ref)
+   store (apply + (array:offset array) (map * (array:scales array) indices))))
+
+;;@args array obj index1 index2 @dots{}
+;;Stores @2 in the (@3, @4, @dots{}) element of @1.  The value returned
+;;by @0 is unspecified.
+(define (array-set! array obj . indices)
+  (define store (array:store array))
+  (or (array:in-bounds? array indices)
+      (slib:error 'array-set! 'bad-indices indices))
+  ((if (string? store) string-set! vector-set!)
+   store (apply + (array:offset array) (map * (array:scales array) indices))
+   obj))
+
+;;; 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!)
-- 
cgit v1.2.3