Artifact 60a7c9082d74fd1640b46dc2e4269374fe9239c9:
- File srfi/s25/arlib.scm — part of check-in [80c8c83034] at 2016-07-07 18:11:39 on branch trunk — initial import (user: ovenpasta@pizzahack.eu size: 18854)
0000: 3b 3b 3b 20 61 72 72 61 79 20 61 72 6c 69 62 0a ;;; array arlib. 0010: 0a 3b 3b 3b 20 32 30 30 31 20 4a 75 73 73 69 20 .;;; 2001 Jussi 0020: 50 69 69 74 75 6c 61 69 6e 65 6e 0a 0a 3b 3b 3b Piitulainen..;;; 0030: 20 54 68 69 73 20 69 73 20 61 20 68 69 67 68 20 This is a high 0040: 6c 65 76 65 6c 20 69 6d 70 6c 65 6d 65 6e 74 61 level implementa 0050: 74 69 6f 6e 20 6f 66 20 73 6f 6d 65 20 67 65 6e tion of some gen 0060: 65 72 61 6c 6c 79 20 75 73 65 66 75 6c 0a 3b 3b erally useful.;; 0070: 3b 20 61 72 72 61 79 20 70 72 6f 63 65 64 75 72 ; array procedur 0080: 65 73 2e 20 49 6e 20 61 64 64 69 74 69 6f 6e 20 es. In addition 0090: 74 6f 20 52 35 52 53 20 61 6e 64 20 53 52 46 49 to R5RS and SRFI 00a0: 2d 32 35 2c 20 6f 6e 6c 79 20 6f 6e 65 0a 3b 3b -25, only one.;; 00b0: 3b 20 74 6f 6f 6c 20 69 73 20 75 73 65 64 2c 20 ; tool is used, 00c0: 6e 61 6d 65 6c 79 20 61 72 72 61 79 3a 61 70 70 namely array:app 00d0: 6c 79 2d 74 6f 2d 76 65 63 74 6f 72 20 61 6e 64 ly-to-vector and 00e0: 20 66 72 69 65 6e 64 73 2e 20 54 68 75 73 0a 3b friends. Thus.; 00f0: 3b 3b 20 74 68 69 73 20 6c 69 62 72 61 72 79 20 ;; this library 0100: 73 65 72 76 65 73 20 74 6f 20 70 72 6f 76 65 20 serves to prove 0110: 74 68 61 74 20 74 68 65 20 70 72 69 6d 69 74 69 that the primiti 0120: 76 65 73 20 72 65 61 6c 6c 79 20 61 72 65 0a 3b ves really are.; 0130: 3b 3b 20 70 72 69 6d 69 74 69 76 65 73 2e 20 2d ;; primitives. - 0140: 20 41 20 6c 6f 77 65 72 20 6c 65 76 65 6c 20 69 A lower level i 0150: 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 20 77 6f mplementation wo 0160: 75 6c 64 20 61 63 63 65 73 73 20 73 6f 6d 65 0a uld access some. 0170: 3b 3b 3b 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 ;;; implementati 0180: 6f 6e 20 64 65 74 61 69 6c 73 20 74 6f 20 62 79 on details to by 0190: 70 61 73 73 20 72 65 64 75 6e 64 61 6e 74 20 63 pass redundant c 01a0: 68 65 63 6b 69 6e 67 20 61 6e 64 20 73 75 63 68 hecking and such 01b0: 2e 0a 0a 3b 3b 3b 20 4e 6f 74 65 20 74 68 61 74 ...;;; Note that 01c0: 20 74 68 65 73 65 20 70 72 6f 63 65 64 75 72 65 these procedure 01d0: 73 20 61 72 65 20 6e 6f 74 20 6e 65 63 65 73 73 s are not necess 01e0: 61 72 69 6c 79 20 64 65 73 69 67 6e 65 64 20 77 arily designed w 01f0: 69 74 68 0a 3b 3b 3b 20 66 75 6c 6c 20 63 61 72 ith.;;; full car 0200: 65 2e 20 54 68 69 6e 6b 20 6f 66 20 74 68 65 6d e. Think of them 0210: 20 61 73 20 65 78 61 6d 70 6c 65 73 20 6f 66 20 as examples of 0220: 77 68 61 74 20 63 61 6e 20 62 65 20 64 6f 6e 65 what can be done 0230: 2e 0a 3b 3b 3b 20 49 6d 70 6f 72 74 61 6e 74 20 ..;;; Important 0240: 74 6f 6f 6c 73 20 61 72 65 20 61 6c 73 6f 20 6d tools are also m 0250: 69 73 73 69 6e 67 2c 20 69 6e 63 6c 75 64 69 6e issing, includin 0260: 67 20 73 63 61 6e 73 20 61 6e 64 20 72 65 64 75 g scans and redu 0270: 63 65 73 0a 3b 3b 3b 20 61 6e 64 20 6d 61 6e 79 ces.;;; and many 0280: 20 74 68 69 6e 6b 73 20 74 68 61 74 20 49 20 68 thinks that I h 0290: 61 76 65 20 6e 6f 74 20 65 76 65 6e 20 68 65 61 ave not even hea 02a0: 72 64 20 6f 66 20 79 65 74 2e 0a 0a 3b 3b 3b 20 rd of yet...;;; 02b0: 28 61 72 72 61 79 2d 73 68 61 70 65 20 61 72 72 (array-shape arr 02c0: 29 20 28 61 72 72 61 79 2d 6c 65 6e 67 74 68 20 ) (array-length 02d0: 61 72 72 20 64 69 6d 29 20 28 61 72 72 61 79 2d arr dim) (array- 02e0: 73 69 7a 65 20 61 72 72 29 0a 3b 3b 3b 20 28 61 size arr).;;; (a 02f0: 72 72 61 79 2d 65 71 75 61 6c 3f 20 61 72 72 31 rray-equal? arr1 0300: 20 61 72 72 32 29 0a 3b 3b 3b 20 28 73 68 61 70 arr2).;;; (shap 0310: 65 2d 66 6f 72 2d 65 61 63 68 20 73 68 70 20 70 e-for-each shp p 0320: 72 6f 63 20 5b 69 6e 64 5d 29 0a 3b 3b 3b 20 28 roc [ind]).;;; ( 0330: 61 72 72 61 79 2d 66 6f 72 2d 65 61 63 68 2d 69 array-for-each-i 0340: 6e 64 65 78 20 61 72 72 20 70 72 6f 63 20 5b 69 ndex arr proc [i 0350: 6e 64 5d 29 0a 3b 3b 3b 20 28 74 61 62 75 6c 61 nd]).;;; (tabula 0360: 74 65 2d 61 72 72 61 79 20 73 68 70 20 70 72 6f te-array shp pro 0370: 63 29 20 28 74 61 62 75 6c 61 74 65 2d 61 72 72 c) (tabulate-arr 0380: 61 79 21 20 73 68 70 20 70 72 6f 63 20 69 6e 64 ay! shp proc ind 0390: 29 0a 3b 3b 3b 20 28 61 72 72 61 79 2d 72 65 74 ).;;; (array-ret 03a0: 61 62 75 6c 61 74 65 21 20 61 72 72 20 73 68 70 abulate! arr shp 03b0: 20 70 72 6f 63 20 5b 69 6e 64 5d 29 0a 3b 3b 3b proc [ind]).;;; 03c0: 20 28 61 72 72 61 79 2d 6d 61 70 20 5b 73 68 70 (array-map [shp 03d0: 5d 20 70 72 6f 63 20 61 72 72 30 20 61 72 72 31 ] proc arr0 arr1 03e0: 20 2e 2e 2e 29 0a 3b 3b 3b 20 28 61 72 72 61 79 ...).;;; (array 03f0: 2d 6d 61 70 21 20 61 72 72 20 5b 73 68 70 5d 20 -map! arr [shp] 0400: 70 72 6f 63 20 61 72 72 30 20 61 72 72 31 20 2e proc arr0 arr1 . 0410: 2e 2e 29 0a 3b 3b 3b 20 28 61 72 72 61 79 2d 3e ..).;;; (array-> 0420: 76 65 63 74 6f 72 20 61 72 72 29 20 28 61 72 72 vector arr) (arr 0430: 61 79 2d 3e 6c 69 73 74 20 61 72 72 29 0a 3b 3b ay->list arr).;; 0440: 3b 20 28 73 68 61 72 65 2d 61 72 72 61 79 2f 70 ; (share-array/p 0450: 72 65 66 69 78 20 61 72 72 20 6b 20 2e 2e 2e 29 refix arr k ...) 0460: 20 28 73 68 61 72 65 2d 72 6f 77 20 61 72 72 20 (share-row arr 0470: 6b 29 20 28 73 68 61 72 65 2d 63 6f 6c 75 6d 6e k) (share-column 0480: 20 61 72 72 20 6b 29 0a 3b 3b 3b 20 28 73 68 61 arr k).;;; (sha 0490: 72 65 2d 61 72 72 61 79 2f 6f 72 69 67 69 6e 20 re-array/origin 04a0: 61 72 72 20 6b 20 2e 2e 2e 29 20 28 73 68 61 72 arr k ...) (shar 04b0: 65 2d 61 72 72 61 79 2f 6f 72 69 67 69 6e 20 61 e-array/origin a 04c0: 72 72 20 69 6e 64 29 0a 3b 3b 3b 20 28 61 72 72 rr ind).;;; (arr 04d0: 61 79 2d 61 70 70 65 6e 64 20 64 69 6d 20 61 72 ay-append dim ar 04e0: 72 30 20 61 72 72 31 20 2e 2e 2e 29 0a 3b 3b 3b r0 arr1 ...).;;; 04f0: 20 28 74 72 61 6e 73 70 6f 73 65 20 61 72 72 20 (transpose arr 0500: 64 69 6d 20 2e 2e 2e 29 0a 3b 3b 3b 20 28 73 68 dim ...).;;; (sh 0510: 61 72 65 2d 6e 74 68 73 20 61 72 72 20 64 69 6d are-nths arr dim 0520: 20 6e 29 0a 0a 3b 3b 3b 20 4e 61 6d 69 6e 67 20 n)..;;; Naming 0530: 70 72 6f 62 6c 65 6d 3a 20 73 68 6f 75 6c 64 20 problem: should 0540: 61 6c 6c 20 74 68 6f 73 65 20 69 6e 64 65 78 2d all those index- 0550: 6f 62 6a 65 63 74 20 75 73 69 6e 67 20 70 72 6f object using pro 0560: 63 65 64 75 72 65 73 0a 3b 3b 3b 20 62 61 6e 67 cedures.;;; bang 0570: 3f 20 54 68 65 20 6d 61 69 6e 20 61 72 67 75 6d ? The main argum 0580: 65 6e 74 2c 20 6c 69 6b 65 20 73 68 61 70 65 2c ent, like shape, 0590: 20 69 73 20 6e 6f 74 20 6d 75 74 61 74 65 64 2e is not mutated. 05a0: 0a 0a 3b 3b 3b 20 28 61 72 72 61 79 2d 73 68 61 ..;;; (array-sha 05b0: 70 65 20 61 72 72 29 0a 0a 28 64 65 66 69 6e 65 pe arr)..(define 05c0: 20 28 61 72 72 61 79 2d 73 68 61 70 65 20 61 72 (array-shape ar 05d0: 72 29 0a 20 20 28 6c 65 74 20 28 28 72 20 28 61 r). (let ((r (a 05e0: 72 72 61 79 2d 72 61 6e 6b 20 61 72 72 29 29 29 rray-rank arr))) 05f0: 0a 20 20 20 20 28 6c 65 74 20 28 28 6d 20 28 6d . (let ((m (m 0600: 61 6b 65 2d 61 72 72 61 79 20 28 73 68 61 70 65 ake-array (shape 0610: 20 30 20 72 20 30 20 32 29 29 29 29 0a 20 20 20 0 r 0 2)))). 0620: 20 20 20 28 64 6f 20 28 28 64 20 30 20 28 2b 20 (do ((d 0 (+ 0630: 64 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 28 d 1))). ( 0640: 28 3d 20 64 20 72 29 0a 20 20 20 20 20 20 20 20 (= d r). 0650: 20 6d 29 0a 20 20 20 20 20 20 20 20 28 61 72 72 m). (arr 0660: 61 79 2d 73 65 74 21 20 6d 20 64 20 30 20 28 61 ay-set! m d 0 (a 0670: 72 72 61 79 2d 73 74 61 72 74 20 61 72 72 20 64 rray-start arr d 0680: 29 29 0a 20 20 20 20 20 20 20 20 28 61 72 72 61 )). (arra 0690: 79 2d 73 65 74 21 20 6d 20 64 20 31 20 28 61 72 y-set! m d 1 (ar 06a0: 72 61 79 2d 65 6e 64 20 61 72 72 20 64 29 29 29 ray-end arr d))) 06b0: 29 29 29 0a 0a 3b 3b 3b 20 28 61 72 72 61 79 2d )))..;;; (array- 06c0: 6c 65 6e 67 74 68 20 61 72 72 20 64 69 6d 29 0a length arr dim). 06d0: 0a 28 64 65 66 69 6e 65 20 28 61 72 72 61 79 2d .(define (array- 06e0: 6c 65 6e 67 74 68 20 61 72 72 20 64 69 6d 29 0a length arr dim). 06f0: 20 20 28 2d 20 28 61 72 72 61 79 2d 65 6e 64 20 (- (array-end 0700: 61 72 72 20 64 69 6d 29 0a 20 20 20 20 20 28 61 arr dim). (a 0710: 72 72 61 79 2d 73 74 61 72 74 20 61 72 72 20 64 rray-start arr d 0720: 69 6d 29 29 29 0a 0a 3b 3b 3b 20 28 61 72 72 61 im)))..;;; (arra 0730: 79 2d 73 69 7a 65 20 61 72 72 29 0a 0a 28 64 65 y-size arr)..(de 0740: 66 69 6e 65 20 28 61 72 72 61 79 2d 73 69 7a 65 fine (array-size 0750: 20 61 72 72 29 0a 20 20 28 6c 65 74 20 28 28 72 arr). (let ((r 0760: 20 28 61 72 72 61 79 2d 72 61 6e 6b 20 61 72 72 (array-rank arr 0770: 29 29 29 0a 20 20 20 20 28 64 6f 20 28 28 6b 20 ))). (do ((k 0780: 30 20 28 2b 20 6b 20 31 29 29 0a 20 20 20 20 20 0 (+ k 1)). 0790: 20 20 20 20 28 70 20 31 20 28 2a 20 70 20 28 61 (p 1 (* p (a 07a0: 72 72 61 79 2d 6c 65 6e 67 74 68 20 61 72 72 20 rray-length arr 07b0: 6b 29 29 29 29 0a 20 20 20 20 20 20 28 28 3d 20 k)))). ((= 07c0: 6b 20 72 29 20 70 29 29 29 29 0a 0a 3b 3b 3b 20 k r) p))))..;;; 07d0: 28 61 72 72 61 79 2d 65 71 75 61 6c 3f 20 61 20 (array-equal? a 07e0: 62 29 0a 3b 3b 3b 20 63 6f 6d 70 61 72 65 73 20 b).;;; compares 07f0: 65 6c 65 6d 65 6e 74 73 20 77 69 74 68 20 65 71 elements with eq 0800: 75 61 6c 3f 20 73 6f 20 65 6c 65 6d 65 6e 74 73 ual? so elements 0810: 20 62 65 74 74 65 72 20 6e 6f 74 20 63 6f 6e 74 better not cont 0820: 61 69 6e 0a 3b 3b 3b 20 61 72 72 61 79 73 2e 0a ain.;;; arrays.. 0830: 0a 28 64 65 66 69 6e 65 20 28 61 72 72 61 79 2d .(define (array- 0840: 65 71 75 61 6c 3f 20 61 20 62 29 0a 20 20 28 6c equal? a b). (l 0850: 65 74 20 28 28 72 20 28 61 72 72 61 79 2d 72 61 et ((r (array-ra 0860: 6e 6b 20 61 29 29 29 0a 20 20 20 20 28 61 6e 64 nk a))). (and 0870: 20 28 3d 20 72 20 28 61 72 72 61 79 2d 72 61 6e (= r (array-ran 0880: 6b 20 62 29 29 0a 20 20 20 20 20 20 20 20 20 28 k b)). ( 0890: 61 6e 64 20 28 64 6f 20 28 28 6b 20 30 20 28 2b and (do ((k 0 (+ 08a0: 20 6b 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 k 1)). 08b0: 20 20 20 20 20 20 20 20 20 20 28 74 72 75 65 20 (true 08c0: 23 74 20 28 61 6e 64 20 74 72 75 65 0a 20 20 20 #t (and true. 08d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 08e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 3d (= 08f0: 20 28 61 72 72 61 79 2d 73 74 61 72 74 20 61 20 (array-start a 0900: 6b 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 k). 0910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0920: 20 20 20 20 20 20 20 28 61 72 72 61 79 2d 73 74 (array-st 0930: 61 72 74 20 62 20 6b 29 29 0a 20 20 20 20 20 20 art b k)). 0940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0950: 20 20 20 20 20 20 20 20 20 20 20 28 3d 20 28 61 (= (a 0960: 72 72 61 79 2d 65 6e 64 20 61 20 6b 29 0a 20 20 rray-end a k). 0970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0990: 20 20 28 61 72 72 61 79 2d 65 6e 64 20 62 20 6b (array-end b k 09a0: 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ))))). 09b0: 20 20 20 20 20 20 28 28 3d 20 6b 20 72 29 20 74 ((= k r) t 09c0: 72 75 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 rue)). 09d0: 20 20 20 20 28 6c 65 74 20 28 28 6b 73 20 28 6d (let ((ks (m 09e0: 61 6b 65 2d 76 65 63 74 6f 72 20 72 20 30 29 29 ake-vector r 0)) 09f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 0a00: 20 20 28 6c 65 74 20 77 6f 6b 20 28 28 64 20 30 (let wok ((d 0 0a10: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 0a20: 20 20 20 20 20 28 69 66 20 28 3c 20 64 20 72 29 (if (< d r) 0a30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 0a40: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 65 20 (let ((e 0a50: 28 61 72 72 61 79 2d 65 6e 64 20 61 20 64 29 29 (array-end a d)) 0a60: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 0a70: 20 20 20 20 20 20 20 20 20 20 28 64 6f 20 28 28 (do (( 0a80: 6b 20 28 61 72 72 61 79 2d 73 74 61 72 74 20 61 k (array-start a 0a90: 20 64 29 20 28 2b 20 6b 20 31 29 29 0a 20 20 20 d) (+ k 1)). 0aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0ab0: 20 20 20 20 20 20 20 20 20 20 28 74 72 75 65 20 (true 0ac0: 23 74 20 28 61 6e 64 20 74 72 75 65 20 28 77 6f #t (and true (wo 0ad0: 6b 20 28 2b 20 64 20 31 29 29 29 29 29 0a 20 20 k (+ d 1))))). 0ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0af0: 20 20 20 20 20 20 20 20 28 28 3d 20 6b 20 65 29 ((= k e) 0b00: 20 74 72 75 65 29 0a 20 20 20 20 20 20 20 20 20 true). 0b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0b20: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 6b 73 (vector-set! ks 0b30: 20 64 20 6b 29 29 29 0a 20 20 20 20 20 20 20 20 d k))). 0b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e 0b50: 71 75 61 6c 3f 20 28 61 72 72 61 79 2d 72 65 66 qual? (array-ref 0b60: 20 61 20 6b 73 29 0a 20 20 20 20 20 20 20 20 20 a ks). 0b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0b80: 20 20 20 20 20 28 61 72 72 61 79 2d 72 65 66 20 (array-ref 0b90: 62 20 6b 73 29 29 29 29 29 29 29 29 29 0a 0a 3b b ks)))))))))..; 0ba0: 3b 3b 20 28 73 68 61 70 65 2d 66 6f 72 2d 65 61 ;; (shape-for-ea 0bb0: 63 68 20 73 68 70 20 70 72 6f 63 20 5b 69 6e 64 ch shp proc [ind 0bc0: 65 78 2d 6f 62 6a 65 63 74 5d 29 0a 3b 3b 3b 20 ex-object]).;;; 0bd0: 70 61 73 73 65 73 20 65 61 63 68 20 69 6e 64 65 passes each inde 0be0: 78 20 69 6e 20 73 68 61 70 65 20 74 6f 20 70 72 x in shape to pr 0bf0: 6f 63 20 69 6e 20 72 6f 77 2d 6d 61 6a 6f 72 20 oc in row-major 0c00: 6f 72 64 65 72 64 2c 20 75 73 69 6e 67 0a 3b 3b orderd, using.;; 0c10: 3b 20 69 6e 64 65 78 2d 6f 62 6a 65 63 74 20 69 ; index-object i 0c20: 66 20 70 72 6f 76 69 64 65 64 2e 0a 0a 28 64 65 f provided...(de 0c30: 66 69 6e 65 20 28 73 68 61 70 65 2d 66 6f 72 2d fine (shape-for- 0c40: 65 61 63 68 20 73 68 70 20 70 72 6f 63 20 2e 20 each shp proc . 0c50: 6f 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 o). (if (null? 0c60: 6f 29 0a 20 20 20 20 20 20 28 61 72 72 61 79 3a o). (array: 0c70: 61 72 6c 69 62 3a 73 68 61 70 65 2d 66 6f 72 2d arlib:shape-for- 0c80: 65 61 63 68 2f 61 72 67 75 6d 65 6e 74 73 20 73 each/arguments s 0c90: 68 70 20 70 72 6f 63 29 0a 20 20 20 20 20 20 28 hp proc). ( 0ca0: 69 66 20 28 76 65 63 74 6f 72 3f 20 28 63 61 72 if (vector? (car 0cb0: 20 6f 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 o)). ( 0cc0: 61 72 72 61 79 3a 61 72 6c 69 62 3a 73 68 61 70 array:arlib:shap 0cd0: 65 2d 66 6f 72 2d 65 61 63 68 2f 76 65 63 74 6f e-for-each/vecto 0ce0: 72 20 73 68 70 20 70 72 6f 63 20 28 63 61 72 20 r shp proc (car 0cf0: 6f 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 61 o)). (a 0d00: 72 72 61 79 3a 61 72 6c 69 62 3a 73 68 61 70 65 rray:arlib:shape 0d10: 2d 66 6f 72 2d 65 61 63 68 2f 61 72 72 61 79 20 -for-each/array 0d20: 73 68 70 20 70 72 6f 63 20 28 63 61 72 20 6f 29 shp proc (car o) 0d30: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 ))))..(define (a 0d40: 72 72 61 79 3a 61 72 6c 69 62 3a 73 68 61 70 65 rray:arlib:shape 0d50: 2d 66 6f 72 2d 65 61 63 68 2f 61 72 67 75 6d 65 -for-each/argume 0d60: 6e 74 73 20 73 68 70 20 70 72 6f 63 29 0a 20 20 nts shp proc). 0d70: 28 6c 65 74 20 28 28 72 20 28 61 72 72 61 79 2d (let ((r (array- 0d80: 65 6e 64 20 73 68 70 20 30 29 29 29 0a 20 20 20 end shp 0))). 0d90: 20 28 6c 65 74 20 28 28 76 65 63 20 28 6d 61 6b (let ((vec (mak 0da0: 65 2d 76 65 63 74 6f 72 20 72 29 29 29 0a 20 20 e-vector r))). 0db0: 20 20 20 20 28 6c 65 74 20 64 6f 2d 64 69 6d 20 (let do-dim 0dc0: 28 28 64 20 30 29 29 0a 20 20 20 20 20 20 20 20 ((d 0)). 0dd0: 28 69 66 20 28 3d 20 64 20 72 29 0a 20 20 20 20 (if (= d r). 0de0: 20 20 20 20 20 20 20 20 28 61 72 72 61 79 3a 61 (array:a 0df0: 70 70 6c 79 2d 74 6f 2d 76 65 63 74 6f 72 20 72 pply-to-vector r 0e00: 20 70 72 6f 63 20 76 65 63 29 0a 20 20 20 20 20 proc vec). 0e10: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 65 20 (let ((e 0e20: 28 61 72 72 61 79 2d 72 65 66 20 73 68 70 20 64 (array-ref shp d 0e30: 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 1))). 0e40: 20 20 20 20 28 64 6f 20 28 28 6b 20 28 61 72 72 (do ((k (arr 0e50: 61 79 2d 72 65 66 20 73 68 70 20 64 20 30 29 20 ay-ref shp d 0) 0e60: 28 2b 20 6b 20 31 29 29 29 0a 20 20 20 20 20 20 (+ k 1))). 0e70: 20 20 20 20 20 20 20 20 20 20 28 28 3d 20 6b 20 ((= k 0e80: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e)). 0e90: 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 (vector-set! 0ea0: 20 76 65 63 20 64 20 6b 29 0a 20 20 20 20 20 20 vec d k). 0eb0: 20 20 20 20 20 20 20 20 20 20 28 64 6f 2d 64 69 (do-di 0ec0: 6d 20 28 2b 20 64 20 31 29 29 29 29 29 29 29 29 m (+ d 1)))))))) 0ed0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 72 72 61 )..(define (arra 0ee0: 79 3a 61 72 6c 69 62 3a 73 68 61 70 65 2d 66 6f y:arlib:shape-fo 0ef0: 72 2d 65 61 63 68 2f 76 65 63 74 6f 72 20 73 68 r-each/vector sh 0f00: 70 20 70 72 6f 63 20 76 65 63 29 0a 20 20 28 6c p proc vec). (l 0f10: 65 74 20 28 28 72 20 28 61 72 72 61 79 2d 65 6e et ((r (array-en 0f20: 64 20 73 68 70 20 30 29 29 29 0a 20 20 20 20 28 d shp 0))). ( 0f30: 6c 65 74 20 64 6f 2d 64 69 6d 20 28 28 64 20 30 let do-dim ((d 0 0f40: 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 3d 20 )). (if (= 0f50: 64 20 72 29 0a 20 20 20 20 20 20 20 20 20 20 28 d r). ( 0f60: 70 72 6f 63 20 76 65 63 29 0a 20 20 20 20 20 20 proc vec). 0f70: 20 20 20 20 28 6c 65 74 20 28 28 65 20 28 61 72 (let ((e (ar 0f80: 72 61 79 2d 72 65 66 20 73 68 70 20 64 20 31 29 ray-ref shp d 1) 0f90: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). ( 0fa0: 64 6f 20 28 28 6b 20 28 61 72 72 61 79 2d 72 65 do ((k (array-re 0fb0: 66 20 73 68 70 20 64 20 30 29 20 28 2b 20 6b 20 f shp d 0) (+ k 0fc0: 31 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 1))). 0fd0: 20 20 20 28 28 3d 20 6b 20 65 29 29 0a 20 20 20 ((= k e)). 0fe0: 20 20 20 20 20 20 20 20 20 20 20 28 76 65 63 74 (vect 0ff0: 6f 72 2d 73 65 74 21 20 76 65 63 20 64 20 6b 29 or-set! vec d k) 1000: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . ( 1010: 64 6f 2d 64 69 6d 20 28 2b 20 64 20 31 29 29 29 do-dim (+ d 1))) 1020: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define ( 1030: 61 72 72 61 79 3a 61 72 6c 69 62 3a 73 68 61 70 array:arlib:shap 1040: 65 2d 66 6f 72 2d 65 61 63 68 2f 61 72 72 61 79 e-for-each/array 1050: 20 73 68 70 20 70 72 6f 63 20 61 72 72 29 0a 20 shp proc arr). 1060: 20 3b 3b 20 61 72 72 20 69 73 20 6e 6f 74 20 76 ;; arr is not v 1070: 65 63 74 6f 72 0a 20 20 28 6c 65 74 20 28 28 72 ector. (let ((r 1080: 20 28 61 72 72 61 79 2d 65 6e 64 20 73 68 70 20 (array-end shp 1090: 30 29 29 29 0a 20 20 20 20 28 6c 65 74 20 64 6f 0))). (let do 10a0: 2d 64 69 6d 20 28 28 64 20 30 29 29 0a 20 20 20 -dim ((d 0)). 10b0: 20 20 20 28 69 66 20 28 3d 20 64 20 72 29 0a 20 (if (= d r). 10c0: 20 20 20 20 20 20 20 20 20 28 70 72 6f 63 20 61 (proc a 10d0: 72 72 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c rr). (l 10e0: 65 74 20 28 28 65 20 28 61 72 72 61 79 2d 72 65 et ((e (array-re 10f0: 66 20 73 68 70 20 64 20 31 29 29 29 0a 20 20 20 f shp d 1))). 1100: 20 20 20 20 20 20 20 20 20 28 64 6f 20 28 28 6b (do ((k 1110: 20 28 61 72 72 61 79 2d 72 65 66 20 73 68 70 20 (array-ref shp 1120: 64 20 30 29 20 28 2b 20 6b 20 31 29 29 29 0a 20 d 0) (+ k 1))). 1130: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 3d ((= 1140: 20 6b 20 65 29 29 0a 20 20 20 20 20 20 20 20 20 k e)). 1150: 20 20 20 20 20 28 61 72 72 61 79 2d 73 65 74 21 (array-set! 1160: 20 61 72 72 20 64 20 6b 29 0a 20 20 20 20 20 20 arr d k). 1170: 20 20 20 20 20 20 20 20 28 64 6f 2d 64 69 6d 20 (do-dim 1180: 28 2b 20 64 20 31 29 29 29 29 29 29 29 29 0a 0a (+ d 1)))))))).. 1190: 3b 3b 3b 20 28 61 72 72 61 79 2d 66 6f 72 2d 65 ;;; (array-for-e 11a0: 61 63 68 2d 69 6e 64 65 78 20 61 72 72 20 70 72 ach-index arr pr 11b0: 6f 63 20 5b 69 6e 64 5d 29 0a 3b 3b 3b 20 69 73 oc [ind]).;;; is 11c0: 20 65 71 75 69 76 61 6c 65 6e 74 20 74 6f 0a 3b equivalent to.; 11d0: 3b 3b 0a 3b 3b 3b 20 20 20 28 73 68 61 70 65 2d ;;.;;; (shape- 11e0: 66 6f 72 2d 65 61 63 68 2d 69 6e 64 65 78 20 28 for-each-index ( 11f0: 61 72 72 61 79 2d 73 68 61 70 65 20 61 72 72 29 array-shape arr) 1200: 20 70 72 6f 63 20 5b 69 6e 64 5d 29 0a 3b 3b 3b proc [ind]).;;; 1210: 0a 3b 3b 3b 20 62 75 74 20 69 73 20 69 6d 70 6c .;;; but is impl 1220: 65 6d 65 6e 74 65 64 20 77 69 74 68 6f 75 74 20 emented without 1230: 61 6c 6c 6f 63 61 74 69 6f 6e 20 6f 66 20 74 68 allocation of th 1240: 65 20 73 68 61 70 65 2c 20 74 6f 20 70 72 6f 76 e shape, to prov 1250: 65 0a 3b 3b 3b 20 74 68 61 74 20 69 74 20 63 61 e.;;; that it ca 1260: 6e 20 62 65 20 73 6f 20 69 6d 70 6c 65 6d 65 6e n be so implemen 1270: 74 65 64 2e 0a 0a 28 64 65 66 69 6e 65 20 28 61 ted...(define (a 1280: 72 72 61 79 2d 66 6f 72 2d 65 61 63 68 2d 69 6e rray-for-each-in 1290: 64 65 78 20 61 72 72 20 70 72 6f 63 20 2e 20 6f dex arr proc . o 12a0: 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6f ). (if (null? o 12b0: 29 0a 20 20 20 20 20 20 28 61 72 72 61 79 3a 61 ). (array:a 12c0: 72 6c 69 62 3a 61 72 72 61 79 2d 66 6f 72 2d 65 rlib:array-for-e 12d0: 61 63 68 2d 69 6e 64 65 78 2f 61 72 67 75 6d 65 ach-index/argume 12e0: 6e 74 73 20 61 72 72 20 70 72 6f 63 29 0a 20 20 nts arr proc). 12f0: 20 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f (if (vector? 1300: 20 28 63 61 72 20 6f 29 29 0a 20 20 20 20 20 20 (car o)). 1310: 20 20 20 20 28 61 72 72 61 79 3a 61 72 6c 69 62 (array:arlib 1320: 3a 61 72 72 61 79 2d 66 6f 72 2d 65 61 63 68 2d :array-for-each- 1330: 69 6e 64 65 78 2f 76 65 63 74 6f 72 20 61 72 72 index/vector arr 1340: 20 70 72 6f 63 20 28 63 61 72 20 6f 29 29 0a 20 proc (car o)). 1350: 20 20 20 20 20 20 20 20 20 28 61 72 72 61 79 3a (array: 1360: 61 72 6c 69 62 3a 61 72 72 61 79 2d 66 6f 72 2d arlib:array-for- 1370: 65 61 63 68 2d 69 6e 64 65 78 2f 61 72 72 61 79 each-index/array 1380: 20 61 72 72 20 70 72 6f 63 20 28 63 61 72 20 6f arr proc (car o 1390: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define ( 13a0: 61 72 72 61 79 3a 61 72 6c 69 62 3a 61 72 72 61 array:arlib:arra 13b0: 79 2d 66 6f 72 2d 65 61 63 68 2d 69 6e 64 65 78 y-for-each-index 13c0: 2f 61 72 67 75 6d 65 6e 74 73 20 61 72 72 20 70 /arguments arr p 13d0: 72 6f 63 29 0a 20 20 28 6c 65 74 20 28 28 72 20 roc). (let ((r 13e0: 28 61 72 72 61 79 2d 72 61 6e 6b 20 61 72 72 29 (array-rank arr) 13f0: 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 76 65 )). (let ((ve 1400: 63 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 72 c (make-vector r 1410: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 61 70 )). (ap 1420: 70 6c 79 20 28 61 72 72 61 79 3a 61 70 70 6c 69 ply (array:appli 1430: 65 72 2d 74 6f 2d 76 65 63 74 6f 72 20 72 29 29 er-to-vector r)) 1440: 29 0a 20 20 20 20 20 20 28 6c 65 74 20 64 6f 2d ). (let do- 1450: 64 69 6d 20 28 28 64 20 30 29 29 0a 20 20 20 20 dim ((d 0)). 1460: 20 20 20 20 28 69 66 20 28 3d 20 64 20 72 29 0a (if (= d r). 1470: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 (app 1480: 6c 79 20 70 72 6f 63 20 76 65 63 29 0a 20 20 20 ly proc vec). 1490: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let (( 14a0: 65 20 28 61 72 72 61 79 2d 65 6e 64 20 61 72 72 e (array-end arr 14b0: 20 64 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 d))). 14c0: 20 20 20 20 28 64 6f 20 28 28 6b 20 28 61 72 72 (do ((k (arr 14d0: 61 79 2d 73 74 61 72 74 20 61 72 72 20 64 29 20 ay-start arr d) 14e0: 28 2b 20 6b 20 31 29 29 29 0a 20 20 20 20 20 20 (+ k 1))). 14f0: 20 20 20 20 20 20 20 20 20 20 28 28 3d 20 6b 20 ((= k 1500: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e)). 1510: 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 (vector-set! 1520: 20 76 65 63 20 64 20 6b 29 0a 20 20 20 20 20 20 vec d k). 1530: 20 20 20 20 20 20 20 20 20 20 28 64 6f 2d 64 69 (do-di 1540: 6d 20 28 2b 20 64 20 31 29 29 29 29 29 29 29 29 m (+ d 1)))))))) 1550: 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 72 72 61 )..(define (arra 1560: 79 3a 61 72 6c 69 62 3a 61 72 72 61 79 2d 66 6f y:arlib:array-fo 1570: 72 2d 65 61 63 68 2d 69 6e 64 65 78 2f 76 65 63 r-each-index/vec 1580: 74 6f 72 20 61 72 72 20 70 72 6f 63 20 69 6e 64 tor arr proc ind 1590: 29 0a 20 20 3b 3b 20 69 6e 64 20 69 73 20 61 20 ). ;; ind is a 15a0: 76 65 63 74 6f 72 0a 20 20 28 6c 65 74 20 28 28 vector. (let (( 15b0: 72 20 28 61 72 72 61 79 2d 72 61 6e 6b 20 61 72 r (array-rank ar 15c0: 72 29 29 29 0a 20 20 20 20 28 6c 65 74 20 64 6f r))). (let do 15d0: 2d 64 69 6d 20 28 28 64 20 30 29 29 0a 20 20 20 -dim ((d 0)). 15e0: 20 20 20 28 69 66 20 28 3d 20 64 20 72 29 0a 20 (if (= d r). 15f0: 20 20 20 20 20 20 20 20 20 28 70 72 6f 63 20 69 (proc i 1600: 6e 64 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c nd). (l 1610: 65 74 20 28 28 65 20 28 61 72 72 61 79 2d 65 6e et ((e (array-en 1620: 64 20 61 72 72 20 64 29 29 29 0a 20 20 20 20 20 d arr d))). 1630: 20 20 20 20 20 20 20 28 64 6f 20 28 28 6b 20 28 (do ((k ( 1640: 61 72 72 61 79 2d 73 74 61 72 74 20 61 72 72 20 array-start arr 1650: 64 29 20 28 2b 20 6b 20 31 29 29 29 0a 20 20 20 d) (+ k 1))). 1660: 20 20 20 20 20 20 20 20 20 20 20 28 28 3d 20 6b ((= k 1670: 20 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 e)). 1680: 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 (vector-set! 1690: 69 6e 64 20 64 20 6b 29 0a 20 20 20 20 20 20 20 ind d k). 16a0: 20 20 20 20 20 20 20 28 64 6f 2d 64 69 6d 20 28 (do-dim ( 16b0: 2b 20 64 20 31 29 29 29 29 29 29 29 29 0a 0a 28 + d 1))))))))..( 16c0: 64 65 66 69 6e 65 20 28 61 72 72 61 79 3a 61 72 define (array:ar 16d0: 6c 69 62 3a 61 72 72 61 79 2d 66 6f 72 2d 65 61 lib:array-for-ea 16e0: 63 68 2d 69 6e 64 65 78 2f 61 72 72 61 79 20 61 ch-index/array a 16f0: 72 72 20 70 72 6f 63 20 69 6e 64 29 0a 20 20 3b rr proc ind). ; 1700: 3b 20 69 6e 64 20 69 73 20 61 6e 20 61 72 72 61 ; ind is an arra 1710: 79 20 62 75 74 20 6e 6f 74 20 61 20 76 65 63 74 y but not a vect 1720: 6f 72 0a 20 20 28 6c 65 74 20 28 28 72 20 28 61 or. (let ((r (a 1730: 72 72 61 79 2d 72 61 6e 6b 20 61 72 72 29 29 29 rray-rank arr))) 1740: 0a 20 20 20 20 28 6c 65 74 20 64 6f 2d 64 69 6d . (let do-dim 1750: 20 28 28 64 20 30 29 29 0a 20 20 20 20 20 20 28 ((d 0)). ( 1760: 69 66 20 28 3d 20 64 20 72 29 0a 20 20 20 20 20 if (= d r). 1770: 20 20 20 20 20 28 70 72 6f 63 20 69 6e 64 29 0a (proc ind). 1780: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let ( 1790: 28 65 20 28 61 72 72 61 79 2d 65 6e 64 20 61 72 (e (array-end ar 17a0: 72 20 64 29 29 29 0a 20 20 20 20 20 20 20 20 20 r d))). 17b0: 20 20 20 28 64 6f 20 28 28 6b 20 28 61 72 72 61 (do ((k (arra 17c0: 79 2d 73 74 61 72 74 20 61 72 72 20 64 29 20 28 y-start arr d) ( 17d0: 2b 20 6b 20 31 29 29 29 0a 20 20 20 20 20 20 20 + k 1))). 17e0: 20 20 20 20 20 20 20 28 28 3d 20 6b 20 65 29 29 ((= k e)) 17f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . ( 1800: 61 72 72 61 79 2d 73 65 74 21 20 69 6e 64 20 64 array-set! ind d 1810: 20 6b 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 k). 1820: 20 20 28 64 6f 2d 64 69 6d 20 28 2b 20 64 20 31 (do-dim (+ d 1 1830: 29 29 29 29 29 29 29 29 0a 0a 3b 3b 3b 20 28 74 ))))))))..;;; (t 1840: 61 62 75 6c 61 74 65 2d 61 72 72 61 79 20 73 68 abulate-array sh 1850: 70 20 70 72 6f 63 29 0a 3b 3b 3b 20 28 74 61 62 p proc).;;; (tab 1860: 75 6c 61 74 65 2d 61 72 72 61 79 21 20 73 68 70 ulate-array! shp 1870: 20 70 72 6f 63 20 69 6e 64 29 0a 3b 3b 3b 20 72 proc ind).;;; r 1880: 65 74 75 72 6e 73 20 61 20 6e 65 77 6c 79 20 61 eturns a newly a 1890: 6c 6c 6f 63 61 74 65 64 20 61 72 72 61 79 20 6f llocated array o 18a0: 66 20 74 68 65 20 67 69 76 65 6e 20 73 68 61 70 f the given shap 18b0: 65 20 77 69 74 68 20 69 6e 69 74 69 61 6c 0a 3b e with initial.; 18c0: 3b 3b 20 63 6f 6e 74 65 6e 74 73 20 61 74 20 65 ;; contents at e 18d0: 61 63 68 20 69 6e 64 65 78 20 77 68 61 74 65 76 ach index whatev 18e0: 65 72 20 70 72 6f 63 20 72 65 74 75 72 6e 73 20 er proc returns 18f0: 67 69 76 65 6e 20 74 68 65 20 69 6e 64 69 63 65 given the indice 1900: 73 2e 0a 3b 3b 3b 20 54 68 65 20 6c 61 74 74 65 s..;;; The latte 1910: 72 20 70 72 6f 63 65 64 75 72 65 20 72 65 75 73 r procedure reus 1920: 65 73 20 69 6e 64 20 66 6f 72 20 70 61 63 6b 61 es ind for packa 1930: 67 65 20 6f 66 20 69 6e 64 69 63 65 73 2e 0a 0a ge of indices... 1940: 28 64 65 66 69 6e 65 20 28 74 61 62 75 6c 61 74 (define (tabulat 1950: 65 2d 61 72 72 61 79 20 73 68 70 20 70 72 6f 63 e-array shp proc 1960: 29 0a 20 20 28 6c 65 74 20 28 28 61 72 72 20 28 ). (let ((arr ( 1970: 6d 61 6b 65 2d 61 72 72 61 79 20 73 68 70 29 29 make-array shp)) 1980: 29 0a 20 20 20 20 28 61 72 72 61 79 3a 61 72 6c ). (array:arl 1990: 69 62 3a 73 68 61 70 65 2d 66 6f 72 2d 65 61 63 ib:shape-for-eac 19a0: 68 2f 76 65 63 74 6f 72 0a 20 20 20 20 20 73 68 h/vector. sh 19b0: 70 0a 20 20 20 20 20 28 6c 65 74 20 28 28 61 70 p. (let ((ap 19c0: 70 6c 79 20 28 61 72 72 61 79 3a 61 70 70 6c 69 ply (array:appli 19d0: 65 72 2d 74 6f 2d 76 65 63 74 6f 72 20 28 61 72 er-to-vector (ar 19e0: 72 61 79 2d 65 6e 64 20 73 68 70 20 30 29 29 29 ray-end shp 0))) 19f0: 29 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 ). (lambda 1a00: 20 28 69 78 29 20 28 61 72 72 61 79 2d 73 65 74 (ix) (array-set 1a10: 21 20 61 72 72 20 69 78 20 28 61 70 70 6c 79 20 ! arr ix (apply 1a20: 70 72 6f 63 20 69 78 29 29 29 29 0a 20 20 20 20 proc ix)))). 1a30: 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 28 61 (make-vector (a 1a40: 72 72 61 79 2d 65 6e 64 20 73 68 70 20 30 29 29 rray-end shp 0)) 1a50: 29 0a 20 20 20 20 61 72 72 29 29 0a 20 20 20 20 ). arr)). 1a60: 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 74 61 .(define (ta 1a70: 62 75 6c 61 74 65 2d 61 72 72 61 79 21 20 73 68 bulate-array! sh 1a80: 70 20 70 72 6f 63 20 69 6e 64 29 0a 20 20 28 6c p proc ind). (l 1a90: 65 74 20 28 28 61 72 72 20 28 6d 61 6b 65 2d 61 et ((arr (make-a 1aa0: 72 72 61 79 20 73 68 70 29 29 29 0a 20 20 20 20 rray shp))). 1ab0: 28 69 66 20 28 76 65 63 74 6f 72 3f 20 69 6e 64 (if (vector? ind 1ac0: 29 0a 20 20 20 20 20 20 20 20 28 61 72 72 61 79 ). (array 1ad0: 3a 61 72 6c 69 62 3a 73 68 61 70 65 2d 66 6f 72 :arlib:shape-for 1ae0: 2d 65 61 63 68 2f 76 65 63 74 6f 72 0a 20 20 20 -each/vector. 1af0: 20 20 20 20 20 20 73 68 70 0a 20 20 20 20 20 20 shp. 1b00: 20 20 20 28 6c 61 6d 62 64 61 20 28 69 78 29 20 (lambda (ix) 1b10: 28 61 72 72 61 79 2d 73 65 74 21 20 61 72 72 20 (array-set! arr 1b20: 69 78 20 28 70 72 6f 63 20 69 78 29 29 29 0a 20 ix (proc ix))). 1b30: 20 20 20 20 20 20 20 20 69 6e 64 29 0a 20 20 20 ind). 1b40: 20 20 20 20 20 28 61 72 72 61 79 3a 61 72 6c 69 (array:arli 1b50: 62 3a 73 68 61 70 65 2d 66 6f 72 2d 65 61 63 68 b:shape-for-each 1b60: 2f 61 72 72 61 79 0a 20 20 20 20 20 20 20 20 20 /array. 1b70: 73 68 70 0a 20 20 20 20 20 20 20 20 20 28 6c 61 shp. (la 1b80: 6d 62 64 61 20 28 69 78 29 20 28 61 72 72 61 79 mbda (ix) (array 1b90: 2d 73 65 74 21 20 61 72 72 20 69 78 20 28 70 72 -set! arr ix (pr 1ba0: 6f 63 20 69 78 29 29 29 0a 20 20 20 20 20 20 20 oc ix))). 1bb0: 20 20 69 6e 64 29 29 0a 20 20 20 20 61 72 72 29 ind)). arr) 1bc0: 29 0a 0a 3b 3b 3b 20 28 61 72 72 61 79 2d 72 65 )..;;; (array-re 1bd0: 74 61 62 75 6c 61 74 65 21 20 61 72 72 20 73 68 tabulate! arr sh 1be0: 70 20 70 72 6f 63 20 5b 69 6e 64 65 78 2d 6f 62 p proc [index-ob 1bf0: 6a 65 63 74 5d 29 0a 3b 3b 3b 20 73 65 74 73 20 ject]).;;; sets 1c00: 74 68 65 20 65 6c 65 6d 65 6e 74 73 20 6f 66 20 the elements of 1c10: 61 72 72 20 69 6e 20 73 68 61 70 65 20 74 6f 20 arr in shape to 1c20: 74 68 65 20 76 61 6c 75 65 20 6f 66 20 70 72 6f the value of pro 1c30: 63 20 61 74 20 74 68 61 74 0a 3b 3b 3b 20 69 6e c at that.;;; in 1c40: 64 65 78 2c 20 75 73 69 6e 67 20 69 6e 64 65 78 dex, using index 1c50: 2d 6f 62 6a 65 63 74 20 69 66 20 70 72 6f 76 69 -object if provi 1c60: 64 65 64 2e 0a 0a 28 64 65 66 69 6e 65 20 28 61 ded...(define (a 1c70: 72 72 61 79 2d 72 65 74 61 62 75 6c 61 74 65 21 rray-retabulate! 1c80: 20 61 72 72 20 73 68 70 20 70 72 6f 63 20 2e 20 arr shp proc . 1c90: 6f 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 o). (if (null? 1ca0: 6f 29 0a 20 20 20 20 20 20 28 61 72 72 61 79 3a o). (array: 1cb0: 61 72 6c 69 62 3a 73 68 61 70 65 2d 66 6f 72 2d arlib:shape-for- 1cc0: 65 61 63 68 2f 76 65 63 74 6f 72 0a 20 20 20 20 each/vector. 1cd0: 20 20 20 73 68 70 0a 20 20 20 20 20 20 20 28 6c shp. (l 1ce0: 65 74 20 28 28 61 70 70 6c 79 20 28 61 72 72 61 et ((apply (arra 1cf0: 79 3a 61 70 70 6c 69 65 72 2d 74 6f 2d 76 65 63 y:applier-to-vec 1d00: 74 6f 72 20 28 61 72 72 61 79 2d 65 6e 64 20 73 tor (array-end s 1d10: 68 70 20 30 29 29 29 29 0a 20 20 20 20 20 20 20 hp 0)))). 1d20: 20 20 28 6c 61 6d 62 64 61 20 28 69 78 29 0a 20 (lambda (ix). 1d30: 20 20 20 20 20 20 20 20 20 20 28 61 72 72 61 79 (array 1d40: 2d 73 65 74 21 20 61 72 72 20 69 78 20 28 61 70 -set! arr ix (ap 1d50: 70 6c 79 20 70 72 6f 63 20 69 78 29 29 29 29 0a ply proc ix)))). 1d60: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 76 65 63 (make-vec 1d70: 74 6f 72 20 28 61 72 72 61 79 2d 65 6e 64 20 73 tor (array-end s 1d80: 68 70 20 30 29 29 29 0a 20 20 20 20 20 20 28 69 hp 0))). (i 1d90: 66 20 28 76 65 63 74 6f 72 3f 20 28 63 61 72 20 f (vector? (car 1da0: 6f 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 61 o)). (a 1db0: 72 72 61 79 3a 61 72 6c 69 62 3a 73 68 61 70 65 rray:arlib:shape 1dc0: 2d 66 6f 72 2d 65 61 63 68 2f 76 65 63 74 6f 72 -for-each/vector 1dd0: 0a 20 20 20 20 20 20 20 20 20 20 20 73 68 70 0a . shp. 1de0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 (lamb 1df0: 64 61 20 28 69 78 29 0a 20 20 20 20 20 20 20 20 da (ix). 1e00: 20 20 20 20 20 28 61 72 72 61 79 2d 73 65 74 21 (array-set! 1e10: 20 61 72 72 20 69 78 20 28 70 72 6f 63 20 69 78 arr ix (proc ix 1e20: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 ))). ( 1e30: 63 61 72 20 6f 29 29 0a 20 20 20 20 20 20 20 20 car o)). 1e40: 20 20 28 61 72 72 61 79 3a 61 72 6c 69 62 3a 73 (array:arlib:s 1e50: 68 61 70 65 2d 66 6f 72 2d 65 61 63 68 2f 61 72 hape-for-each/ar 1e60: 72 61 79 0a 20 20 20 20 20 20 20 20 20 20 20 73 ray. s 1e70: 68 70 0a 20 20 20 20 20 20 20 20 20 20 20 28 6c hp. (l 1e80: 61 6d 62 64 61 20 28 69 78 29 0a 20 20 20 20 20 ambda (ix). 1e90: 20 20 20 20 20 20 20 20 28 61 72 72 61 79 2d 73 (array-s 1ea0: 65 74 21 20 61 72 72 20 69 78 20 28 70 72 6f 63 et! arr ix (proc 1eb0: 20 69 78 29 29 29 0a 20 20 20 20 20 20 20 20 20 ix))). 1ec0: 20 20 28 63 61 72 20 6f 29 29 29 29 29 0a 0a 3b (car o)))))..; 1ed0: 3b 3b 20 28 61 72 72 61 79 2d 6d 61 70 21 20 61 ;; (array-map! a 1ee0: 72 72 61 79 20 5b 73 68 61 70 65 5d 20 70 72 6f rray [shape] pro 1ef0: 63 20 61 72 72 61 79 30 20 61 72 72 61 79 31 2e c array0 array1. 1f00: 2e 2e 29 0a 3b 3b 3b 20 73 74 6f 72 65 73 20 74 ..).;;; stores t 1f10: 6f 20 74 68 65 20 65 6c 65 6d 65 6e 74 73 20 6f o the elements o 1f20: 66 20 61 72 72 61 79 20 28 69 6e 20 73 68 61 70 f array (in shap 1f30: 65 29 20 74 68 65 20 76 61 6c 75 65 73 20 6f 66 e) the values of 1f40: 20 70 72 6f 63 20 61 74 0a 3b 3b 3b 20 74 68 65 proc at.;;; the 1f50: 20 63 6f 6e 74 65 6e 74 73 20 6f 66 20 61 72 72 contents of arr 1f60: 61 79 6b 20 61 74 20 63 6f 72 72 65 73 70 6f 6e ayk at correspon 1f70: 64 69 6e 67 20 69 6e 64 65 78 2e 0a 0a 28 64 65 ding index...(de 1f80: 66 69 6e 65 20 28 61 72 72 61 79 2d 6d 61 70 21 fine (array-map! 1f90: 20 61 72 72 20 78 20 79 20 2e 20 6f 29 0a 20 20 arr x y . o). 1fa0: 28 69 66 20 28 61 72 72 61 79 3a 61 72 72 61 79 (if (array:array 1fb0: 3f 20 78 29 0a 20 20 20 20 20 20 28 61 72 72 61 ? x). (arra 1fc0: 79 3a 61 72 6c 69 62 3a 6d 61 70 21 20 61 72 72 y:arlib:map! arr 1fd0: 20 78 20 79 20 28 61 70 70 6c 79 20 76 65 63 74 x y (apply vect 1fe0: 6f 72 20 6f 29 29 0a 20 20 20 20 20 20 28 61 72 or o)). (ar 1ff0: 72 61 79 3a 61 72 6c 69 62 3a 6d 61 70 21 20 61 ray:arlib:map! a 2000: 72 72 20 28 61 72 72 61 79 2d 73 68 61 70 65 20 rr (array-shape 2010: 61 72 72 29 20 78 20 28 61 70 70 6c 79 20 76 65 arr) x (apply ve 2020: 63 74 6f 72 20 79 20 6f 29 29 29 29 0a 0a 28 64 ctor y o))))..(d 2030: 65 66 69 6e 65 20 28 61 72 72 61 79 3a 61 72 6c efine (array:arl 2040: 69 62 3a 6d 61 70 21 20 61 72 72 20 73 68 70 20 ib:map! arr shp 2050: 70 72 6f 63 20 61 72 67 73 29 0a 20 20 28 6c 65 proc args). (le 2060: 74 20 28 28 72 61 6e 6b 20 28 76 65 63 74 6f 72 t ((rank (vector 2070: 2d 6c 65 6e 67 74 68 20 61 72 67 73 29 29 29 0a -length args))). 2080: 20 20 20 20 28 6c 65 74 20 28 28 61 72 67 76 20 (let ((argv 2090: 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 72 61 6e (make-vector ran 20a0: 6b 29 29 29 0a 20 20 20 20 20 20 28 61 72 72 61 k))). (arra 20b0: 79 3a 61 72 6c 69 62 3a 73 68 61 70 65 2d 66 6f y:arlib:shape-fo 20c0: 72 2d 65 61 63 68 2f 76 65 63 74 6f 72 0a 20 20 r-each/vector. 20d0: 20 20 20 20 20 73 68 70 0a 20 20 20 20 20 20 20 shp. 20e0: 28 6c 65 74 20 28 28 61 70 70 6c 79 20 28 61 72 (let ((apply (ar 20f0: 72 61 79 3a 61 70 70 6c 69 65 72 2d 74 6f 2d 76 ray:applier-to-v 2100: 65 63 74 6f 72 20 72 61 6e 6b 29 29 29 0a 20 20 ector rank))). 2110: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda ( 2120: 69 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 ix). ( 2130: 64 6f 20 28 28 6b 20 30 20 28 2b 20 6b 20 31 29 do ((k 0 (+ k 1) 2140: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 2150: 28 28 3d 20 6b 20 72 61 6e 6b 29 29 0a 20 20 20 ((= k rank)). 2160: 20 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f (vecto 2170: 72 2d 73 65 74 21 20 61 72 67 76 20 6b 20 28 61 r-set! argv k (a 2180: 72 72 61 79 2d 72 65 66 20 28 76 65 63 74 6f 72 rray-ref (vector 2190: 2d 72 65 66 20 61 72 67 73 20 6b 29 20 69 78 29 -ref args k) ix) 21a0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 61 )). (a 21b0: 72 72 61 79 2d 73 65 74 21 20 61 72 72 20 69 78 rray-set! arr ix 21c0: 20 28 61 70 70 6c 79 20 70 72 6f 63 20 61 72 67 (apply proc arg 21d0: 76 29 29 29 29 0a 20 20 20 20 20 20 20 28 6d 61 v)))). (ma 21e0: 6b 65 2d 76 65 63 74 6f 72 20 28 61 72 72 61 79 ke-vector (array 21f0: 2d 65 6e 64 20 73 68 70 20 30 29 29 29 29 29 29 -end shp 0)))))) 2200: 0a 0a 3b 3b 3b 20 28 61 72 72 61 79 2d 6d 61 70 ..;;; (array-map 2210: 20 5b 73 68 61 70 65 5d 20 70 72 6f 63 20 61 72 [shape] proc ar 2220: 72 61 79 30 20 61 72 72 61 79 31 20 2e 2e 2e 29 ray0 array1 ...) 2230: 0a 3b 3b 3b 20 63 72 65 61 74 65 73 20 61 20 6e .;;; creates a n 2240: 65 77 20 61 72 72 61 79 20 77 69 74 68 20 65 6c ew array with el 2250: 65 6d 65 6e 74 73 20 69 6e 69 74 69 61 6c 69 7a ements initializ 2260: 65 64 20 74 6f 20 74 68 65 20 76 61 6c 75 65 73 ed to the values 2270: 20 6f 66 0a 3b 3b 3b 20 70 72 6f 63 20 61 74 20 of.;;; proc at 2280: 63 6f 6e 74 65 6e 74 73 20 6f 66 20 61 72 72 61 contents of arra 2290: 79 6b 20 28 69 6e 20 73 68 61 70 65 29 2e 0a 0a yk (in shape)... 22a0: 28 64 65 66 69 6e 65 20 28 61 72 72 61 79 2d 6d (define (array-m 22b0: 61 70 20 78 20 79 20 2e 20 6f 29 0a 20 20 28 69 ap x y . o). (i 22c0: 66 20 28 61 72 72 61 79 3a 61 72 72 61 79 3f 20 f (array:array? 22d0: 78 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 x). (let (( 22e0: 61 72 72 20 28 6d 61 6b 65 2d 61 72 72 61 79 20 arr (make-array 22f0: 78 29 29 29 0a 20 20 20 20 20 20 20 20 28 61 72 x))). (ar 2300: 72 61 79 3a 61 72 6c 69 62 3a 6d 61 70 21 20 61 ray:arlib:map! a 2310: 72 72 20 78 20 79 20 28 61 70 70 6c 79 20 76 65 rr x y (apply ve 2320: 63 74 6f 72 20 6f 29 29 0a 20 20 20 20 20 20 20 ctor o)). 2330: 20 61 72 72 29 0a 20 20 20 20 20 20 28 6c 65 74 arr). (let 2340: 20 28 28 73 68 70 20 28 61 72 72 61 79 2d 73 68 ((shp (array-sh 2350: 61 70 65 20 79 29 29 29 0a 20 20 20 20 20 20 20 ape y))). 2360: 20 28 6c 65 74 20 28 28 61 72 72 20 28 6d 61 6b (let ((arr (mak 2370: 65 2d 61 72 72 61 79 20 73 68 70 29 29 29 0a 20 e-array shp))). 2380: 20 20 20 20 20 20 20 20 20 28 61 72 72 61 79 3a (array: 2390: 61 72 6c 69 62 3a 6d 61 70 21 20 61 72 72 20 73 arlib:map! arr s 23a0: 68 70 20 78 20 28 61 70 70 6c 79 20 76 65 63 74 hp x (apply vect 23b0: 6f 72 20 79 20 6f 29 29 0a 20 20 20 20 20 20 20 or y o)). 23c0: 20 20 20 61 72 72 29 29 29 29 0a 0a 3b 3b 3b 20 arr))))..;;; 23d0: 53 52 46 49 2d 32 35 20 6d 61 69 6c 69 6e 67 20 SRFI-25 mailing 23e0: 6c 69 73 74 20 72 65 71 75 65 73 74 65 64 20 61 list requested a 23f0: 72 72 61 79 2d 3e 76 65 63 74 6f 72 3b 20 74 68 rray->vector; th 2400: 65 79 20 61 6c 73 6f 20 72 65 71 75 65 73 74 65 ey also requeste 2410: 64 20 74 68 65 0a 3b 3b 3b 20 61 62 69 6c 69 74 d the.;;; abilit 2420: 79 20 74 6f 20 75 73 65 20 61 6e 20 61 72 72 61 y to use an arra 2430: 79 20 61 73 20 61 6e 20 69 6e 64 65 78 20 6f 66 y as an index of 2440: 20 61 6e 20 65 6c 65 6d 65 6e 74 2c 20 61 6e 64 an element, and 2450: 20 61 72 72 61 79 2d 3e 6c 69 73 74 20 69 73 0a array->list is. 2460: 3b 3b 3b 20 61 6e 20 61 74 74 65 6d 70 74 20 74 ;;; an attempt t 2470: 6f 20 70 72 6f 76 69 64 65 20 66 6f 72 20 74 68 o provide for th 2480: 61 74 2e 0a 0a 28 64 65 66 69 6e 65 20 28 61 72 at...(define (ar 2490: 72 61 79 2d 3e 76 65 63 74 6f 72 20 61 72 72 29 ray->vector arr) 24a0: 0a 20 20 28 6c 65 74 20 28 28 76 65 63 20 28 6d . (let ((vec (m 24b0: 61 6b 65 2d 76 65 63 74 6f 72 20 28 61 72 72 61 ake-vector (arra 24c0: 79 2d 73 69 7a 65 20 61 72 72 29 29 29 29 0a 20 y-size arr)))). 24d0: 20 20 20 28 6c 65 74 20 28 28 6b 20 30 29 29 0a (let ((k 0)). 24e0: 20 20 20 20 20 20 28 73 68 61 70 65 2d 66 6f 72 (shape-for 24f0: 2d 65 61 63 68 0a 20 20 20 20 20 20 20 28 61 72 -each. (ar 2500: 72 61 79 2d 73 68 61 70 65 20 61 72 72 29 0a 20 ray-shape arr). 2510: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 69 (lambda (i 2520: 6e 64 65 78 29 0a 20 20 20 20 20 20 20 20 20 28 ndex). ( 2530: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 vector-set! vec 2540: 6b 20 28 61 72 72 61 79 2d 72 65 66 20 61 72 72 k (array-ref arr 2550: 20 69 6e 64 65 78 29 29 0a 20 20 20 20 20 20 20 index)). 2560: 20 20 28 73 65 74 21 20 6b 20 28 2b 20 6b 20 31 (set! k (+ k 1 2570: 29 29 29 0a 20 20 20 20 20 20 20 28 6d 61 6b 65 ))). (make 2580: 2d 76 65 63 74 6f 72 20 28 61 72 72 61 79 2d 72 -vector (array-r 2590: 61 6e 6b 20 61 72 72 29 29 29 0a 20 20 20 20 20 ank arr))). 25a0: 20 76 65 63 29 29 29 0a 0a 3b 3b 3b 20 49 74 20 vec)))..;;; It 25b0: 6e 65 65 64 73 20 74 6f 20 62 65 20 73 61 69 64 needs to be said 25c0: 20 74 68 61 74 20 6d 6f 72 65 20 65 66 66 69 63 that more effic 25d0: 69 65 6e 74 20 69 6d 70 6c 65 6d 65 6e 74 61 74 ient implementat 25e0: 69 6f 6e 73 20 61 72 65 0a 3b 3b 3b 20 70 6f 73 ions are.;;; pos 25f0: 73 69 62 6c 65 2c 20 65 76 65 6e 20 77 69 74 68 sible, even with 2600: 69 6e 20 53 52 46 49 2d 32 35 2e 0a 0a 28 64 65 in SRFI-25...(de 2610: 66 69 6e 65 20 28 61 72 72 61 79 2d 3e 6c 69 73 fine (array->lis 2620: 74 20 61 72 72 29 0a 20 20 28 76 65 63 74 6f 72 t arr). (vector 2630: 2d 3e 6c 69 73 74 20 28 61 72 72 61 79 2d 3e 76 ->list (array->v 2640: 65 63 74 6f 72 20 61 72 72 29 29 29 0a 0a 3b 3b ector arr)))..;; 2650: 3b 20 28 73 68 61 72 65 2d 72 6f 77 20 61 72 72 ; (share-row arr 2660: 20 6b 29 0a 3b 3b 3b 20 73 68 61 72 65 73 20 77 k).;;; shares w 2670: 68 61 74 65 76 65 72 20 74 68 65 20 66 69 72 73 hatever the firs 2680: 74 20 69 6e 64 65 78 20 69 73 20 61 62 6f 75 74 t index is about 2690: 2e 0a 3b 3b 3b 20 54 68 65 20 72 65 73 75 6c 74 ..;;; The result 26a0: 20 68 61 73 20 6f 6e 65 20 64 69 6d 65 6e 73 69 has one dimensi 26b0: 6f 6e 20 6c 65 73 73 2e 0a 0a 28 64 65 66 69 6e on less...(defin 26c0: 65 20 28 73 68 61 72 65 2d 72 6f 77 20 61 72 72 e (share-row arr 26d0: 20 6b 29 0a 20 20 28 73 68 61 72 65 2d 61 72 72 k). (share-arr 26e0: 61 79 0a 20 20 20 61 72 72 0a 20 20 20 28 6c 65 ay. arr. (le 26f0: 74 20 28 28 62 6f 75 6e 64 73 20 28 61 72 72 61 t ((bounds (arra 2700: 79 2d 3e 6c 69 73 74 20 28 61 72 72 61 79 2d 73 y->list (array-s 2710: 68 61 70 65 20 61 72 72 29 29 29 29 0a 20 20 20 hape arr)))). 2720: 20 20 28 61 70 70 6c 79 20 73 68 61 70 65 20 28 (apply shape ( 2730: 63 64 64 72 20 62 6f 75 6e 64 73 29 29 29 0a 20 cddr bounds))). 2740: 20 20 28 6c 61 6d 62 64 61 20 6b 73 0a 20 20 20 (lambda ks. 2750: 20 20 28 61 70 70 6c 79 20 76 61 6c 75 65 73 20 (apply values 2760: 6b 20 6b 73 29 29 29 29 0a 0a 3b 3b 3b 20 28 73 k ks))))..;;; (s 2770: 68 61 72 65 2d 61 72 72 61 79 2f 70 72 65 66 69 hare-array/prefi 2780: 78 20 61 72 72 20 6b 20 2e 2e 2e 29 0a 0a 28 64 x arr k ...)..(d 2790: 65 66 69 6e 65 20 28 73 68 61 72 65 2d 61 72 72 efine (share-arr 27a0: 61 79 2f 70 72 65 66 69 78 20 61 72 72 20 2e 20 ay/prefix arr . 27b0: 6a 73 29 0a 20 20 28 69 66 20 28 6f 72 20 28 6e js). (if (or (n 27c0: 75 6c 6c 3f 20 6a 73 29 0a 20 20 20 20 20 20 20 ull? js). 27d0: 20 20 20 28 69 6e 74 65 67 65 72 3f 20 28 63 61 (integer? (ca 27e0: 72 20 6a 73 29 29 29 0a 20 20 20 20 20 20 28 73 r js))). (s 27f0: 68 61 72 65 2d 61 72 72 61 79 0a 20 20 20 20 20 hare-array. 2800: 20 20 61 72 72 0a 20 20 20 20 20 20 20 28 6c 65 arr. (le 2810: 74 20 28 28 62 6f 75 6e 64 73 20 28 61 72 72 61 t ((bounds (arra 2820: 79 2d 3e 6c 69 73 74 20 28 61 72 72 61 79 2d 73 y->list (array-s 2830: 68 61 70 65 20 61 72 72 29 29 29 29 0a 20 20 20 hape arr)))). 2840: 20 20 20 20 20 20 28 61 70 70 6c 79 20 73 68 61 (apply sha 2850: 70 65 20 28 6c 69 73 74 2d 74 61 69 6c 20 62 6f pe (list-tail bo 2860: 75 6e 64 73 20 28 2a 20 32 20 28 6c 65 6e 67 74 unds (* 2 (lengt 2870: 68 20 6a 73 29 29 29 29 29 0a 20 20 20 20 20 20 h js))))). 2880: 20 28 6c 61 6d 62 64 61 20 6b 73 0a 20 20 20 20 (lambda ks. 2890: 20 20 20 20 20 28 61 70 70 6c 79 20 76 61 6c 75 (apply valu 28a0: 65 73 20 28 61 70 70 65 6e 64 20 6a 73 20 6b 73 es (append js ks 28b0: 29 29 29 29 0a 20 20 20 20 20 20 28 61 70 70 6c )))). (appl 28c0: 79 20 28 6c 61 6d 62 64 61 20 28 66 69 78 29 0a y (lambda (fix). 28d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 28e0: 73 68 61 72 65 2d 61 72 72 61 79 2f 70 72 65 66 share-array/pref 28f0: 69 78 21 0a 20 20 20 20 20 20 20 20 20 20 20 20 ix!. 2900: 20 20 20 20 61 72 72 0a 20 20 20 20 20 20 20 20 arr. 2910: 20 20 20 20 20 20 20 20 66 69 78 0a 20 20 20 20 fix. 2920: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b (mak 2930: 65 2d 76 65 63 74 6f 72 20 28 2d 20 28 61 72 72 e-vector (- (arr 2940: 61 79 2d 72 61 6e 6b 20 61 72 72 29 0a 20 20 20 ay-rank arr). 2950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2960: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if 2970: 20 28 76 65 63 74 6f 72 3f 20 66 69 78 29 0a 20 (vector? fix). 2980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29a0: 20 20 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 (vector-lengt 29b0: 68 20 66 69 78 29 0a 20 20 20 20 20 20 20 20 20 h fix). 29c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29d0: 20 20 20 20 20 20 20 20 20 20 20 28 61 72 72 61 (arra 29e0: 79 2d 65 6e 64 20 66 69 78 20 30 29 29 29 29 29 y-end fix 0))))) 29f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 6a ). j 2a00: 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 s)))..(define (s 2a10: 68 61 72 65 2d 61 72 72 61 79 2f 70 72 65 66 69 hare-array/prefi 2a20: 78 21 20 61 72 72 20 66 69 78 20 69 6e 20 2e 20 x! arr fix in . 2a30: 6f 75 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 6f out). (let* ((o 2a40: 75 74 20 28 69 66 20 28 70 61 69 72 3f 20 6f 75 ut (if (pair? ou 2a50: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t). 2a60: 20 20 20 20 20 28 28 6c 61 6d 62 64 61 20 28 6f ((lambda (o 2a70: 75 74 29 20 6f 75 74 29 20 6f 75 74 29 0a 20 20 ut) out) out). 2a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2a90: 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 28 61 72 (make-vector (ar 2aa0: 72 61 79 2d 72 61 6e 6b 20 61 72 72 29 29 29 29 ray-rank arr)))) 2ab0: 0a 20 20 20 20 20 20 20 20 20 28 66 69 78 2d 72 . (fix-r 2ac0: 65 66 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 ef (if (vector? 2ad0: 66 69 78 29 20 76 65 63 74 6f 72 2d 72 65 66 20 fix) vector-ref 2ae0: 61 72 72 61 79 2d 72 65 66 29 29 0a 20 20 20 20 array-ref)). 2af0: 20 20 20 20 20 28 69 6e 2d 72 65 66 20 28 69 66 (in-ref (if 2b00: 20 28 76 65 63 74 6f 72 3f 20 69 6e 29 20 76 65 (vector? in) ve 2b10: 63 74 6f 72 2d 72 65 66 20 61 72 72 61 79 2d 72 ctor-ref array-r 2b20: 65 66 29 29 0a 20 20 20 20 20 20 20 20 20 28 6f ef)). (o 2b30: 75 74 2d 73 65 74 21 20 28 69 66 20 28 76 65 63 ut-set! (if (vec 2b40: 74 6f 72 3f 20 6f 75 74 29 20 76 65 63 74 6f 72 tor? out) vector 2b50: 2d 73 65 74 21 20 61 72 72 61 79 2d 73 65 74 21 -set! array-set! 2b60: 29 29 0a 20 20 20 20 20 20 20 20 20 28 6d 20 28 )). (m ( 2b70: 69 66 20 28 76 65 63 74 6f 72 3f 20 66 69 78 29 if (vector? fix) 2b80: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 2b90: 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 (vector-length 2ba0: 66 69 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 fix). 2bb0: 20 20 20 20 20 28 61 72 72 61 79 2d 65 6e 64 20 (array-end 2bc0: 66 69 78 20 30 29 29 29 0a 20 20 20 20 20 20 20 fix 0))). 2bd0: 20 20 28 6e 20 28 69 66 20 28 76 65 63 74 6f 72 (n (if (vector 2be0: 3f 20 6f 75 74 29 0a 20 20 20 20 20 20 20 20 20 ? out). 2bf0: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 6c (vector-l 2c00: 65 6e 67 74 68 20 6f 75 74 29 0a 20 20 20 20 20 ength out). 2c10: 20 20 20 20 20 20 20 20 20 20 20 28 61 72 72 61 (arra 2c20: 79 2d 65 6e 64 20 6f 75 74 20 30 29 29 29 29 0a y-end out 0)))). 2c30: 20 20 20 20 28 64 6f 20 28 28 6b 20 30 20 28 2b (do ((k 0 (+ 2c40: 20 6b 20 31 29 29 29 0a 20 20 20 20 20 20 28 28 k 1))). (( 2c50: 3d 20 6b 20 6d 29 29 0a 20 20 20 20 20 20 28 6f = k m)). (o 2c60: 75 74 2d 73 65 74 21 20 6f 75 74 20 6b 20 28 66 ut-set! out k (f 2c70: 69 78 2d 72 65 66 20 66 69 78 20 6b 29 29 29 0a ix-ref fix k))). 2c80: 20 20 20 20 28 73 68 61 72 65 2d 61 72 72 61 79 (share-array 2c90: 2f 69 6e 64 65 78 21 0a 20 20 20 20 20 61 72 72 /index!. arr 2ca0: 0a 20 20 20 20 20 28 6c 65 74 20 28 28 62 6f 75 . (let ((bou 2cb0: 6e 64 73 20 28 61 72 72 61 79 2d 3e 6c 69 73 74 nds (array->list 2cc0: 20 28 61 72 72 61 79 2d 73 68 61 70 65 20 61 72 (array-shape ar 2cd0: 72 29 29 29 29 0a 20 20 20 20 20 20 20 28 61 70 r)))). (ap 2ce0: 70 6c 79 20 73 68 61 70 65 20 28 6c 69 73 74 2d ply shape (list- 2cf0: 74 61 69 6c 20 62 6f 75 6e 64 73 20 28 69 66 20 tail bounds (if 2d00: 28 76 65 63 74 6f 72 3f 20 66 69 78 29 0a 20 20 (vector? fix). 2d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2d30: 20 20 20 20 20 20 20 20 28 2a 20 32 20 28 76 65 (* 2 (ve 2d40: 63 74 6f 72 2d 6c 65 6e 67 74 68 20 66 69 78 29 ctor-length fix) 2d50: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 2d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2d70: 20 20 20 20 20 20 20 20 20 20 20 20 28 2a 20 32 (* 2 2d80: 20 28 61 72 72 61 79 2d 65 6e 64 20 66 69 78 20 (array-end fix 2d90: 30 29 29 29 29 29 29 0a 20 20 20 20 20 28 6c 61 0)))))). (la 2da0: 6d 62 64 61 20 28 69 6e 29 0a 20 20 20 20 20 20 mbda (in). 2db0: 20 28 64 6f 20 28 28 6b 20 6d 20 28 2b 20 6b 20 (do ((k m (+ k 2dc0: 31 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 28 1))). (( 2dd0: 3d 20 6b 20 6e 29 29 0a 20 20 20 20 20 20 20 20 = k n)). 2de0: 20 28 6f 75 74 2d 73 65 74 21 20 6f 75 74 20 6b (out-set! out k 2df0: 20 28 69 6e 2d 72 65 66 20 69 6e 20 28 2d 20 6b (in-ref in (- k 2e00: 20 6d 29 29 29 29 0a 20 20 20 20 20 20 20 6f 75 m)))). ou 2e10: 74 29 0a 20 20 20 20 20 69 6e 29 29 29 0a 0a 3b t). in)))..; 2e20: 3b 3b 20 28 73 68 61 72 65 2d 63 6f 6c 75 6d 6e ;; (share-column 2e30: 20 61 72 72 20 6b 29 0a 3b 3b 3b 20 73 68 61 72 arr k).;;; shar 2e40: 65 73 20 77 68 61 74 65 76 65 72 20 74 68 65 20 es whatever the 2e50: 73 65 63 6f 6e 64 20 69 6e 64 65 78 20 69 73 20 second index is 2e60: 61 62 6f 75 74 2e 0a 3b 3b 3b 20 54 68 65 20 72 about..;;; The r 2e70: 65 73 75 6c 74 20 68 61 73 20 6f 6e 65 20 64 69 esult has one di 2e80: 6d 65 6e 73 69 6f 6e 20 6c 65 73 73 2e 0a 0a 28 mension less...( 2e90: 64 65 66 69 6e 65 20 28 73 68 61 72 65 2d 63 6f define (share-co 2ea0: 6c 75 6d 6e 20 61 72 72 20 6b 29 0a 20 20 28 73 lumn arr k). (s 2eb0: 68 61 72 65 2d 61 72 72 61 79 0a 20 20 20 61 72 hare-array. ar 2ec0: 72 0a 20 20 20 28 6c 65 74 20 28 28 62 6f 75 6e r. (let ((boun 2ed0: 64 73 20 28 61 72 72 61 79 2d 3e 6c 69 73 74 20 ds (array->list 2ee0: 28 61 72 72 61 79 2d 73 68 61 70 65 20 61 72 72 (array-shape arr 2ef0: 29 29 29 29 0a 20 20 20 20 20 28 61 70 70 6c 79 )))). (apply 2f00: 20 73 68 61 70 65 0a 20 20 20 20 20 20 20 20 20 shape. 2f10: 20 20 20 28 63 61 72 20 62 6f 75 6e 64 73 29 20 (car bounds) 2f20: 28 63 61 64 72 20 62 6f 75 6e 64 73 29 0a 20 20 (cadr bounds). 2f30: 20 20 20 20 20 20 20 20 20 20 28 63 64 64 64 64 (cdddd 2f40: 72 20 62 6f 75 6e 64 73 29 29 29 0a 20 20 20 28 r bounds))). ( 2f50: 6c 61 6d 62 64 61 20 6b 73 0a 20 20 20 20 20 28 lambda ks. ( 2f60: 61 70 70 6c 79 20 76 61 6c 75 65 73 20 28 63 61 apply values (ca 2f70: 72 20 6b 73 29 20 6b 20 28 63 64 72 20 6b 73 29 r ks) k (cdr ks) 2f80: 29 29 29 29 0a 0a 3b 3b 3b 20 28 73 68 61 72 65 ))))..;;; (share 2f90: 2d 61 72 72 61 79 2f 6f 72 69 67 69 6e 20 61 72 -array/origin ar 2fa0: 72 20 6b 20 2e 2e 2e 29 0a 3b 3b 3b 20 28 73 68 r k ...).;;; (sh 2fb0: 61 72 65 2d 61 72 72 61 79 2f 6f 72 69 67 69 6e are-array/origin 2fc0: 20 61 72 72 20 69 6e 64 65 78 29 0a 3b 3b 3b 20 arr index).;;; 2fd0: 63 68 61 6e 67 65 20 6f 72 69 67 69 6e 20 74 6f change origin to 2fe0: 20 6b 20 2e 2e 2e 2c 20 77 69 74 68 20 69 6e 64 k ..., with ind 2ff0: 65 78 20 61 20 76 65 63 74 6f 72 20 6f 72 20 7a ex a vector or z 3000: 65 72 6f 2d 62 61 73 65 64 0a 3b 3b 3b 20 6f 6e ero-based.;;; on 3010: 65 2d 64 69 6d 65 6e 73 69 6f 6e 61 6c 20 61 72 e-dimensional ar 3020: 72 61 79 20 74 68 61 74 20 63 6f 6e 74 61 69 6e ray that contain 3030: 73 20 6b 20 2e 2e 2e 0a 3b 3b 3b 0a 3b 3b 3b 20 s k ....;;;.;;; 3040: 54 68 69 73 20 69 73 20 75 73 65 66 75 6c 20 66 This is useful f 3050: 6f 72 20 77 72 69 74 69 6e 67 20 61 72 72 61 79 or writing array 3060: 2d 61 70 70 65 6e 64 2e 20 4d 61 79 62 65 20 66 -append. Maybe f 3070: 6f 72 20 73 6f 6d 65 74 68 69 6e 67 0a 3b 3b 3b or something.;;; 3080: 20 65 6c 73 65 20 74 6f 6f 20 2d 20 77 68 6f 20 else too - who 3090: 6b 6e 6f 77 73 2e 0a 0a 28 64 65 66 69 6e 65 20 knows...(define 30a0: 28 73 68 61 72 65 2d 61 72 72 61 79 2f 6f 72 69 (share-array/ori 30b0: 67 69 6e 20 61 72 72 20 2e 20 78 73 29 0a 20 20 gin arr . xs). 30c0: 28 6c 65 74 20 28 28 6e 65 77 20 28 69 66 20 28 (let ((new (if ( 30d0: 6f 72 20 28 6e 75 6c 6c 3f 20 78 73 29 0a 20 20 or (null? xs). 30e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 30f0: 20 20 20 28 69 6e 74 65 67 65 72 3f 20 28 63 61 (integer? (ca 3100: 72 20 78 73 29 29 29 0a 20 20 20 20 20 20 20 20 r xs))). 3110: 20 20 20 20 20 20 20 20 20 78 73 0a 20 20 20 20 xs. 3120: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 (ap 3130: 70 6c 79 20 28 6c 61 6d 62 64 61 20 28 78 29 0a ply (lambda (x). 3140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3150: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 76 (if (v 3160: 65 63 74 6f 72 3f 20 78 29 0a 20 20 20 20 20 20 ector? x). 3170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3180: 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d (vector- 3190: 3e 6c 69 73 74 20 78 29 0a 20 20 20 20 20 20 20 >list x). 31a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 31b0: 20 20 20 20 20 20 20 28 69 66 20 28 61 72 72 61 (if (arra 31c0: 79 3f 20 78 29 0a 20 20 20 20 20 20 20 20 20 20 y? x). 31d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 31e0: 20 20 20 20 20 20 20 20 28 61 72 72 61 79 2d 3e (array-> 31f0: 6c 69 73 74 20 78 29 0a 20 20 20 20 20 20 20 20 list x). 3200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3210: 20 20 20 20 20 20 20 20 20 20 28 65 72 72 6f 72 (error 3220: 20 22 73 68 61 72 65 2d 61 72 72 61 79 2f 6f 72 "share-array/or 3230: 69 67 69 6e 3a 20 62 61 64 20 74 68 69 6e 67 22 igin: bad thing" 3240: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))). 3250: 20 20 20 20 20 20 20 20 20 20 20 20 20 78 73 29 xs) 3260: 29 29 29 0a 20 20 20 20 28 64 6f 20 28 28 6b 20 ))). (do ((k 3270: 28 61 72 72 61 79 2d 72 61 6e 6b 20 61 72 72 29 (array-rank arr) 3280: 20 28 2d 20 6b 20 31 29 29 0a 20 20 20 20 20 20 (- k 1)). 3290: 20 20 20 28 6f 6c 64 20 27 28 29 20 28 63 6f 6e (old '() (con 32a0: 73 20 28 61 72 72 61 79 2d 73 74 61 72 74 20 61 s (array-start a 32b0: 72 72 20 28 2d 20 6b 20 31 29 29 20 6f 6c 64 29 rr (- k 1)) old) 32c0: 29 29 0a 20 20 20 20 20 20 28 28 3d 20 6b 20 30 )). ((= k 0 32d0: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 ). (let (( 32e0: 64 73 20 28 6d 61 70 20 2d 20 6e 65 77 20 6f 6c ds (map - new ol 32f0: 64 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 73 d))). (s 3300: 68 61 72 65 2d 61 72 72 61 79 0a 20 20 20 20 20 hare-array. 3310: 20 20 20 20 20 61 72 72 0a 20 20 20 20 20 20 20 arr. 3320: 20 20 20 28 74 61 62 75 6c 61 74 65 2d 61 72 72 (tabulate-arr 3330: 61 79 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 ay. (s 3340: 68 61 70 65 20 30 20 28 61 72 72 61 79 2d 72 61 hape 0 (array-ra 3350: 6e 6b 20 61 72 72 29 20 30 20 32 29 0a 20 20 20 nk arr) 0 2). 3360: 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 (lambda 3370: 28 72 20 6b 29 0a 20 20 20 20 20 20 20 20 20 20 (r k). 3380: 20 20 20 28 63 61 73 65 20 6b 0a 20 20 20 20 20 (case k. 3390: 20 20 20 20 20 20 20 20 20 20 28 28 30 29 20 28 ((0) ( 33a0: 2b 20 28 61 72 72 61 79 2d 73 74 61 72 74 20 61 + (array-start a 33b0: 72 72 20 72 29 20 28 6c 69 73 74 2d 72 65 66 20 rr r) (list-ref 33c0: 64 73 20 72 29 29 29 0a 20 20 20 20 20 20 20 20 ds r))). 33d0: 20 20 20 20 20 20 20 28 28 31 29 20 28 2b 20 28 ((1) (+ ( 33e0: 61 72 72 61 79 2d 65 6e 64 20 61 72 72 20 72 29 array-end arr r) 33f0: 20 28 6c 69 73 74 2d 72 65 66 20 64 73 20 72 29 (list-ref ds r) 3400: 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ))))). 3410: 28 6c 61 6d 62 64 61 20 6b 73 0a 20 20 20 20 20 (lambda ks. 3420: 20 20 20 20 20 20 20 28 61 70 70 6c 79 20 76 61 (apply va 3430: 6c 75 65 73 20 28 6d 61 70 20 2d 20 6b 73 20 64 lues (map - ks d 3440: 73 29 29 29 29 29 29 29 29 29 0a 0a 3b 3b 3b 20 s)))))))))..;;; 3450: 53 52 46 49 2d 32 35 20 6d 61 69 6c 69 6e 67 20 SRFI-25 mailing 3460: 6c 69 73 74 20 72 65 71 75 65 73 74 65 64 20 6d list requested m 3470: 61 6b 69 6e 67 20 73 68 61 70 65 73 20 74 68 65 aking shapes the 3480: 69 72 20 6f 77 6e 20 74 79 70 65 2e 20 48 65 72 ir own type. Her 3490: 65 27 73 0a 3b 3b 3b 20 61 6e 20 65 78 61 6d 70 e's.;;; an examp 34a0: 6c 65 20 6f 66 20 68 6f 77 20 6d 61 6e 69 70 75 le of how manipu 34b0: 6c 61 74 69 6e 67 20 73 68 61 70 65 73 20 61 73 lating shapes as 34c0: 20 61 72 72 61 79 73 20 63 61 6e 20 62 65 20 75 arrays can be u 34d0: 73 65 66 75 6c 2e 20 54 68 65 0a 3b 3b 3b 20 65 seful. The.;;; e 34e0: 78 61 6d 70 6c 65 20 61 6c 73 6f 20 74 65 73 74 xample also test 34f0: 73 20 74 68 61 74 20 68 69 67 68 65 72 20 6c 65 s that higher le 3500: 76 65 6c 20 6c 69 62 72 61 72 69 65 73 20 61 72 vel libraries ar 3510: 65 20 69 6e 64 65 65 64 20 65 61 73 79 20 74 6f e indeed easy to 3520: 0a 3b 3b 3b 20 77 72 69 74 65 20 6f 6e 20 74 6f .;;; write on to 3530: 70 20 6f 66 20 74 68 69 73 20 53 52 46 49 2e 0a p of this SRFI.. 3540: 0a 3b 3b 3b 20 28 61 72 72 61 79 2d 61 70 70 65 .;;; (array-appe 3550: 6e 64 20 61 72 72 31 20 61 72 72 32 20 64 69 6d nd arr1 arr2 dim 3560: 29 0a 3b 3b 3b 20 61 70 70 65 6e 64 73 20 74 77 ).;;; appends tw 3570: 6f 20 61 72 72 61 79 73 20 61 6c 6f 6e 67 20 61 o arrays along a 3580: 20 73 70 65 63 69 66 69 65 64 20 64 69 6d 65 6e specified dimen 3590: 73 69 6f 6e 2e 20 54 68 65 20 61 72 72 61 79 73 sion. The arrays 35a0: 20 6d 75 73 74 0a 3b 3b 3b 20 68 61 76 65 20 65 must.;;; have e 35b0: 71 75 61 6c 6c 79 20 6d 61 6e 79 20 64 69 6d 65 qually many dime 35c0: 6e 73 69 6f 6e 73 20 61 6e 64 20 61 6c 6c 20 6f nsions and all o 35d0: 74 68 65 72 20 64 69 6d 65 6e 73 69 6f 6e 73 20 ther dimensions 35e0: 65 71 75 61 6c 6c 79 20 6c 6f 6e 67 2e 0a 3b 3b equally long..;; 35f0: 3b 0a 3b 3b 3b 20 47 65 6e 65 72 61 6c 69 7a 65 ;.;;; Generalize 3600: 20 74 6f 20 6d 6f 72 65 20 61 72 72 61 79 73 20 to more arrays 3610: 61 6e 64 20 6d 61 79 62 65 20 72 65 77 72 69 74 and maybe rewrit 3620: 65 20 77 69 74 68 20 73 68 61 70 65 2d 66 6f 72 e with shape-for 3630: 2d 65 61 63 68 20 6f 72 0a 3b 3b 3b 20 77 68 61 -each or.;;; wha 3640: 74 20 68 61 76 65 20 79 6f 75 2e 0a 0a 28 64 65 t have you...(de 3650: 66 69 6e 65 20 28 61 72 72 61 79 2d 61 70 70 65 fine (array-appe 3660: 6e 64 20 64 69 6d 20 61 72 72 20 2e 20 61 72 73 nd dim arr . ars 3670: 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 6f 74 61 ). (let* ((tota 3680: 6c 20 28 64 6f 20 28 28 6d 20 28 61 72 72 61 79 l (do ((m (array 3690: 2d 6c 65 6e 67 74 68 20 61 72 72 20 64 69 6d 29 -length arr dim) 36a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 36b0: 20 20 20 20 20 20 20 20 20 28 2b 20 6d 20 28 61 (+ m (a 36c0: 72 72 61 79 2d 6c 65 6e 67 74 68 20 28 63 61 72 rray-length (car 36d0: 20 72 29 20 64 69 6d 29 29 29 0a 20 20 20 20 20 r) dim))). 36e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 36f0: 28 72 20 61 72 73 20 28 63 64 72 20 72 29 29 29 (r ars (cdr r))) 3700: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 3710: 20 20 20 28 28 6e 75 6c 6c 3f 20 72 29 20 6d 29 ((null? r) m) 3720: 29 29 0a 20 20 20 20 20 20 20 20 20 28 63 6f 6d )). (com 3730: 6d 6f 6e 20 28 61 72 72 61 79 2d 73 68 61 70 65 mon (array-shape 3740: 20 61 72 72 29 29 0a 20 20 20 20 20 20 20 20 20 arr)). 3750: 28 6f 72 69 67 69 6e 20 28 61 72 72 61 79 2d 3e (origin (array-> 3760: 76 65 63 74 6f 72 20 28 73 68 61 72 65 2d 63 6f vector (share-co 3770: 6c 75 6d 6e 20 63 6f 6d 6d 6f 6e 20 30 29 29 29 lumn common 0))) 3780: 0a 20 20 20 20 20 20 20 20 20 28 69 6e 64 65 78 . (index 3790: 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 28 61 (make-vector (a 37a0: 72 72 61 79 2d 72 61 6e 6b 20 61 72 72 29 29 29 rray-rank arr))) 37b0: 29 0a 20 20 20 20 28 61 72 72 61 79 2d 73 65 74 ). (array-set 37c0: 21 20 63 6f 6d 6d 6f 6e 20 64 69 6d 20 31 20 28 ! common dim 1 ( 37d0: 2b 20 28 61 72 72 61 79 2d 73 74 61 72 74 20 61 + (array-start a 37e0: 72 72 20 64 69 6d 29 20 74 6f 74 61 6c 29 29 0a rr dim) total)). 37f0: 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c (let ((resul 3800: 74 20 28 6d 61 6b 65 2d 61 72 72 61 79 20 63 6f t (make-array co 3810: 6d 6d 6f 6e 29 29 29 0a 20 20 20 20 20 20 28 61 mmon))). (a 3820: 72 72 61 79 2d 73 65 74 21 20 63 6f 6d 6d 6f 6e rray-set! common 3830: 20 64 69 6d 20 31 20 28 61 72 72 61 79 2d 73 74 dim 1 (array-st 3840: 61 72 74 20 61 72 72 20 64 69 6d 29 29 0a 20 20 art arr dim)). 3850: 20 20 20 20 28 6c 65 74 20 77 6f 6b 20 28 28 61 (let wok ((a 3860: 72 72 20 61 72 72 29 0a 20 20 20 20 20 20 20 20 rr arr). 3870: 20 20 20 20 20 20 20 20 28 61 72 73 20 61 72 73 (ars ars 3880: 29 29 0a 20 20 20 20 20 20 20 20 28 76 65 63 74 )). (vect 3890: 6f 72 2d 73 65 74 21 20 6f 72 69 67 69 6e 20 64 or-set! origin d 38a0: 69 6d 20 28 61 72 72 61 79 2d 72 65 66 20 63 6f im (array-ref co 38b0: 6d 6d 6f 6e 20 64 69 6d 20 31 29 29 0a 20 20 20 mmon dim 1)). 38c0: 20 20 20 20 20 28 6c 65 74 20 28 28 61 72 72 31 (let ((arr1 38d0: 20 28 73 68 61 72 65 2d 61 72 72 61 79 2f 6f 72 (share-array/or 38e0: 69 67 69 6e 20 61 72 72 20 6f 72 69 67 69 6e 29 igin arr origin) 38f0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 61 72 )). (ar 3900: 72 61 79 2d 73 65 74 21 20 63 6f 6d 6d 6f 6e 20 ray-set! common 3910: 64 69 6d 20 30 20 28 61 72 72 61 79 2d 73 74 61 dim 0 (array-sta 3920: 72 74 20 61 72 72 31 20 64 69 6d 29 29 0a 20 20 rt arr1 dim)). 3930: 20 20 20 20 20 20 20 20 28 61 72 72 61 79 2d 73 (array-s 3940: 65 74 21 20 63 6f 6d 6d 6f 6e 20 64 69 6d 20 31 et! common dim 1 3950: 20 28 61 72 72 61 79 2d 65 6e 64 20 61 72 72 31 (array-end arr1 3960: 20 64 69 6d 29 29 0a 20 20 20 20 20 20 20 20 20 dim)). 3970: 20 28 73 68 61 70 65 2d 66 6f 72 2d 65 61 63 68 (shape-for-each 3980: 0a 20 20 20 20 20 20 20 20 20 20 20 63 6f 6d 6d . comm 3990: 6f 6e 0a 20 20 20 20 20 20 20 20 20 20 20 28 6c on. (l 39a0: 61 6d 62 64 61 20 28 69 6e 64 65 78 29 0a 20 20 ambda (index). 39b0: 20 20 20 20 20 20 20 20 20 20 20 28 61 72 72 61 (arra 39c0: 79 2d 73 65 74 21 20 72 65 73 75 6c 74 20 69 6e y-set! result in 39d0: 64 65 78 20 28 61 72 72 61 79 2d 72 65 66 20 61 dex (array-ref a 39e0: 72 72 31 20 69 6e 64 65 78 29 29 29 0a 20 20 20 rr1 index))). 39f0: 20 20 20 20 20 20 20 20 69 6e 64 65 78 29 29 0a index)). 3a00: 20 20 20 20 20 20 20 20 28 69 66 20 28 70 61 69 (if (pai 3a10: 72 3f 20 61 72 73 29 0a 20 20 20 20 20 20 20 20 r? ars). 3a20: 20 20 20 20 28 77 6f 6b 20 28 63 61 72 20 61 72 (wok (car ar 3a30: 73 29 20 28 63 64 72 20 61 72 73 29 29 29 29 0a s) (cdr ars)))). 3a40: 20 20 20 20 20 20 72 65 73 75 6c 74 29 29 29 0a result))). 3a50: 0a 3b 3b 3b 20 54 72 61 6e 73 70 6f 73 65 2c 20 .;;; Transpose, 3a60: 61 73 20 70 65 72 6d 75 74 61 74 69 6f 6e 20 6f as permutation o 3a70: 66 20 64 69 6d 65 6e 73 69 6f 6e 73 2c 20 69 73 f dimensions, is 3a80: 20 61 70 70 6c 69 63 61 62 6c 65 20 74 6f 20 61 applicable to a 3a90: 6c 6c 0a 3b 3b 3b 20 61 72 72 61 79 73 2e 20 54 ll.;;; arrays. T 3aa0: 68 65 20 64 65 66 61 75 6c 74 20 69 73 20 72 65 he default is re 3ab0: 76 65 72 73 61 6c 2e 0a 0a 3b 3b 3b 20 54 68 65 versal...;;; The 3ac0: 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 20 implementation 3ad0: 75 73 65 73 20 6d 75 6c 74 69 70 6c 69 63 61 74 uses multiplicat 3ae0: 69 6f 6e 20 62 79 20 70 65 72 6d 75 74 61 74 69 ion by permutati 3af0: 6f 6e 0a 3b 3b 3b 20 6d 61 74 72 69 78 20 62 75 on.;;; matrix bu 3b00: 74 20 6d 61 74 72 69 78 20 6d 75 6c 74 69 70 6c t matrix multipl 3b10: 69 63 61 74 69 6f 6e 20 69 73 20 6e 6f 74 20 65 ication is not e 3b20: 78 70 6f 72 74 65 64 2e 0a 0a 28 64 65 66 69 6e xported...(defin 3b30: 65 20 28 61 72 72 61 79 3a 61 72 6c 69 62 3a 6d e (array:arlib:m 3b40: 61 74 72 69 78 2d 74 69 6d 65 73 20 61 20 62 29 atrix-times a b) 3b50: 0a 20 20 28 6f 72 20 28 61 6e 64 20 28 3d 20 28 . (or (and (= ( 3b60: 61 72 72 61 79 2d 72 61 6e 6b 20 61 29 20 32 29 array-rank a) 2) 3b70: 0a 20 20 20 20 20 20 20 20 20 20 20 28 3d 20 28 . (= ( 3b80: 61 72 72 61 79 2d 72 61 6e 6b 20 62 29 20 32 29 array-rank b) 2) 3b90: 29 0a 20 20 20 20 20 20 28 65 72 72 6f 72 20 22 ). (error " 3ba0: 74 69 6d 65 73 3a 20 61 72 72 61 79 73 20 61 72 times: arrays ar 3bb0: 65 20 6e 6f 74 20 6d 61 74 72 69 63 65 73 22 29 e not matrices") 3bc0: 29 0a 20 20 28 6c 65 74 20 28 28 72 30 20 28 61 ). (let ((r0 (a 3bd0: 72 72 61 79 2d 73 74 61 72 74 20 61 20 30 29 29 rray-start a 0)) 3be0: 20 20 28 72 6e 20 28 61 72 72 61 79 2d 65 6e 64 (rn (array-end 3bf0: 20 61 20 30 29 29 0a 20 20 20 20 20 20 20 20 28 a 0)). ( 3c00: 74 30 20 28 61 72 72 61 79 2d 73 74 61 72 74 20 t0 (array-start 3c10: 61 20 31 29 29 20 20 28 74 6e 20 28 61 72 72 61 a 1)) (tn (arra 3c20: 79 2d 65 6e 64 20 61 20 31 29 29 0a 20 20 20 20 y-end a 1)). 3c30: 20 20 20 20 28 75 30 20 28 61 72 72 61 79 2d 73 (u0 (array-s 3c40: 74 61 72 74 20 62 20 30 29 29 20 20 28 75 6e 20 tart b 0)) (un 3c50: 28 61 72 72 61 79 2d 65 6e 64 20 62 20 30 29 29 (array-end b 0)) 3c60: 20 0a 20 20 20 20 20 20 20 20 28 6b 30 20 28 61 . (k0 (a 3c70: 72 72 61 79 2d 73 74 61 72 74 20 62 20 31 29 29 rray-start b 1)) 3c80: 20 20 28 6b 6e 20 28 61 72 72 61 79 2d 65 6e 64 (kn (array-end 3c90: 20 62 20 31 29 29 29 0a 20 20 20 20 28 6f 72 20 b 1))). (or 3ca0: 28 3d 20 28 2d 20 74 6e 20 74 30 29 20 28 2d 20 (= (- tn t0) (- 3cb0: 75 6e 20 75 30 29 29 0a 20 20 20 20 20 20 20 20 un u0)). 3cc0: 28 65 72 72 6f 72 20 22 74 69 6d 65 73 3a 20 6d (error "times: m 3cd0: 61 74 72 69 63 65 73 20 61 72 65 20 6e 6f 74 20 atrices are not 3ce0: 63 6f 6d 70 61 74 69 62 6c 65 22 29 29 0a 20 20 compatible")). 3cf0: 20 20 28 6c 65 74 20 28 28 61 62 20 28 6d 61 6b (let ((ab (mak 3d00: 65 2d 61 72 72 61 79 20 28 73 68 61 70 65 20 72 e-array (shape r 3d10: 30 20 72 6e 20 6b 30 20 6b 6e 29 29 29 29 0a 20 0 rn k0 kn)))). 3d20: 20 20 20 20 20 28 64 6f 20 28 28 72 20 72 30 20 (do ((r r0 3d30: 28 2b 20 72 20 31 29 29 29 0a 20 20 20 20 20 20 (+ r 1))). 3d40: 20 20 28 28 3d 20 72 20 72 6e 29 29 0a 20 20 20 ((= r rn)). 3d50: 20 20 20 20 20 28 64 6f 20 28 28 6b 20 6b 30 20 (do ((k k0 3d60: 28 2b 20 6b 20 31 29 29 29 0a 20 20 20 20 20 20 (+ k 1))). 3d70: 20 20 20 20 28 28 3d 20 6b 20 6b 6e 29 29 0a 20 ((= k kn)). 3d80: 20 20 20 20 20 20 20 20 20 28 64 6f 20 28 28 74 (do ((t 3d90: 20 74 30 20 28 2b 20 74 20 31 29 29 0a 20 20 20 t0 (+ t 1)). 3da0: 20 20 20 20 20 20 20 20 20 20 20 20 28 75 20 75 (u u 3db0: 30 20 28 2b 20 75 20 31 29 29 0a 20 20 20 20 20 0 (+ u 1)). 3dc0: 20 20 20 20 20 20 20 20 20 20 28 73 20 30 20 28 (s 0 ( 3dd0: 2b 20 73 20 28 2a 20 28 61 72 72 61 79 2d 72 65 + s (* (array-re 3de0: 66 20 61 20 72 20 74 29 0a 20 20 20 20 20 20 20 f a r t). 3df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3e00: 20 20 20 20 20 28 61 72 72 61 79 2d 72 65 66 20 (array-ref 3e10: 62 20 75 20 6b 29 29 29 29 29 0a 20 20 20 20 20 b u k))))). 3e20: 20 20 20 20 20 20 20 28 28 61 6e 64 20 28 3d 20 ((and (= 3e30: 74 20 74 6e 29 0a 20 20 20 20 20 20 20 20 20 20 t tn). 3e40: 20 20 20 20 20 20 20 20 28 3d 20 75 20 75 6e 29 (= u un) 3e50: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ). ( 3e60: 61 72 72 61 79 2d 73 65 74 21 20 61 62 20 72 20 array-set! ab r 3e70: 6b 20 73 29 29 29 29 29 0a 20 20 20 20 20 20 61 k s))))). a 3e80: 62 29 29 29 0a 0a 3b 20 54 68 69 73 20 69 73 20 b)))..; This is 3e90: 61 20 67 65 6e 65 72 61 6c 69 7a 65 64 20 74 72 a generalized tr 3ea0: 61 6e 73 70 6f 73 65 2e 20 49 74 20 63 61 6e 20 anspose. It can 3eb0: 70 65 72 6d 75 74 65 20 74 68 65 20 64 69 6d 65 permute the dime 3ec0: 6e 73 69 6f 6e 73 20 61 6e 79 20 77 68 69 63 68 nsions any which 3ed0: 20 0a 3b 20 77 61 79 2e 20 54 68 65 20 70 65 72 .; way. The per 3ee0: 6d 75 74 61 74 69 6f 6e 20 69 73 20 70 72 6f 76 mutation is prov 3ef0: 69 64 65 64 20 62 79 20 61 20 70 65 72 6d 75 74 ided by a permut 3f00: 61 74 69 6f 6e 20 6d 61 74 72 69 78 3a 20 61 20 ation matrix: a 3f10: 73 71 75 61 72 65 20 6d 61 74 72 69 78 0a 3b 20 square matrix.; 3f20: 6f 66 20 7a 65 72 6f 73 20 61 6e 64 20 6f 6e 65 of zeros and one 3f30: 73 2c 20 77 69 74 68 20 65 78 61 63 74 6c 79 20 s, with exactly 3f40: 6f 6e 65 20 6f 6e 65 20 69 6e 20 65 61 63 68 20 one one in each 3f50: 72 6f 77 20 61 6e 64 20 63 6f 6c 75 6d 6e 2c 20 row and column, 3f60: 6f 72 20 61 0a 3b 20 70 65 72 6d 75 74 61 74 69 or a.; permutati 3f70: 6f 6e 20 6f 66 20 74 68 65 20 72 6f 77 73 20 6f on of the rows o 3f80: 66 20 61 6e 20 69 64 65 6e 74 69 74 79 20 6d 61 f an identity ma 3f90: 74 72 69 78 3b 20 74 68 65 20 73 69 7a 65 20 6f trix; the size o 3fa0: 66 20 74 68 65 20 6d 61 74 72 69 78 0a 3b 20 6d f the matrix.; m 3fb0: 75 73 74 20 6d 61 74 63 68 20 74 68 65 20 6e 75 ust match the nu 3fc0: 6d 62 65 72 20 6f 66 20 64 69 6d 65 6e 73 69 6f mber of dimensio 3fd0: 6e 73 20 6f 66 20 74 68 65 20 61 72 72 61 79 2e ns of the array. 3fe0: 0a 3b 0a 3b 20 54 68 65 20 64 65 66 61 75 6c 74 .;.; The default 3ff0: 20 70 65 72 6d 75 74 61 74 69 6f 6e 20 69 73 20 permutation is 4000: 5b 20 30 20 31 20 7c 20 31 20 30 20 5d 20 6f 66 [ 0 1 | 1 0 ] of 4010: 20 63 6f 75 72 73 65 2c 20 62 75 74 20 61 6e 79 course, but any 4020: 20 70 65 72 6d 75 74 61 74 69 6f 6e 0a 3b 20 61 permutation.; a 4030: 72 72 61 79 20 63 61 6e 20 62 65 20 73 70 65 63 rray can be spec 4040: 69 66 69 65 64 2c 20 61 6e 64 20 74 68 65 20 73 ified, and the s 4050: 68 61 70 65 20 61 72 72 61 79 20 6f 66 20 74 68 hape array of th 4060: 65 20 6f 72 69 67 69 6e 61 6c 20 61 72 72 61 79 e original array 4070: 20 69 73 20 74 68 65 6e 0a 3b 20 6d 75 6c 74 69 is then.; multi 4080: 70 6c 69 65 64 20 77 69 74 68 20 69 74 2c 20 61 plied with it, a 4090: 6e 64 20 69 6e 64 65 78 20 63 6f 6c 75 6d 6e 20 nd index column 40a0: 76 65 63 74 6f 72 73 20 6f 66 20 74 68 65 20 6e vectors of the n 40b0: 65 77 20 61 72 72 61 79 20 77 69 74 68 20 69 74 ew array with it 40c0: 73 0a 3b 20 69 6e 76 65 72 73 65 2c 20 66 72 6f s.; inverse, fro 40d0: 6d 20 6c 65 66 74 2c 20 74 6f 20 70 65 72 6d 75 m left, to permu 40e0: 74 65 20 74 68 65 20 72 6f 77 73 20 61 70 70 72 te the rows appr 40f0: 6f 70 72 69 61 74 65 6c 79 2e 0a 0a 28 64 65 66 opriately...(def 4100: 69 6e 65 20 28 61 72 72 61 79 3a 61 72 6c 69 62 ine (array:arlib 4110: 3a 70 65 72 6d 75 74 61 74 69 6f 6e 2d 6d 61 74 :permutation-mat 4120: 72 69 78 20 2e 20 64 73 29 0a 20 20 28 6c 65 74 rix . ds). (let 4130: 2a 20 28 28 6e 20 28 6c 65 6e 67 74 68 20 64 73 * ((n (length ds 4140: 29 29 0a 20 20 20 20 20 20 20 20 20 28 61 72 72 )). (arr 4150: 20 28 6d 61 6b 65 2d 61 72 72 61 79 20 28 73 68 (make-array (sh 4160: 61 70 65 20 30 20 6e 20 30 20 6e 29 20 30 29 29 ape 0 n 0 n) 0)) 4170: 29 0a 20 20 20 20 28 64 6f 20 28 28 6b 20 30 20 ). (do ((k 0 4180: 28 2b 20 6b 20 31 29 29 0a 20 20 20 20 20 20 20 (+ k 1)). 4190: 20 20 28 64 73 20 64 73 20 28 63 64 72 20 64 73 (ds ds (cdr ds 41a0: 29 29 29 0a 20 20 20 20 20 20 28 28 3d 20 6b 20 ))). ((= k 41b0: 6e 29 29 0a 20 20 20 20 20 20 28 61 72 72 61 79 n)). (array 41c0: 2d 73 65 74 21 20 61 72 72 20 6b 20 28 63 61 72 -set! arr k (car 41d0: 20 64 73 29 20 31 29 29 0a 20 20 20 20 61 72 72 ds) 1)). arr 41e0: 29 29 0a 0a 3b 3b 3b 20 28 74 72 61 6e 73 70 6f ))..;;; (transpo 41f0: 73 65 20 61 72 72 20 6b 20 2e 2e 2e 29 0a 3b 3b se arr k ...).;; 4200: 3b 20 73 68 61 72 65 73 20 61 72 72 20 77 69 74 ; shares arr wit 4210: 68 20 70 65 72 6d 75 74 65 64 20 64 69 6d 65 6e h permuted dimen 4220: 73 69 6f 6e 73 2e 20 45 61 63 68 20 64 69 6d 65 sions. Each dime 4230: 6e 73 69 6f 6e 20 66 72 6f 6d 20 30 0a 3b 3b 3b nsion from 0.;;; 4240: 20 69 6e 63 6c 75 73 69 76 65 20 74 6f 20 72 61 inclusive to ra 4250: 6e 6b 20 65 78 63 6c 75 73 69 76 65 20 6d 75 73 nk exclusive mus 4260: 74 20 61 70 70 65 61 72 20 6f 6e 63 65 20 69 6e t appear once in 4270: 20 6b 20 2e 2e 2e 0a 0a 28 64 65 66 69 6e 65 20 k .....(define 4280: 28 74 72 61 6e 73 70 6f 73 65 20 61 20 2e 20 70 (transpose a . p 4290: 30 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 20 28 0). (let* ((r ( 42a0: 61 72 72 61 79 2d 72 61 6e 6b 20 61 29 29 0a 20 array-rank a)). 42b0: 20 20 20 20 20 20 20 20 28 70 65 72 6d 75 74 61 (permuta 42c0: 74 69 6f 6e 20 28 61 70 70 6c 79 20 61 72 72 61 tion (apply arra 42d0: 79 3a 61 72 6c 69 62 3a 70 65 72 6d 75 74 61 74 y:arlib:permutat 42e0: 69 6f 6e 2d 6d 61 74 72 69 78 0a 20 20 20 20 20 ion-matrix. 42f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4300: 20 20 20 20 20 20 20 20 28 69 66 20 28 70 61 69 (if (pai 4310: 72 3f 20 70 30 29 0a 20 20 20 20 20 20 20 20 20 r? p0). 4320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4330: 20 20 20 20 20 20 20 20 70 30 0a 20 20 20 20 20 p0. 4340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4350: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 6f 20 (do 4360: 28 28 64 73 20 27 28 29 20 28 63 6f 6e 73 20 64 ((ds '() (cons d 4370: 20 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ds)). 4380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4390: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 20 30 (d 0 43a0: 20 28 2b 20 64 20 31 29 29 29 0a 20 20 20 20 20 (+ d 1))). 43b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 43c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 (( 43d0: 3d 20 64 20 72 29 0a 20 20 20 20 20 20 20 20 20 = d r). 43e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 43f0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 72 65 ;; re 4400: 76 65 72 73 65 20 64 69 6d 65 6e 73 69 6f 6e 73 verse dimensions 4410: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 4420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4430: 20 20 20 20 20 64 73 29 29 29 29 29 0a 20 20 20 ds))))). 4440: 20 20 20 20 20 20 28 69 6e 76 65 72 73 65 2d 70 (inverse-p 4450: 65 72 6d 75 74 61 74 69 6f 6e 20 28 73 68 61 72 ermutation (shar 4460: 65 2d 61 72 72 61 79 20 70 65 72 6d 75 74 61 74 e-array permutat 4470: 69 6f 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 ion. 4480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 44a0: 61 72 72 61 79 2d 73 68 61 70 65 20 70 65 72 6d array-shape perm 44b0: 75 74 61 74 69 6f 6e 29 0a 20 20 20 20 20 20 20 utation). 44c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 44d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 44e0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 20 6b (lambda (r k 44f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 4500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ; 4520: 3b 20 74 72 61 6e 73 70 6f 73 65 0a 20 20 20 20 ; transpose. 4530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4550: 20 20 20 20 20 20 20 20 20 28 76 61 6c 75 65 73 (values 4560: 20 6b 20 72 29 29 29 29 29 0a 20 20 20 20 28 73 k r))))). (s 4570: 68 61 72 65 2d 61 72 72 61 79 0a 20 20 20 20 20 hare-array. 4580: 61 0a 20 20 20 20 20 28 61 72 72 61 79 3a 61 72 a. (array:ar 4590: 6c 69 62 3a 6d 61 74 72 69 78 2d 74 69 6d 65 73 lib:matrix-times 45a0: 20 70 65 72 6d 75 74 61 74 69 6f 6e 20 28 61 72 permutation (ar 45b0: 72 61 79 2d 73 68 61 70 65 20 61 29 29 0a 20 20 ray-shape a)). 45c0: 20 20 20 28 6c 61 6d 62 64 61 20 6b 73 30 0a 20 (lambda ks0. 45d0: 20 20 20 20 20 20 28 61 70 70 6c 79 20 76 61 6c (apply val 45e0: 75 65 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 ues. 45f0: 20 20 28 61 72 72 61 79 2d 3e 6c 69 73 74 0a 20 (array->list. 4600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a 4610: 72 72 61 79 3a 61 72 6c 69 62 3a 6d 61 74 72 69 rray:arlib:matri 4620: 78 2d 74 69 6d 65 73 0a 20 20 20 20 20 20 20 20 x-times. 4630: 20 20 20 20 20 20 20 20 69 6e 76 65 72 73 65 2d inverse- 4640: 70 65 72 6d 75 74 61 74 69 6f 6e 0a 20 20 20 20 permutation. 4650: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 (app 4660: 6c 79 20 61 72 72 61 79 20 28 73 68 61 70 65 20 ly array (shape 4670: 30 20 72 20 30 20 31 29 20 6b 73 30 29 29 29 29 0 r 0 1) ks0)))) 4680: 29 29 29 29 0a 0a 3b 3b 3b 20 28 73 68 61 72 65 ))))..;;; (share 4690: 2d 61 72 72 61 79 2f 69 6e 64 65 78 21 20 61 72 -array/index! ar 46a0: 72 61 79 20 73 75 62 73 68 61 70 65 20 70 72 6f ray subshape pro 46b0: 63 20 69 6e 64 65 78 29 0a 0a 28 64 65 66 69 6e c index)..(defin 46c0: 65 20 28 73 68 61 72 65 2d 61 72 72 61 79 2f 69 e (share-array/i 46d0: 6e 64 65 78 21 20 61 72 72 61 79 20 73 75 62 73 ndex! array subs 46e0: 68 61 70 65 20 70 72 6f 63 20 69 6e 64 65 78 29 hape proc index) 46f0: 0a 20 20 28 61 72 72 61 79 3a 73 68 61 72 65 2f . (array:share/ 4700: 69 6e 64 65 78 21 20 61 72 72 61 79 20 73 75 62 index! array sub 4710: 73 68 61 70 65 20 70 72 6f 63 20 69 6e 64 65 78 shape proc index 4720: 29 29 0a 0a 3b 3b 3b 20 54 61 6b 65 20 65 76 65 ))..;;; Take eve 4730: 72 79 20 6e 74 68 20 73 6c 69 63 65 20 61 6c 6f ry nth slice alo 4740: 6e 67 20 64 69 6d 65 6e 73 69 6f 6e 20 64 20 69 ng dimension d i 4750: 6e 74 6f 20 61 20 73 68 61 72 65 64 20 61 72 72 nto a shared arr 4760: 61 79 2e 20 54 68 69 73 0a 3b 3b 3b 20 70 72 65 ay. This.;;; pre 4770: 73 65 72 76 65 73 20 74 68 65 20 6f 72 69 67 69 serves the origi 4780: 6e 2e 0a 0a 28 64 65 66 69 6e 65 20 28 73 68 61 n...(define (sha 4790: 72 65 2d 6e 74 68 73 20 61 72 72 20 64 20 6e 29 re-nths arr d n) 47a0: 0a 20 20 28 6c 65 74 2a 20 28 28 62 6f 75 6e 64 . (let* ((bound 47b0: 73 20 28 61 72 72 61 79 2d 3e 76 65 63 74 6f 72 s (array->vector 47c0: 20 28 61 72 72 61 79 2d 73 68 61 70 65 20 61 72 (array-shape ar 47d0: 72 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 62 r))). (b 47e0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 62 6f 75 (vector-ref bou 47f0: 6e 64 73 20 28 2a 20 32 20 64 29 29 29 0a 20 20 nds (* 2 d))). 4800: 20 20 20 20 20 20 20 28 65 20 28 76 65 63 74 6f (e (vecto 4810: 72 2d 72 65 66 20 62 6f 75 6e 64 73 20 28 2b 20 r-ref bounds (+ 4820: 28 2a 20 32 20 64 29 20 31 29 29 29 29 0a 20 20 (* 2 d) 1)))). 4830: 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 62 (vector-set! b 4840: 6f 75 6e 64 73 20 28 2b 20 28 2a 20 32 20 64 29 ounds (+ (* 2 d) 4850: 20 31 29 20 28 2b 20 62 20 28 71 75 6f 74 69 65 1) (+ b (quotie 4860: 6e 74 20 28 2b 20 6e 20 28 2d 20 65 20 62 20 31 nt (+ n (- e b 1 4870: 29 29 20 6e 29 29 29 0a 20 20 20 20 28 73 68 61 )) n))). (sha 4880: 72 65 2d 61 72 72 61 79 0a 20 20 20 20 20 61 72 re-array. ar 4890: 72 0a 20 20 20 20 20 28 61 70 70 6c 79 20 73 68 r. (apply sh 48a0: 61 70 65 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 ape (vector->lis 48b0: 74 20 62 6f 75 6e 64 73 29 29 0a 20 20 20 20 20 t bounds)). 48c0: 28 6c 61 6d 62 64 61 20 6b 73 0a 20 20 20 20 20 (lambda ks. 48d0: 20 20 28 61 70 70 6c 79 20 76 61 6c 75 65 73 0a (apply values. 48e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l 48f0: 65 74 20 64 2f 6e 6b 20 28 28 75 20 30 29 20 28 et d/nk ((u 0) ( 4900: 6b 73 20 6b 73 29 29 0a 20 20 20 20 20 20 20 20 ks ks)). 4910: 20 20 20 20 20 20 20 20 28 69 66 20 28 3d 20 75 (if (= u 4920: 20 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 d). 4930: 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 28 2b (cons (+ 4940: 20 62 20 28 2a 20 6e 20 28 2d 20 28 63 61 72 20 b (* n (- (car 4950: 6b 73 29 20 62 29 29 29 20 28 63 64 72 20 6b 73 ks) b))) (cdr ks 4960: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 4970: 20 20 20 20 20 20 20 28 63 6f 6e 73 20 28 63 61 (cons (ca 4980: 72 20 6b 73 29 20 28 64 2f 6e 6b 20 28 2b 20 75 r ks) (d/nk (+ u 4990: 20 31 29 20 28 63 64 72 20 6b 73 29 29 29 29 29 1) (cdr ks))))) 49a0: 29 29 29 29 29 0a ))))).