source: project/release/4/srfi-25/tests/run.scm @ 15208

Last change on this file since 15208 was 15208, checked in by felix winkelmann, 11 years ago

ported srfi-25 to r4

File size: 16.7 KB
Line 
1;;; array test
2;;; 2001 Jussi Piitulainen
3
4;(use srfi-25)
5
6(define past
7  (let ((stones '()))
8    (lambda stone
9      (print stone)
10      (if (null? stone)
11          (reverse stones)
12          (set! stones (cons (apply (lambda (stone) stone) stone) stones))))))
13
14(define (tail n)
15  (if (< n (length (past)))
16      (list-tail (past) (- (length (past)) n))
17      (past)))
18
19;;; Simple tests
20
21(or (and (shape)
22         (shape -1 -1)
23         (shape -1 0)
24         (shape -1 1)
25         (shape 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8))
26    (error "(shape ...) failed"))
27
28(past "shape")
29
30(or (and (make-array (shape))
31         (make-array (shape) *)
32         (make-array (shape -1 -1))
33         (make-array (shape -1 -1) *)
34         (make-array (shape -1 1))
35         (make-array (shape 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8 1 2 3 4) *))
36    (error "(make-array (shape ...) [o]) failed"))
37
38(past "make-array")
39
40(or (and (array (shape) *)
41         (array (shape -1 -1))
42         (array (shape -1 1) * *)
43         (array (shape 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8) *))
44    (error "(array (shape ...) ...) failed"))
45
46(past "array")
47
48(or (and (= (array-rank (shape)) 2)
49         (= (array-rank (shape -1 -1)) 2)
50         (= (array-rank (shape -1 1)) 2)
51         (= (array-rank (shape 1 2 3 4 5 6 7 8)) 2))
52    (error "(array-rank (shape ...)) failed"))
53
54(past "array-rank of shape")
55
56(or (and (= (array-rank (make-array (shape))) 0)
57         (= (array-rank (make-array (shape -1 -1))) 1)
58         (= (array-rank (make-array (shape -1 1))) 1)
59         (= (array-rank (make-array (shape 1 2 3 4 5 6 7 8))) 4))
60    (error "(array-rank (make-array ...)) failed"))
61
62(past "array-rank of make-array")
63
64(or (and (= (array-rank (array (shape) *)) 0)
65         (= (array-rank (array (shape -1 -1))) 1)
66         (= (array-rank (array (shape -1 1) * *)) 1)
67         (= (array-rank (array (shape 1 2 3 4 5 6 7 8) *)) 4))
68    (error "(array-rank (array ...)) failed"))
69
70(past "array-rank of array")
71
72(or (and (= (array-start (shape -1 -1) 0) 0)
73         (= (array-start (shape -1 -1) 1) 0)
74         (= (array-start (shape -1 1) 0) 0)
75         (= (array-start (shape -1 1) 1) 0)
76         (= (array-start (shape 1 2 3 4 5 6 7 8) 0) 0)
77         (= (array-start (shape 1 2 3 4 5 6 7 8) 1) 0))
78    (error "(array-start (shape ...)) failed"))
79
80(past "array-start of shape")
81
82(or (and (= (array-end (shape -1 -1) 0) 1)
83         (= (array-end (shape -1 -1) 1) 2)
84         (= (array-end (shape -1 1) 0) 1)
85         (= (array-end (shape -1 1) 1) 2)
86         (= (array-end (shape 1 2 3 4 5 6 7 8) 0) 4)
87         (= (array-end (shape 1 2 3 4 5 6 7 8) 1) 2))
88    (error "(array-end (shape ...)) failed"))
89
90(past "array-end of shape")
91
92(or (and (= (array-start (make-array (shape -1 -1)) 0) -1)
93         (= (array-start (make-array (shape -1 1)) 0) -1)
94         (= (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 0) 1)
95         (= (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 1) 3)
96         (= (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 2) 5)
97         (= (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 3) 7))
98    (error "(array-start (make-array ...)) failed"))
99
100(past "array-start of make-array")
101
102(or (and (= (array-end (make-array (shape -1 -1)) 0) -1)
103         (= (array-end (make-array (shape -1 1)) 0) 1)
104         (= (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 0) 2)
105         (= (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 1) 4)
106         (= (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 2) 6)
107         (= (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 3) 8))
108    (error "(array-end (make-array ...)) failed"))
109
110(past "array-end of make-array")
111
112(or (and (= (array-start (array (shape -1 -1)) 0) -1)
113         (= (array-start (array (shape -1 1) * *) 0) -1)
114         (= (array-start (array (shape 1 2 3 4 5 6 7 8) *) 0) 1)
115         (= (array-start (array (shape 1 2 3 4 5 6 7 8) *) 1) 3)
116         (= (array-start (array (shape 1 2 3 4 5 6 7 8) *) 2) 5)
117         (= (array-start (array (shape 1 2 3 4 5 6 7 8) *) 3) 7))
118    (error "(array-start (array ...)) failed"))
119
120(past "array-start of array")
121
122(or (and (= (array-end (array (shape -1 -1)) 0) -1)
123         (= (array-end (array (shape -1 1) * *) 0) 1)
124         (= (array-end (array (shape 1 2 3 4 5 6 7 8) *) 0) 2)
125         (= (array-end (array (shape 1 2 3 4 5 6 7 8) *) 1) 4)
126         (= (array-end (array (shape 1 2 3 4 5 6 7 8) *) 2) 6)
127         (= (array-end (array (shape 1 2 3 4 5 6 7 8) *) 3) 8))
128    (error "(array-end (array ...)) failed"))
129
130(past "array-end of array")
131
132(or (and (eq? (array-ref (make-array (shape) 'a)) 'a)
133         (eq? (array-ref (make-array (shape -1 1) 'b) -1) 'b)
134         (eq? (array-ref (make-array (shape -1 1) 'c) 0) 'c)
135         (eq? (array-ref (make-array (shape 1 2 3 4 5 6 7 8) 'd) 1 3 5 7) 'd))
136    (error "array-ref of make-array with arguments failed"))
137
138(past "array-ref of make-array with arguments")
139
140(or (and (eq? (array-ref (make-array (shape) 'a) '#()) 'a)
141         (eq? (array-ref (make-array (shape -1 1) 'b) '#(-1)) 'b)
142         (eq? (array-ref (make-array (shape -1 1) 'c) '#(0)) 'c)
143         (eq? (array-ref (make-array (shape 1 2 3 4 5 6 7 8) 'd)
144                         '#(1 3 5 7))
145              'd))
146    (error "array-ref of make-array with vector failed"))
147
148(past "array-ref of make-array with vector")
149
150(or (and (eq? (array-ref (make-array (shape) 'a)
151                         (array (shape 0 0)))
152              'a)
153         (eq? (array-ref (make-array (shape -1 1) 'b)
154                         (array (shape 0 1) -1))
155              'b)
156         (eq? (array-ref (make-array (shape -1 1) 'c)
157                         (array (shape 0 1) 0))
158              'c)
159         (eq? (array-ref (make-array (shape 1 2 3 4 5 6 7 8) 'd)
160                         (array (shape 0 4) 1 3 5 7))
161              'd))
162    (error "(array-ref of make-array with array failed"))
163
164(past "array-ref of make-array with array")
165
166(or (and (let ((arr (make-array (shape) 'o)))
167           (array-set! arr 'a)
168           (eq? (array-ref arr) 'a))
169         (let ((arr (make-array (shape -1 1) 'o)))
170           (array-set! arr -1 'b)
171           (array-set! arr 0 'c)
172           (and (eq? (array-ref arr -1) 'b)
173                (eq? (array-ref arr 0) 'c)))
174         (let ((arr (make-array (shape 1 2 3 4 5 6 7 8) 'o)))
175           (array-set! arr 1 3 5 7 'd)
176           (eq? (array-ref arr 1 3 5 7) 'd)))
177    (error "array-set! with arguments failed"))
178
179(past "array-set! of make-array with arguments")
180
181(or (and (let ((arr (make-array (shape) 'o)))
182           (array-set! arr '#() 'a)
183           (eq? (array-ref arr) 'a))
184         (let ((arr (make-array (shape -1 1) 'o)))
185           (array-set! arr '#(-1) 'b)
186           (array-set! arr '#(0) 'c)
187           (and (eq? (array-ref arr -1) 'b)
188                (eq? (array-ref arr 0) 'c)))
189         (let ((arr (make-array (shape 1 2 3 4 5 6 7 8) 'o)))
190           (array-set! arr '#(1 3 5 7) 'd)
191           (eq? (array-ref arr 1 3 5 7) 'd)))
192    (error "array-set! with vector failed"))
193
194(past "array-set! of make-array with vector")
195
196(or (and (let ((arr (make-array (shape) 'o)))
197           (array-set! arr 'a)
198           (eq? (array-ref arr) 'a))
199         (let ((arr (make-array (shape -1 1) 'o)))
200           (array-set! arr (array (shape 0 1) -1) 'b)
201           (array-set! arr (array (shape 0 1) 0) 'c)
202           (and (eq? (array-ref arr -1) 'b)
203                (eq? (array-ref arr 0) 'c)))
204         (let ((arr (make-array (shape 1 2 3 4 5 6 7 8) 'o)))
205           (array-set! arr (array (shape 0 4) 1 3 5 7) 'd)
206           (eq? (array-ref arr 1 3 5 7) 'd)))
207    (error "array-set! with arguments failed"))
208
209(past "array-set! of make-array with array")
210
211;;; Share and change:
212;;;
213;;;  org     brk     swp            box
214;;;
215;;;   0 1     1 2     5 6
216;;; 6 a b   2 a b   3 d c   0 2 4 6 8: e
217;;; 7 c d   3 e f   4 f e
218;;; 8 e f
219
220(or (let* ((org (array (shape 6 9 0 2) 'a 'b 'c 'd 'e 'f))
221           (brk (share-array
222                 org
223                 (shape 2 4 1 3)
224                 (lambda (r k)
225                   (values
226                    (+ 6 (* 2 (- r 2)))
227                    (- k 1)))))
228           (swp (share-array
229                 org
230                 (shape 3 5 5 7)
231                 (lambda (r k)
232                   (values
233                    (+ 7 (- r 3))
234                    (- 1 (- k 5))))))
235           (box (share-array
236                 swp
237                 (shape 0 1 2 3 4 5 6 7 8 9)
238                 (lambda _ (values 4 6))))
239           (org-contents (lambda ()
240                           (list (array-ref org 6 0) (array-ref org 6 1)
241                                 (array-ref org 7 0) (array-ref org 7 1)
242                                 (array-ref org 8 0) (array-ref org 8 1))))
243           (brk-contents (lambda ()
244                           (list (array-ref brk 2 1) (array-ref brk 2 2)
245                                 (array-ref brk 3 1) (array-ref brk 3 2))))
246           (swp-contents (lambda ()
247                           (list (array-ref swp 3 5) (array-ref swp 3 6)
248                                 (array-ref swp 4 5) (array-ref swp 4 6))))
249           (box-contents (lambda ()
250                           (list (array-ref box 0 2 4 6 8)))))
251      (and (equal? (org-contents) '(a b c d e f))
252           (equal? (brk-contents) '(a b e f))
253           (equal? (swp-contents) '(d c f e))
254           (equal? (box-contents) '(e))
255           (begin (array-set! org 6 0 'x) #t)
256           (equal? (org-contents) '(x b c d e f))
257           (equal? (brk-contents) '(x b e f))
258           (equal? (swp-contents) '(d c f e))
259           (equal? (box-contents) '(e))
260           (begin (array-set! brk 3 1 'y) #t)
261           (equal? (org-contents) '(x b c d y f))
262           (equal? (brk-contents) '(x b y f))
263           (equal? (swp-contents) '(d c f y))
264           (equal? (box-contents) '(y))
265           (begin (array-set! swp 4 5 'z) #t)
266           (equal? (org-contents) '(x b c d y z))
267           (equal? (brk-contents) '(x b y z))
268           (equal? (swp-contents) '(d c z y))
269           (equal? (box-contents) '(y))
270           (begin (array-set! box 0 2 4 6 8 'e) #t)
271           (equal? (org-contents) '(x b c d e z))
272           (equal? (brk-contents) '(x b e z))
273           (equal? (swp-contents) '(d c z e))
274           (equal? (box-contents) '(e))))
275    (error "shared change failed"))
276
277(past "shared change")
278
279;;; Check that arrays copy the shape specification
280
281(or (let ((shp (shape 10 12)))
282      (let ((arr (make-array shp))
283            (ars (array shp * *))
284            (art (share-array (make-array shp) shp (lambda (k) k))))
285        (array-set! shp 0 0 '?)
286        (array-set! shp 0 1 '!)
287        (and (= (array-rank shp) 2)
288             (= (array-start shp 0) 0)
289             (= (array-end shp 0) 1)
290             (= (array-start shp 1) 0)
291             (= (array-end shp 1) 2)
292             (eq? (array-ref shp 0 0) '?)
293             (eq? (array-ref shp 0 1) '!)
294             (= (array-rank arr) 1)
295             (= (array-start arr 0) 10)
296             (= (array-end arr 0) 12)
297             (= (array-rank ars) 1)
298             (= (array-start ars 0) 10)
299             (= (array-end ars 0) 12)
300             (= (array-rank art) 1)
301             (= (array-start art 0) 10)
302             (= (array-end art 0) 12))))
303    (error "array-set! of shape failed"))
304
305(past "array-set! of shape")
306
307;;; Check that index arrays work even when they share
308;;;
309;;; arr       ixn
310;;;   5  6      0 1
311;;; 4 nw ne   0 4 6
312;;; 5 sw se   1 5 4
313
314(or (let ((arr (array (shape 4 6 5 7) 'nw 'ne 'sw 'se))
315          (ixn (array (shape 0 2 0 2) 4 6 5 4)))
316      (let ((col0 (share-array
317                   ixn
318                   (shape 0 2)
319                   (lambda (k)
320                     (values k 0))))
321            (row0 (share-array
322                   ixn
323                   (shape 0 2)
324                   (lambda (k)
325                     (values 0 k))))
326            (wor1 (share-array
327                   ixn
328                   (shape 0 2)
329                   (lambda (k)
330                     (values 1 (- 1 k)))))
331            (cod (share-array
332                  ixn
333                  (shape 0 2)
334                  (lambda (k)
335                    (case k
336                      ((0) (values 1 0))
337                      ((1) (values 0 1))))))
338            (box (share-array
339                  ixn
340                  (shape 0 2)
341                  (lambda (k)
342                    (values 1 0)))))
343        (and (eq? (array-ref arr col0) 'nw)
344             (eq? (array-ref arr row0) 'ne)
345             (eq? (array-ref arr wor1) 'nw)
346             (eq? (array-ref arr cod) 'se)
347             (eq? (array-ref arr box) 'sw)
348             (begin
349               (array-set! arr col0 'ul)
350               (array-set! arr row0 'ur)
351               (array-set! arr cod 'lr)
352               (array-set! arr box 'll)
353               #t)
354             (eq? (array-ref arr 4 5) 'ul)
355             (eq? (array-ref arr 4 6) 'ur)
356             (eq? (array-ref arr 5 5) 'll)
357             (eq? (array-ref arr 5 6) 'lr)
358             (begin
359               (array-set! arr wor1 'xx)
360               (eq? (array-ref arr 4 5) 'xx)))))
361    (error "array access with sharing index array failed"))
362
363(past "array access with sharing index array")
364
365;;; Check that shape arrays work even when they share
366;;;
367;;; arr             shp       shq       shr       shs
368;;;    1  2  3  4      0  1      0  1      0  1      0  1
369;;; 1 10 12 16 20   0 10 12   0 12 20   0 10 10   0 12 12
370;;; 2 10 11 12 13   1 10 11   1 11 13   1 11 12   1 12 12
371;;;                                     2 12 16
372;;;                                     3 13 20
373
374(or (let ((arr (array (shape 1 3 1 5) 10 12 16 20 10 11 12 13)))
375      (let ((shp (share-array
376                  arr
377                  (shape 0 2 0 2)
378                  (lambda (r k)
379                    (values (+ r 1) (+ k 1)))))
380            (shq (share-array
381                  arr
382                  (shape 0 2 0 2)
383                  (lambda (r k)
384                    (values (+ r 1) (* 2 (+ 1 k))))))
385            (shr (share-array
386                  arr
387                  (shape 0 4 0 2)
388                  (lambda (r k)
389                    (values (- 2 k) (+ r 1)))))
390            (shs (share-array
391                  arr
392                  (shape 0 2 0 2)
393                  (lambda (r k)
394                    (values 2 3)))))
395        (and (let ((arr-p (make-array shp)))
396               (and (= (array-rank arr-p) 2)
397                    (= (array-start arr-p 0) 10)
398                    (= (array-end arr-p 0) 12)
399                    (= (array-start arr-p 1) 10)
400                    (= (array-end arr-p 1) 11)))
401             (let ((arr-q (array shq * * * *  * * * *  * * * *  * * * *)))
402               (and (= (array-rank arr-q) 2)
403                    (= (array-start arr-q 0) 12)
404                    (= (array-end arr-q 0) 20)
405                    (= (array-start arr-q 1) 11)
406                    (= (array-end arr-q 1) 13)))
407             (let ((arr-r (share-array
408                           (array (shape) *)
409                           shr
410                           (lambda _ (values)))))
411               (and (= (array-rank arr-r) 4)
412                    (= (array-start arr-r 0) 10)
413                    (= (array-end arr-r 0) 10)
414                    (= (array-start arr-r 1) 11)
415                    (= (array-end arr-r 1) 12)
416                    (= (array-start arr-r 2) 12)
417                    (= (array-end arr-r 2) 16)
418                    (= (array-start arr-r 3) 13)
419                    (= (array-end arr-r 3) 20)))
420             (let ((arr-s (make-array shs)))
421               (and (= (array-rank arr-s) 2)
422                    (= (array-start arr-s 0) 12)
423                    (= (array-end arr-s 0) 12)
424                    (= (array-start arr-s 1) 12)
425                    (= (array-end arr-s 1) 12))))))
426    (error "sharing shape array failed"))
427
428(past "sharing shape array")
429
430(let ((super (array (shape 4 7 4 7)
431                    1 * *
432                    * 2 *
433                    * * 3))
434      (subshape (share-array
435                 (array (shape 0 2 0 3)
436                        * 4 *
437                        * 7 *)
438                 (shape 0 1 0 2)
439                 (lambda (r k)
440                   (values k 1)))))
441  (let ((sub (share-array super subshape (lambda (k) (values k k)))))
442    ;(array-equal? subshape (shape 4 7))
443    (or (and (= (array-rank subshape) 2)
444             (= (array-start subshape 0) 0)
445             (= (array-end subshape 0) 1)
446             (= (array-start subshape 1) 0)
447             (= (array-end subshape 1) 2)
448             (= (array-ref subshape 0 0) 4)
449             (= (array-ref subshape 0 1) 7))
450        (error "sharing subshape failed"))
451    ;(array-equal? sub (array (shape 4 7) 1 2 3))
452    (or (and (= (array-rank sub) 1)
453             (= (array-start sub 0) 4)
454             (= (array-end sub 0) 7)
455             (= (array-ref sub 4) 1)
456             (= (array-ref sub 5) 2)
457             (= (array-ref sub 6) 3))
458        (error "sharing with sharing subshape failed"))))
459
460(past "sharing with sharing subshape")
Note: See TracBrowser for help on using the repository browser.