1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
;;;; "arraymap.scm", applicative routines for arrays in Scheme.
;;; Copyright (c) 1993, 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
;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;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.
;
;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 'array)
;;@code{(require 'array-for-each)}
;;@ftindex array-for-each
;;@args array0 proc array1 @dots{}
;;@var{array1}, @dots{} must have the same number of dimensions as
;;@var{array0} and have a range for each index which includes the range
;;for the corresponding index in @var{array0}. @var{proc} is applied to
;;each tuple of elements of @var{array1} @dots{} and the result is stored
;;as the corresponding element in @var{array0}. The value returned is
;;unspecified. The order of application is unspecified.
(define (array-map! ra0 proc . ras)
(define (ramap rshape inds)
(if (null? (cdr rshape))
(do ((i (cadar rshape) (+ -1 i))
(is (cons (cadar rshape) inds)
(cons (+ -1 i) inds)))
((< i (caar rshape)))
(apply array-set! ra0
(apply proc (map (lambda (ra) (apply array-ref ra is)) ras))
is))
(let ((crshape (cdr rshape))
(ll (caar rshape)))
(do ((i (cadar rshape) (+ -1 i)))
((< i ll))
(ramap crshape (cons i inds))))))
(ramap (reverse (array-shape ra0)) '()))
;;@args prototype proc array1 array2 @dots{}
;;@var{array2}, @dots{} must have the same number of dimensions as
;;@var{array1} and have a range for each index which includes the
;;range for the corresponding index in @var{array1}. @var{proc} is
;;applied to each tuple of elements of @var{array1}, @var{array2},
;;@dots{} and the result is stored as the corresponding element in a
;;new array of type @var{prototype}. The new array is returned. The
;;order of application is unspecified.
(define (array-map prototype proc ra1 . ras)
(define nra (apply create-array prototype (array-shape ra1)))
(apply array-map! nra proc ra1 ras)
nra)
;;@args proc array0 @dots{}
;;@var{proc} is applied to each tuple of elements of @var{array0} @dots{}
;;in row-major order. The value returned is unspecified.
(define (array-for-each proc . ras)
(define (rafe rshape inds)
(if (null? (cdr rshape))
(let ((sdni (reverse (cons #f inds))))
(define lastpair (last-pair sdni))
(do ((i (caar rshape) (+ 1 i)))
((> i (cadar rshape)))
(set-car! lastpair i)
(apply proc (map (lambda (ra) (apply array-ref ra sdni)) ras))))
(let ((crshape (cdr rshape))
(ll (cadar rshape)))
(do ((i (caar rshape) (+ 1 i)))
((> i ll))
(rafe crshape (cons i inds))))))
(rafe (array-shape (car ras)) '()))
;;@args array
;;Returns an array of lists of indexes for @var{array} such that, if
;;@var{li} is a list of indexes for which @var{array} is defined,
;;(equal? @var{li} (apply array-ref (array-indexes @var{array})
;;@var{li})).
(define (array-indexes ra)
(let ((ra0 (apply create-array '#() (array-shape ra))))
(array-index-map! ra0 list)
ra0))
;;@args array proc
;;applies @var{proc} to the indices of each element of @var{array} in
;;turn, storing the result in the corresponding element. The value
;;returned and the order of application are unspecified.
;;
;;One can implement @var{array-indexes} as
;;@example
;;(define (array-indexes array)
;; (let ((ra (apply create-array '#() (array-shape array))))
;; (array-index-map! ra (lambda x x))
;; ra))
;;@end example
;;Another example:
;;@example
;;(define (apl:index-generator n)
;; (let ((v (make-vector n 1)))
;; (array-index-map! v (lambda (i) i))
;; v))
;;@end example
(define (array-index-map! ra fun)
(define (ramap rshape inds)
(if (null? (cdr rshape))
(do ((i (cadar rshape) (+ -1 i))
(is (cons (cadar rshape) inds)
(cons (+ -1 i) inds)))
((< i (caar rshape)))
(apply array-set! ra (apply fun is) is))
(let ((crshape (cdr rshape))
(ll (caar rshape)))
(do ((i (cadar rshape) (+ -1 i)))
((< i ll))
(ramap crshape (cons i inds))))))
(if (zero? (array-rank ra))
(array-set! ra (fun))
(ramap (reverse (array-shape ra)) '())))
;;@args source destination
;;Copies every element from vector or array @var{source} to the
;;corresponding element of @var{destination}. @var{destination} must
;;have the same rank as @var{source}, and be at least as large in each
;;dimension. The order of copying is unspecified.
(define (array-copy! source dest)
(array-map! dest identity source))
|
