arr-test.scm 21 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626
  1. ;; -*- coding: utf-8 -*-
  2. (test-begin "arrays" 234)
  3. ;;; array test
  4. ;;; 2001 Jussi Piitulainen
  5. ;;; 2002 Per Bothner modified to fit Kawa testing framework.
  6. ;;; 2006 Per Bothner modified to fit SRFI-64 testing framework.
  7. ;;; Simple tests
  8. (test-equal "shape" #t
  9. (and (array? (shape))
  10. (array? (shape -1 -1))
  11. (array? (shape -1 0))
  12. (array? (shape -1 1))
  13. (array? (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))))
  14. (test-equal "make-array" #t
  15. (and (array? (make-array (shape)))
  16. (array? (make-array (shape) *))
  17. (array? (make-array (shape -1 -1)))
  18. (array? (make-array (shape -1 -1) *))
  19. (array? (make-array (shape -1 1)))
  20. (array? (make-array (shape 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8 1 2 3 4) *))))
  21. (test-equal "array" #t
  22. (and (array? (array (shape) *))
  23. (array? (array (shape -1 -1)))
  24. (array? (array (shape -1 1) * *))
  25. (array? (array (shape 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8) *))))
  26. (test-equal 2 (array-rank (shape)))
  27. (test-equal 2 (array-rank (shape -1 -1)))
  28. (test-equal 2 (array-rank (shape -1 1)))
  29. (test-equal 2 (array-rank (shape 1 2 3 4 5 6 7 8)))
  30. (test-equal 0 (array-rank (make-array (shape))))
  31. (test-equal 1 (array-rank (make-array (shape -1 -1))))
  32. (test-equal 1 (array-rank (make-array (shape -1 1))))
  33. (test-equal 4 (array-rank (make-array (shape 1 2 3 4 5 6 7 8))))
  34. (test-equal 0 (array-rank (array (shape) *)))
  35. (test-equal 1 (array-rank (array (shape -1 -1))))
  36. (test-equal 1 (array-rank (array (shape -1 1) * *)))
  37. (test-equal 4 (array-rank (array (shape 1 2 3 4 5 6 7 8) *)))
  38. (test-equal 0 (array-start (shape -1 -1) 0))
  39. (test-equal 0 (array-start (shape -1 -1) 1))
  40. (test-equal 0 (array-start (shape -1 1) 0))
  41. (test-equal 0 (array-start (shape -1 1) 1))
  42. (test-equal 0 (array-start (shape 1 2 3 4 5 6 7 8) 0))
  43. (test-equal 0 (array-start (shape 1 2 3 4 5 6 7 8) 1))
  44. (test-equal 1 (array-end (shape -1 -1) 0))
  45. (test-equal 2 (array-end (shape -1 -1) 1))
  46. (test-equal 1 (array-end (shape -1 1) 0))
  47. (test-equal 2 (array-end (shape -1 1) 1))
  48. (test-equal 4 (array-end (shape 1 2 3 4 5 6 7 8) 0))
  49. (test-equal 2 (array-end (shape 1 2 3 4 5 6 7 8) 1))
  50. (test-equal -1 (array-start (make-array (shape -1 -1)) 0))
  51. (test-equal -1 (array-start (make-array (shape -1 1)) 0))
  52. (test-equal 1 (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 0))
  53. (test-equal 3 (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 1))
  54. (test-equal 5 (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 2))
  55. (test-equal 7 (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 3))
  56. (test-equal -1 (array-end (make-array (shape -1 -1)) 0))
  57. (test-equal 1 (array-end (make-array (shape -1 1)) 0))
  58. (test-equal 2 (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 0))
  59. (test-equal 4 (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 1))
  60. (test-equal 6 (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 2))
  61. (test-equal 8 (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 3))
  62. ;; array-start of array
  63. (test-equal -1 (array-start (array (shape -1 -1)) 0))
  64. (test-equal -1 (array-start (array (shape -1 1) * *) 0))
  65. (test-equal 1 (array-start (array (shape 1 2 3 4 5 6 7 8) *) 0))
  66. (test-equal 3 (array-start (array (shape 1 2 3 4 5 6 7 8) *) 1))
  67. (test-equal 5 (array-start (array (shape 1 2 3 4 5 6 7 8) *) 2))
  68. (test-equal 7 (array-start (array (shape 1 2 3 4 5 6 7 8) *) 3))
  69. ;; array-end of array
  70. (test-equal -1 (array-end (array (shape -1 -1)) 0))
  71. (test-equal 1 (array-end (array (shape -1 1) * *) 0))
  72. (test-equal 2 (array-end (array (shape 1 2 3 4 5 6 7 8) *) 0))
  73. (test-equal 4 (array-end (array (shape 1 2 3 4 5 6 7 8) *) 1))
  74. (test-equal 6 (array-end (array (shape 1 2 3 4 5 6 7 8) *) 2))
  75. (test-equal 8 (array-end (array (shape 1 2 3 4 5 6 7 8) *) 3))
  76. ;; array-ref of make-array with arguments
  77. (test-equal 'a (array-ref (make-array (shape) 'a)))
  78. (test-equal 'b (array-ref (make-array (shape -1 1) 'b) -1))
  79. (test-equal 'c (array-ref (make-array (shape -1 1) 'c) 0))
  80. (test-equal 'd (array-ref (make-array (shape 1 2 3 4 5 6 7 8) 'd) 1 3 5 7))
  81. ;; array-ref of make-array with vector
  82. (test-equal 'a (array-ref (make-array (shape) 'a) '#()))
  83. (test-equal 'b (array-ref (make-array (shape -1 1) 'b) '#(-1)))
  84. (test-equal 'c (array-ref (make-array (shape -1 1) 'c) '#(0)))
  85. (test-equal 'd (array-ref (make-array (shape 1 2 3 4 5 6 7 8) 'd) '#(1 3 5 7)))
  86. ;; array-ref of make-array with array
  87. (test-equal 'a (array-ref (make-array (shape) 'a) (array (shape 0 0))))
  88. (test-equal 'b (array-ref (make-array (shape -1 1) 'b) (array (shape 0 1) -1)))
  89. (test-equal 'c (array-ref (make-array (shape -1 1) 'c) (array (shape 0 1) 0)))
  90. (test-equal 'd (array-ref (make-array (shape 1 2 3 4 5 6 7 8) 'd)
  91. (array (shape 0 4) 1 3 5 7)))
  92. ;; array-set! of make-array with arguments
  93. (test-equal "set" 'a
  94. (let ((arr (make-array (shape) 'o)))
  95. (array-set! arr 'a)
  96. (array-ref arr)))
  97. (let ((arr (make-array (shape -1 1) 'o)))
  98. (array-set! arr -1 'b)
  99. (array-set! arr 0 'c)
  100. (test-equal 'b (array-ref arr -1))
  101. (test-equal 'c (array-ref arr 0)))
  102. (let ((arr (make-array (shape 1 2 3 4 5 6 7 8) 'o)))
  103. (array-set! arr 1 3 5 7 'd)
  104. (test-equal 'd (array-ref arr 1 3 5 7)))
  105. ;; array-set! of make-array with vector
  106. (let ((arr (make-array (shape) 'o)))
  107. (array-set! arr '#() 'a)
  108. (test-equal 'a (array-ref arr)))
  109. (let ((arr (make-array (shape -1 1) 'o)))
  110. (array-set! arr '#(-1) 'b)
  111. (array-set! arr '#(0) 'c)
  112. (test-equal 'b (array-ref arr -1))
  113. (test-equal 'c (array-ref arr 0)))
  114. (let ((arr (make-array (shape 1 2 3 4 5 6 7 8) 'o)))
  115. (array-set! arr '#(1 3 5 7) 'd)
  116. (test-equal 'd (array-ref arr 1 3 5 7)))
  117. ;; array-set! of make-array with array
  118. (let ((arr (make-array (shape) 'o)))
  119. (array-set! arr 'a)
  120. (test-equal 'a (array-ref arr)))
  121. (let ((arr (make-array (shape -1 1) 'o)))
  122. (array-set! arr (array (shape 0 1) -1) 'b)
  123. (array-set! arr (array (shape 0 1) 0) 'c)
  124. (test-equal 'b (array-ref arr -1))
  125. (test-equal 'c (array-ref arr 0)))
  126. (let ((arr (make-array (shape 1 2 3 4 5 6 7 8) 'o)))
  127. (array-set! arr (array (shape 0 4) 1 3 5 7) 'd)
  128. (test-equal 'd (array-ref arr 1 3 5 7)))
  129. ;;; Share and change:
  130. ;;;
  131. ;;; org brk swp box
  132. ;;;
  133. ;;; 0 1 1 2 5 6
  134. ;;; 6 a b 2 a b 3 d c 0 2 4 6 8: e
  135. ;;; 7 c d 3 e f 4 f e
  136. ;;; 8 e f
  137. ;; shared change
  138. (let* ((org (array (shape 6 9 0 2) 'a 'b 'c 'd 'e 'f))
  139. (brk (share-array
  140. org
  141. (shape 2 4 1 3)
  142. (lambda (r k)
  143. (values
  144. (+ 6 (* 2 (- r 2)))
  145. (- k 1)))))
  146. (swp (share-array
  147. org
  148. (shape 3 5 5 7)
  149. (lambda (r k)
  150. (values
  151. (+ 7 (- r 3))
  152. (- 1 (- k 5))))))
  153. (box (share-array
  154. swp
  155. (shape 0 1 2 3 4 5 6 7 8 9)
  156. (lambda _ (values 4 6))))
  157. (org-contents (lambda ()
  158. (list (array-ref org 6 0) (array-ref org 6 1)
  159. (array-ref org 7 0) (array-ref org 7 1)
  160. (array-ref org 8 0) (array-ref org 8 1))))
  161. (brk-contents (lambda ()
  162. (list (array-ref brk 2 1) (array-ref brk 2 2)
  163. (array-ref brk 3 1) (array-ref brk 3 2))))
  164. (swp-contents (lambda ()
  165. (list (array-ref swp 3 5) (array-ref swp 3 6)
  166. (array-ref swp 4 5) (array-ref swp 4 6))))
  167. (box-contents (lambda ()
  168. (list (array-ref box 0 2 4 6 8)))))
  169. (test-equal '(a b c d e f) (org-contents))
  170. (test-equal '(a b e f) (brk-contents))
  171. (test-equal '(d c f e) (swp-contents))
  172. (test-equal '(e) (box-contents))
  173. (array-set! org 6 0 'x)
  174. (test-equal '(x b c d e f) (org-contents))
  175. (test-equal '(x b e f) (brk-contents))
  176. (test-equal '(d c f e) (swp-contents))
  177. (test-equal '(e) (box-contents))
  178. (array-set! brk 3 1 'y)
  179. (test-equal '(x b c d y f) (org-contents))
  180. (test-equal '(x b y f) (brk-contents))
  181. (test-equal '(d c f y) (swp-contents))
  182. (test-equal '(y) (box-contents))
  183. (array-set! swp 4 5 'z)
  184. (test-equal '(x b c d y z) (org-contents))
  185. (test-equal '(x b y z) (brk-contents))
  186. (test-equal '(d c z y) (swp-contents))
  187. (test-equal '(y) (box-contents))
  188. (array-set! box 0 2 4 6 8 'e)
  189. (test-equal '(x b c d e z) (org-contents))
  190. (test-equal '(x b e z) (brk-contents))
  191. (test-equal '(d c z e) (swp-contents))
  192. (test-equal '(e) (box-contents)))
  193. ;;; Check that arrays copy the shape specification
  194. ;; array-set! of shape
  195. (let ((shp (shape 10 12)))
  196. (let ((arr (make-array shp))
  197. (ars (array shp * *))
  198. (art (share-array (make-array shp) shp (lambda (k) k))))
  199. (array-set! shp 0 0 '?)
  200. (array-set! shp 0 1 '!)
  201. (test-equal #2s32((10 12)) (array-shape arr))
  202. (test-equal 2 (array-rank shp))
  203. (test-equal 0 (array-start shp 0))
  204. (test-equal 1 (array-end shp 0))
  205. (test-equal 0 (array-start shp 1))
  206. (test-equal 2 (array-end shp 1))
  207. (test-equal '? (array-ref shp 0 0))
  208. (test-equal '! (array-ref shp 0 1))
  209. (test-equal 1 (array-rank arr))
  210. (test-equal 10 (array-start arr 0))
  211. (test-equal 12 (array-end arr 0))
  212. (test-equal 1 (array-rank ars))
  213. (test-equal 10 (array-start ars 0))
  214. (test-equal 12 (array-end ars 0))
  215. (test-equal 1 (array-rank art))
  216. (test-equal 10 (array-start art 0))
  217. (test-equal 12 (array-end art 0))))
  218. ;;; Check that index arrays work even when they share
  219. ;;;
  220. ;;; arr ixn
  221. ;;; 5 6 0 1
  222. ;;; 4 nw ne 0 4 6
  223. ;;; 5 sw se 1 5 4
  224. ;; array access with sharing index array
  225. (let ((arr (array (shape 4 6 5 7) 'nw 'ne 'sw 'se))
  226. (ixn (array (shape 0 2 0 2) 4 6 5 4)))
  227. (let ((col0 (share-array
  228. ixn
  229. (shape 0 2)
  230. (lambda (k) (values k 0))))
  231. (row0 (share-array
  232. ixn
  233. (shape 0 2)
  234. (lambda (k) (values 0 k))))
  235. (wor1 (share-array
  236. ixn
  237. (shape 0 2)
  238. (lambda (k) (values 1 (- 1 k)))))
  239. (cod (share-array
  240. ixn
  241. (shape 0 2)
  242. (lambda (k)
  243. (case k
  244. ((0) (values 1 0))
  245. ((1) (values 0 1))))))
  246. (box (share-array
  247. ixn
  248. (shape 0 2)
  249. (lambda (k) (values 1 0)))))
  250. (test-equal 'nw (array-ref arr col0))
  251. (test-equal 'ne (array-ref arr row0))
  252. (test-equal 'nw (array-ref arr wor1))
  253. (test-equal 'se (array-ref arr cod))
  254. (test-equal 'sw (array-ref arr box))
  255. (array-set! arr col0 'ul)
  256. (array-set! arr row0 'ur)
  257. (array-set! arr cod 'lr)
  258. (array-set! arr box 'll)
  259. (test-equal 'ul (array-ref arr 4 5))
  260. (test-equal 'ur (array-ref arr 4 6))
  261. (test-equal 'll (array-ref arr 5 5))
  262. (test-equal 'lr (array-ref arr 5 6))
  263. (array-set! arr wor1 'xx)
  264. (test-equal 'xx (array-ref arr 4 5))))
  265. ;;; Check that shape arrays work even when they share
  266. ;;;
  267. ;;; arr shp shq shr shs
  268. ;;; 1 2 3 4 0 1 0 1 0 1 0 1
  269. ;;; 1 10 12 16 20 0 10 12 0 12 20 0 10 10 0 12 12
  270. ;;; 2 10 11 12 13 1 10 11 1 11 13 1 11 12 1 12 12
  271. ;;; 2 12 16
  272. ;;; 3 13 20
  273. ;; sharing shape array
  274. (let ((arr (array (shape 1 3 1 5) 10 12 16 20 10 11 12 13)))
  275. (let ((shp (share-array
  276. arr
  277. (shape 0 2 0 2)
  278. (lambda (r k) (values (+ r 1) (+ k 1)))))
  279. (shq (share-array
  280. arr
  281. (shape 0 2 0 2)
  282. (lambda (r k) (values (+ r 1) (* 2 (+ 1 k))))))
  283. (shr (share-array
  284. arr
  285. (shape 0 4 0 2)
  286. (lambda (r k) (values (- 2 k) (+ r 1)))))
  287. (shs (share-array
  288. arr
  289. (shape 0 2 0 2)
  290. (lambda (r k) (values 2 3)))))
  291. (let ((arr-p (make-array shp)))
  292. (test-equal 2 (array-rank arr-p))
  293. (test-equal 10 (array-start arr-p 0))
  294. (test-equal 12 (array-end arr-p 0))
  295. (test-equal 10 (array-start arr-p 1))
  296. (test-equal 11 (array-end arr-p 1)))
  297. (let ((arr-q (array shq * * * * * * * * * * * * * * * *)))
  298. (test-equal 2 (array-rank arr-q))
  299. (test-equal 12 (array-start arr-q 0))
  300. (test-equal 20 (array-end arr-q 0))
  301. (test-equal 11 (array-start arr-q 1))
  302. (test-equal 13 (array-end arr-q 1)))
  303. (let ((arr-r (share-array
  304. (array (shape) *)
  305. shr
  306. (lambda _ (values)))))
  307. (test-equal 4 (array-rank arr-r))
  308. (test-equal 10 (array-start arr-r 0))
  309. (test-equal 10 (array-end arr-r 0))
  310. (test-equal 11 (array-start arr-r 1))
  311. (test-equal 12 (array-end arr-r 1))
  312. (test-equal 12 (array-start arr-r 2))
  313. (test-equal 16 (array-end arr-r 2))
  314. (test-equal 13 (array-start arr-r 3))
  315. (test-equal 20 (array-end arr-r 3)))
  316. (let ((arr-s (make-array shs)))
  317. (test-equal 2 (array-rank arr-s))
  318. (test-equal 12 (array-start arr-s 0))
  319. (test-equal 12 (array-end arr-s 0))
  320. (test-equal 12 (array-start arr-s 1))
  321. (test-equal 12 (array-end arr-s 1)))
  322. (let ((arr-s (make-array shs)))
  323. (test-equal 2 (array-rank arr-s))
  324. (test-equal 12 (array-start arr-s 0))
  325. (test-equal 12 (array-end arr-s 0))
  326. (test-equal 12 (array-start arr-s 1))
  327. (test-equal 12 (array-end arr-s 1)))))
  328. ;; sharing with sharing subshape
  329. (let ((super (array (shape 4 7 4 7)
  330. 1 * *
  331. * 2 *
  332. * * 3))
  333. (subshape (share-array
  334. (array (shape 0 2 0 3)
  335. * 4 *
  336. * 7 *)
  337. (shape 0 1 0 2)
  338. (lambda (r k)
  339. (values k 1)))))
  340. (let ((sub (share-array super subshape (lambda (k) (values k k)))))
  341. ;(array-equal? subshape (shape 4 7))
  342. (test-equal 2 (array-rank subshape))
  343. (test-equal 0 (array-start subshape 0))
  344. (test-equal 1 (array-end subshape 0))
  345. (test-equal 0 (array-start subshape 1))
  346. (test-equal 2 (array-end subshape 1))
  347. (test-equal 4 (array-ref subshape 0 0))
  348. (test-equal 7 (array-ref subshape 0 1))
  349. ;(array-equal? sub (array (shape 4 7) 1 2 3))
  350. (test-equal 1 (array-rank sub))
  351. (test-equal 4 (array-start sub 0))
  352. (test-equal 7 (array-end sub 0))
  353. (test-equal 1 (array-ref sub 4))
  354. (test-equal 2 (array-ref sub 5))
  355. (test-equal 3 (array-ref sub 6))))
  356. ;; Bug reported by Chris Dean <ctdean@mercedsystems.com>
  357. (define a-2-9 (make-array (shape 0 2 0 9)))
  358. (array-set! a-2-9 1 3 'e)
  359. (test-equal 'e (array-ref a-2-9 1 3))
  360. ;; Savannah [bug #4310] share-array edge case. All these tests should
  361. ;; return ok without an error or IndexOutOfBoundsException
  362. (define (make-simple-affine ndims hibound)
  363. (lambda (i)
  364. (if (> i hibound)
  365. (error "index out of bounds" i hibound))
  366. (apply values (vector->list (make-vector ndims i)))))
  367. (define four-dee-array (array (shape 0 2 0 2 0 2 0 2)
  368. 'a 'b 'c 'd 'e 'f 'g 'h
  369. 'i 'j 'k 'l 'm 'n 'o 'p))
  370. (define four-dee-lil-array (make-array (shape 0 1 0 1 0 1 0 1) 'ok))
  371. (test-equal 'ok
  372. (array-ref
  373. (share-array four-dee-lil-array (shape 0 1) (make-simple-affine 4 0))
  374. 0))
  375. (test-equal 'a
  376. (array-ref
  377. (share-array four-dee-array (shape 0 1) (make-simple-affine 4 0))
  378. 0))
  379. (test-equal 'a
  380. (array-ref
  381. (share-array four-dee-array (shape 0 2) (make-simple-affine 4 1))
  382. 0))
  383. (test-equal
  384. '(a p)
  385. (map
  386. (lambda (i)
  387. (array-ref
  388. (share-array four-dee-array (shape 0 2) (make-simple-affine 4 1))
  389. i))
  390. '(0 1)))
  391. (test-equal 'p
  392. (array-ref
  393. (share-array four-dee-array (shape 1 2) (make-simple-affine 4 1))
  394. 1))
  395. ;;; Kawa-specific tests
  396. (let* ((arr (make-array (shape 0 2 1 5) @[100 <: 108]))
  397. (a1 (array-index-ref arr 1 [2 <: 5]))
  398. (a2 (array-index-share arr 1 [2 <=: 4]))
  399. (v1 (array->vector arr))
  400. (v2 (array-flatten arr)))
  401. (test-equal 8 (array-size arr))
  402. (test-equal #(105 106 107) (vector @a1))
  403. (test-equal #(105 106 107) a2)
  404. (test-equal #(100 101 102 103 104 105 106 107) v1)
  405. (test-equal #(100 101 102 103 104 105 106 107) v2)
  406. (set! (arr 1 3) 206)
  407. (test-equal #(105 106 107) a1)
  408. (test-equal #(105 206 107) a2)
  409. (test-error (set! (a1 0) 99))
  410. (test-equal 107 (arr 1 4))
  411. (set! (a2 2) 207)
  412. (test-equal #(100 101 102 103 104 105 206 207) v1)
  413. (test-equal #(100 101 102 103 104 105 106 107) v2)
  414. (test-equal #(105 106 107) a1)
  415. (test-equal #(105 206 207) a2)
  416. (test-equal 207 (arr 1 4))
  417. )
  418. ;; Similar but use plain array (rather than range) for selection
  419. (let* ((arr (make-array (shape 0 2 1 5) @[100 <: 108]))
  420. (a1 (array-index-ref arr 1 [2 3 4]))
  421. (a2 (array-index-share arr 1 [2 3 4])))
  422. (test-equal #(105 106 107) a1)
  423. (test-equal #(105 106 107) a2)
  424. (set! (arr 1 3) 206)
  425. (test-equal #(105 106 107) a1)
  426. (test-equal #(105 206 107) a2)
  427. (test-error (set! (a1 0) 99))
  428. (test-equal 107 (arr 1 4))
  429. (set! (a2 2) 207)
  430. (test-equal #(105 106 107) a1)
  431. (test-equal #(105 206 207) a2)
  432. (test-equal 207 (arr 1 4))
  433. (array-fill! a2 42)
  434. (test-equal #(100 101 102 103 104 42 42 42)
  435. (array-flatten arr)))
  436. (test-equal #2a:2@1:3((9 8 7) (10 9 8))
  437. (build-array [2 [1 <: 4]]
  438. (lambda (ind)
  439. (let ((x (ind 0)) (y (ind 1)))
  440. (+ 10 x (- y))))))
  441. (define (make-sparse-array shape default-value)
  442. (let ((vals '()))
  443. (build-array shape
  444. (lambda (I)
  445. (let ((v (assoc I vals)))
  446. (if v (cdr v)
  447. default-value)))
  448. (lambda (I newval)
  449. (let ((v (assoc I vals)))
  450. (if v
  451. (set-cdr! v newval)
  452. (set! vals (cons (cons I newval) vals))))))))
  453. (define sarr (make-sparse-array [3 4] -1))
  454. (array-set! sarr 1 1 10)
  455. (array-set! sarr 2 3 23)
  456. (array-set! sarr 1 1 11)
  457. (test-equal #2a((-1 -1 -1 -1) (-1 11 -1 -1) (-1 -1 -1 23)) sarr)
  458. (test-equal &{&-
  459. #2a@10:2:3
  460. ║10│ 9│8║
  461. ╟──┼──┼─╢
  462. ║11│10│9║
  463. ╚══╧══╧═╝}
  464. (format-array
  465. (build-array [[10 <: 12] 3]
  466. (lambda (ind)
  467. (let ((x (ind 0)) (y (ind 1)))
  468. (- x y))))))
  469. (test-equal &{&-
  470. #2a:2:3═╗
  471. ║12│3│ 4║
  472. ╟──┼─┼──╢
  473. ║ 5│9│11║
  474. ╚══╧═╧══╝}
  475. (format-array #2a((12 3 4) (5 9 11)) #f))
  476. (test-equal &{&-
  477. #2a:2:4═╤═══╗
  478. ║ab│c│d │e ║
  479. ╟──┼─┼──┼───╢
  480. ║f │g│hi│jkl║
  481. ╚══╧═╧══╧═══╝}
  482. (format-array #2a((ab c d e) (f g hi jkl))))
  483. (test-equal &{&-
  484. #2s8:2:3╤═══╗
  485. ║012│003│004║
  486. ╟───┼───┼───╢
  487. ║005│-09│011║
  488. ╚═══╧═══╧═══╝}
  489. (format-array #2S8((12 3 4) (5 -9 11)) "~3,'0d"))
  490. (test-equal &{&-
  491. #3a:2:2:3═╗
  492. ║ab│c │d ║
  493. ╟──┼───┼──╢
  494. ║e │f │gh║
  495. ╠══╪═══╪══╣
  496. ║i │j │k ║
  497. ╟──┼───┼──╢
  498. ║lm│nop│q ║
  499. ╚══╧═══╧══╝}
  500. (format-array #3a(((ab c d) (e f gh)) ((i j k) (lm nop q)))))
  501. (test-equal &{&-
  502. #2a:2:3════╤═════════╗
  503. ║ 334│4545│#2f32:1:2║
  504. ║ │ │║5.0│6.0║║
  505. ║ │ │╚═══╧═══╝║
  506. ╟─────┼────┼─────────╢
  507. ║78987│abc │#2a══╗ ║
  508. ║ │defg│║1│ 2║ ║
  509. ║ │hi │╟─┼──╢ ║
  510. ║ │ │║3│14║ ║
  511. ║ │ │╚═╧══╝ ║
  512. ╚═════╧════╧═════════╝}
  513. (format-array
  514. #2a((334 4545 #2f32((5 6))) (78987 "abc\ndefg\nhi" #2A((1 2) (3 14))))))
  515. (test-equal "#0a -02" (format-array #0a -2 #f "~3,'0d"))
  516. (test-equal "#2a@1:3:0 ()"
  517. (format-array #2a@1:3:0()))
  518. (let ((arr #2a@1:2:3((a -9 "c") (d 153 "ef"))))
  519. (test-equal "#2a@1:2:3((a -9 c) (d 153 ef))"
  520. (format "~a" arr))
  521. (test-equal #2s32((1 3) (0 3)) (array-shape arr)))
  522. (test-equal #2s32((0 3) (2 5) (0 9) (-1 3))
  523. (->shape `#(3 (2 5) 9 ,[-1 size: 4])))
  524. (test-equal &{#2a@1:2:3((a -9 "c") (d 153 "ef"))}
  525. (format "~w" #2a@1:2:3((a -9 "c") (d 153 "ef"))))
  526. (test-equal [2 5] [2 by: 3 <: 8])
  527. (test-equal [2 5 8] [2 by: 3 <=: 8])
  528. (test-equal [1 4 7 10] [1 by: 3 size: 4])
  529. (test-equal [3 4 5 6] [3 size: 4])
  530. (test-equal [2 5 8] [2 by: 3 <: 9])
  531. (test-equal [2 5 8 11] [2 by: 3 <=: 11])
  532. (test-equal [2 5 8 11] [2 by: 3 <=: 13])
  533. (test-equal ([1 by: 2 ] [1 <: 10]) [3 5 7 9 11 13 15 17 19])
  534. (test-equal [20 20 20 20 20] ([20 by: 0] [0 <: 5]))
  535. (test-equal [3.0 3.5 4.0 4.5 5.0 5.5 6.0] [3.0 by: 0.5 <=: 6])
  536. (test-equal [4.0 3.5 3.0] [4.0 by: -0.5 >=: 3.0])
  537. (test-error [20 by: 2 >: 30])
  538. (test-error [20 by: -2 <=: 10])
  539. (define arr1 (array #2a((1 4) (0 4))
  540. 10 11 12 13 20 21 22 23 30 31 32 33))
  541. (test-equal #2a@1:3:4((10 11 12 13) (20 21 22 23) (30 31 32 33))
  542. arr1)
  543. (test-equal 23 (arr1 2 3))
  544. (test-equal #(23 21) (arr1 2 [3 1]))
  545. (test-equal #2a((23 21 23) (13 11 13))
  546. (arr1 [2 1] [3 1 3]))
  547. (test-equal #2a((11 12 13) (21 22 23))
  548. (arr1 [1 <: 3] [1 <: 4]))
  549. (test-equal #(23 22 21 20)
  550. (arr1 2 [>:]))
  551. (test-equal #(12 22 32)
  552. (arr1 [<:] 2))
  553. (test-equal #2a((10 11 12 13) (20 21 22 23) (30 31 32 33))
  554. (arr1 [<:] [<:]))
  555. (test-equal #3a(((23 21) (23 22)) ((13 11) (13 12)))
  556. (arr1 [2 1] #2a((3 1) (3 2))))
  557. (test-equal #2a((13) (23) (33))
  558. (arr1 [<:] [3]))
  559. (test-equal #2a((13 13 13 13 13) (23 23 23 23 23) (33 33 33 33 33))
  560. (arr1 [<:] [3 by: 0 size: 5]))
  561. (test-equal #3a:3@1:2:2(((10 11) (12 13)) ((20 21) (22 23)) ((30 31) (32 33)))
  562. (array-transform arr1 #2a((0 3) (1 3) (0 2))
  563. (lambda (ix) (let ((i (ix 0)) (j (ix 1)) (k (ix 2)))
  564. [(+ i 1)
  565. (+ (* 2 (- j 1)) k)]))))
  566. (test-equal &{&-
  567. #2u32@2:2@3:2
  568. ║001│002║
  569. ╟───┼───╢
  570. ║002│003║
  571. ╚═══╧═══╝}
  572. (format-array #2u32@2@3((1 2) (2 3)) "~3,'0d"))
  573. (test-end)