test.scm 53 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319
  1. ; -*- mode: scheme; coding: utf-8 -*-
  2. ; Replacement for Guile C-based array system - Tests
  3. ; (c) Daniel Llorens - 2016-2021
  4. ; This library is free software; you can redistribute it and/or modify it under
  5. ; the terms of the GNU General Public License as published by the Free
  6. ; Software Foundation; either version 3 of the License, or (at your option) any
  7. ; later version.
  8. ; Run with $GUILE -L mod test.scm
  9. (import (newra) (newra tools) (newra read) (newra test misc) (newra test map-ladder)
  10. (srfi :64) (srfi :26) (srfi :8) (only (srfi :1) fold iota drop)
  11. (ice-9 match) (only (rnrs base) vector-map vector-for-each))
  12. (define (ra->string ra) (call-with-output-string (cut display ra <>)))
  13. (define (string->ra s) (call-with-input-string s read))
  14. (set! test-log-to-file #f)
  15. (test-begin "newra")
  16. ; -----------------------
  17. ; auxiliary functions
  18. ; -----------------------
  19. (test-equal
  20. 6 ((@ (newra vector) vector-fold) (lambda (a c) (+ c (car a))) 0 #((1) (2) (3))))
  21. (test-equal
  22. #(2 3) ((@ (newra vector) vector-copy) #(1 2 3 4) 1 3))
  23. ; loop-fun from (newra test misc) FIXME may become ra-index-map!
  24. (define ra0 (make-ra-root (make-aseq) (c-dims)))
  25. (define ra1 (make-ra-root (make-aseq) (c-dims 2)))
  26. (define ra2 (make-ra-root (make-aseq) (c-dims 2 3)))
  27. (define ra3 (make-ra-root (make-aseq) (c-dims 2 3 4)))
  28. (test-assert (ra-equal? (make-ra-root #(1 2 3)) (list->ra 1 '(1 2 3))))
  29. (test-assert (not (ra-equal? (make-ra 0 3 4) (make-ra 0 3)))) ; ra-equal? doesn't rank-extend
  30. (test-equal "0"
  31. (with-output-to-string (lambda () (%ra-loop (vector-map dim-len (ra-dims ra0)) 0 () (display (ra0))))))
  32. (test-equal "01"
  33. (with-output-to-string (lambda () (%ra-loop (vector-map dim-len (ra-dims ra1)) 1 (i) (display (+ i))))))
  34. (test-equal "012123"
  35. (with-output-to-string (lambda () (%ra-loop (vector-map dim-len (ra-dims ra2)) 2 (i j) (display (+ i j))))))
  36. (test-equal "012312342345123423453456"
  37. (with-output-to-string (lambda () (%ra-loop (vector-map dim-len (ra-dims ra3)) 3 (i j k) (display (+ i j k))))))
  38. (define a0 (ra->array (as-ra ra0 #:type #t)))
  39. (define a1 (ra->array (as-ra ra1 #:type #t)))
  40. (define a2 (ra->array (as-ra ra2 #:type #t)))
  41. (define a3 (ra->array (as-ra ra3 #:type #t)))
  42. (test-equal "(0)"
  43. (call-with-output-string (lambda (o) (ra-loop ra0 (lambda () (format o "(~a)" (ra0)))))))
  44. (test-equal "(0)(1)"
  45. (call-with-output-string (lambda (o) (ra-loop ra1 (lambda (i) (format o "(~a)" (ra1 i)))))))
  46. (test-equal "(0)(1)(2)(3)(4)(5)"
  47. (call-with-output-string (lambda (o) (ra-loop ra2 (lambda (i j) (format o "(~a)" (ra2 i j)))))))
  48. (test-equal "(0)(1)(2)(3)(4)(5)(6)(7)(8)(9)(10)(11)(12)(13)(14)(15)(16)(17)(18)(19)(20)(21)(22)(23)"
  49. (call-with-output-string (lambda (o) (ra-loop ra3 (lambda (i j k) (format o "(~a)" (ra3 i j k)))))))
  50. (test-equal "(0)"
  51. (call-with-output-string (lambda (o) (array-loop a0 (lambda () (format o "(~a)" (array-ref a0)))))))
  52. (test-equal "(0)(1)"
  53. (call-with-output-string (lambda (o) (array-loop a1 (lambda (i) (format o "(~a)" (array-ref a1 i)))))))
  54. (test-equal "(0)(1)(2)(3)(4)(5)"
  55. (call-with-output-string (lambda (o) (array-loop a2 (lambda (i j) (format o "(~a)" (array-ref a2 i j)))))))
  56. (test-equal "(0)(1)(2)(3)(4)(5)(6)(7)(8)(9)(10)(11)(12)(13)(14)(15)(16)(17)(18)(19)(20)(21)(22)(23)"
  57. (call-with-output-string (lambda (o) (array-loop a3 (lambda (i j k) (format o "(~a)" (array-ref a3 i j k)))))))
  58. ; -----------------------
  59. ; array->ra, ra->array, printers
  60. ; -----------------------
  61. (let* ((ra0 (array->ra #(1 2 3)))
  62. (ra1 (array->ra #@1(1 2 3)))
  63. (ra2 (array->ra #2((1 2) (3 4))))
  64. (ra3 (array->ra #2@1@1((1 2) (3 4))))
  65. (ra4 (array->ra #0(99)))
  66. (ra5 (array->ra #0s64(99)))
  67. (ra6 (array->ra #0((a)))))
  68. (test-equal (ra->string ra0) "#%1:3(1 2 3)")
  69. (test-equal (ra->string ra1) "#%1@1:3(1 2 3)")
  70. (test-equal (ra->string ra2) "#%2:2:2((1 2) (3 4))")
  71. (test-equal (ra->string ra3) "#%2@1:2@1:2((1 2) (3 4))")
  72. (parameterize ((*ra-parenthesized-rank-zero* #t))
  73. (test-equal (ra->string ra4) "#%0(99)")
  74. (test-equal (ra->string ra5) "#%0s64(99)")
  75. (test-equal (ra->string ra6) "#%0((a))"))
  76. (parameterize ((*ra-parenthesized-rank-zero* #f))
  77. (test-equal (ra->string ra4) "#%0 99")
  78. (test-equal (ra->string ra5) "#%0s64 99")
  79. (test-equal (ra->string ra6) "#%0 (a)"))
  80. (test-equal #(1 2 3) (ra->array ra0))
  81. (test-equal #@1(1 2 3) (ra->array ra1))
  82. (test-equal #2((1 2) (3 4)) (ra->array ra2))
  83. (test-equal #2@1@1((1 2) (3 4)) (ra->array ra3))
  84. (test-equal #0(99) (ra->array ra4))
  85. (test-equal #0s64(99) (ra->array ra5))
  86. (test-equal #0((a)) (ra->array ra6)))
  87. ; dead axes
  88. (test-equal "#%2d:d:10((0 1 2 3 4 5 6 7 8 9))" (ra->string (ra-transpose (ra-i 10) 1)))
  89. ; printing of string elements (for example).
  90. (test-equal "#%0(\"hello\")" (ra->string (make-ra "hello")))
  91. (test-equal "#%1:2(\"hello\" \"bye\")" (ra->string (make-ra-root #("hello" "bye") (c-dims 2))))
  92. ; -----------------------
  93. ; ra-iota, ra-i
  94. ; -----------------------
  95. (test-equal "#%3d:2:3:4(((0 1 2 3) (4 5 6 7) (8 9 10 11)) ((12 13 14 15) (16 17 18 19) (20 21 22 23)))"
  96. (ra->string (ra-i 2 3 4)))
  97. (test-equal "#%3d:2:0:4(() ())"
  98. (ra->string (ra-i 2 0 4)))
  99. (test-equal "#%0d(0)"
  100. (ra->string (ra-i)))
  101. (test-equal "#%1d:4(9 8 7 6)"
  102. (ra->string (ra-iota 4 9 -1)))
  103. (test-equal "#%1d:4(9 10 11 12)"
  104. (ra->string (ra-iota 4 9)))
  105. (test-equal "#%1d:0()"
  106. (ra->string (ra-iota 0)))
  107. ; default ra-iota has lo #f so it will match any lower bound and act as index placeholder.
  108. (test-equal "#%1@2:3(2 3 4)"
  109. (ra->string (ra-copy! (make-ra-new #t 'o (c-dims '(2 4))) (ra-iota))))
  110. ; mixing dead and unbounded axes
  111. (let ((a (ra-i #f #t #f 2 3)))
  112. (test-equal 5 (a 0 0 0 1 2))
  113. (test-equal 5 (a 0 0 1 1 2))
  114. (test-equal 11 (a 0 1 0 1 2))
  115. ; reducing the unbounded axis
  116. (test-equal "#%4d:d:d:2:3((((6 7 8) (9 10 11))))"
  117. (ra->string (ra-from a #t 1))))
  118. ; unbounded both ways
  119. (let ((a (ra-i #f '(#f #t) #f 2 3)))
  120. (test-equal "#%4d:d:d:2:3((((-6 -5 -4) (-3 -2 -1))))"
  121. (ra->string (ra-from a #t -1 #t))))
  122. ; 2/3/4 use moving slice but 1 uses direct slicing in the lo..hi range.
  123. (define (test-lof rsfe)
  124. (test-equal
  125. "(#%0(o) #%0d(2))(#%0(o) #%0d(3))(#%0(o) #%0d(4))"
  126. (call-with-output-string
  127. (lambda (o)
  128. (rsfe 1 (lambda a (display a o)) (make-ra-new #t 'o (c-dims '(2 4))) (ra-iota))))))
  129. (test-lof ra-slice-for-each-1)
  130. (test-lof ra-slice-for-each-2)
  131. (test-lof ra-slice-for-each-3)
  132. (test-lof ra-slice-for-each-4)
  133. ; -----------------------
  134. ; make-ra-shared
  135. ; -----------------------
  136. (let* ((ra2 (array->ra #2((1 2) (3 4))))
  137. (ra3 (array->ra #2@1@1((1 2) (3 4))))
  138. (ra4 (array->ra #0(99))))
  139. (test-equal "#%0(99)" (ra->string (make-ra-shared ra4 (lambda () '()))))
  140. (test-equal "#%1:2(1 4)" (ra->string (make-ra-shared ra2 (lambda (i) (list i i)) 2)))
  141. (test-equal "#%1:2(1 3)" (ra->string (make-ra-shared ra2 (lambda (i) (list i 0)) 2)))
  142. (test-equal "#%1:2(2 4)" (ra->string (make-ra-shared ra2 (lambda (i) (list i 1)) 2)))
  143. (test-equal "#%1:2(1 2)" (ra->string (make-ra-shared ra2 (lambda (j) (list 0 j)) 2)))
  144. (test-equal "#%1:2(3 4)" (ra->string (make-ra-shared ra2 (lambda (j) (list 1 j)) 2)))
  145. (test-equal "#%1@1:2(1 4)" (ra->string (make-ra-shared ra3 (lambda (i) (list i i)) '(1 2))))
  146. (test-equal "#%1@1:2(1 3)" (ra->string (make-ra-shared ra3 (lambda (i) (list i 1)) '(1 2))))
  147. (test-equal "#%1@1:2(2 4)" (ra->string (make-ra-shared ra3 (lambda (i) (list i 2)) '(1 2))))
  148. (test-equal "#%1@1:2(1 2)" (ra->string (make-ra-shared ra3 (lambda (j) (list 1 j)) '(1 2))))
  149. (test-equal "#%1@1:2(3 4)" (ra->string (make-ra-shared ra3 (lambda (j) (list 2 j)) '(1 2)))))
  150. ; -----------------------
  151. ; make-ra-new, make-ra
  152. ; -----------------------
  153. (let* ((ra5 (make-ra-new #t 0 (c-dims '(1 3) '(1 2)))))
  154. (array-index-map! (ra-root ra5) (lambda i i))
  155. (test-equal (ra->string ra5) "#%2@1:3@1:2(((0) (1)) ((2) (3)) ((4) (5)))")
  156. (test-equal 3 (ra-len ra5)))
  157. (let* ((ra5 (make-typed-ra 's64 0 '(1 3) '(1 2))))
  158. (array-index-map! (ra-root ra5) (lambda i (car i)))
  159. (test-equal (ra->string ra5) "#%2s64@1:3@1:2((0 1) (2 3) (4 5))")
  160. (test-equal 3 (ra-len ra5)))
  161. ; -----------------------
  162. ; make-ra-root
  163. ; -----------------------
  164. (define ra6 (make-ra-root #(1 2 3 4 5 6) (c-dims '(1 2) '(1 3))))
  165. (test-equal (ra->string ra6) "#%2@1:2@1:3((1 2 3) (4 5 6))")
  166. (define ra7a (make-ra-root (make-aseq 1) (c-dims '(1 2) '(1 3))))
  167. (test-equal (ra->string ra7a) "#%2d@1:2@1:3((1 2 3) (4 5 6))")
  168. (define ra7b (make-ra-root #(1 4 2 5 3 6) `#(,(make-dim 2 1 1) ,(make-dim 3 1 2)) -3))
  169. (test-equal (ra->string ra7b) "#%2@1:2@1:3((1 2 3) (4 5 6))")
  170. (test-equal 2 (ra-len ra6))
  171. (test-equal 2 (ra-len ra7a))
  172. (test-equal 2 (ra-len ra7b))
  173. ; -----------------------
  174. ; ra-slice, ra-ref, ra-cell
  175. ; -----------------------
  176. (define ra8 (make-ra-root (make-aseq 1) (c-dims '(1 2) '(1 3))))
  177. (test-equal 2 (ra-len ra8))
  178. (test-equal (ra->string (ra-cell ra8)) "#%2d@1:2@1:3((1 2 3) (4 5 6))")
  179. (test-equal (ra->string (ra-cell ra8 1)) "#%1d@1:3(1 2 3)")
  180. (test-equal (ra->string (ra-cell ra8 2)) "#%1d@1:3(4 5 6)")
  181. (test-equal 5 (ra-cell ra8 2 2))
  182. ; applicable!
  183. (test-equal (ra->string (ra8)) "#%2d@1:2@1:3((1 2 3) (4 5 6))")
  184. (test-equal (ra->string (ra8 1)) "#%1d@1:3(1 2 3)")
  185. (test-equal (ra->string (ra8 2)) "#%1d@1:3(4 5 6)")
  186. (test-equal 5 (ra8 2 2))
  187. (test-equal (ra->string (ra-slice ra8)) "#%2d@1:2@1:3((1 2 3) (4 5 6))")
  188. (test-equal (ra->string (ra-slice ra8 1)) "#%1d@1:3(1 2 3)")
  189. (test-equal (ra->string (ra-slice ra8 2)) "#%1d@1:3(4 5 6)")
  190. (test-equal (ra->string (ra-slice ra8 2 2)) "#%0d(5)")
  191. (test-equal 5 (ra-ref (ra-slice ra8 2 2)))
  192. (test-assert (throws-exception? 'bad-number-of-indices (lambda () (ra-ref ra8))))
  193. (test-assert (throws-exception? 'bad-number-of-indices (lambda () (ra-ref ra8 1))))
  194. (test-assert (throws-exception? 'dim-check-out-of-range (lambda () (ra-ref ra8 0 0))))
  195. (test-assert (throws-exception? 'dim-check-out-of-range (lambda () (ra-ref ra8 3 1))))
  196. (test-equal 1 (ra-ref ra8 1 1))
  197. (test-equal 2 (ra-ref ra8 1 2))
  198. (test-equal 3 (ra-ref ra8 1 3))
  199. (test-equal 4 (ra-ref ra8 2 1))
  200. (test-equal 5 (ra-ref ra8 2 2))
  201. (test-equal 6 (ra-ref ra8 2 3))
  202. ; -----------------------
  203. ; ra-transpose (see below for ra-transpose with dead axes)
  204. ; -----------------------
  205. (test-equal (ra->string (ra-transpose ra7a 1 0)) "#%2d@1:3@1:2((1 4) (2 5) (3 6))")
  206. (test-equal (ra->string (ra-transpose ra7b 1 0)) "#%2@1:3@1:2((1 4) (2 5) (3 6))")
  207. (test-equal (ra->string (ra-transpose ra7a 0 1)) "#%2d@1:2@1:3((1 2 3) (4 5 6))")
  208. (test-equal (ra->string (ra-transpose ra7b 0 1)) "#%2@1:2@1:3((1 2 3) (4 5 6))")
  209. (test-equal (ra->string (ra-transpose ra7a 0 0)) "#%1d@1:2(1 5)")
  210. (test-equal (ra->string (ra-transpose ra7b 0 0)) "#%1@1:2(1 5)")
  211. (test-assert (throws-exception? 'bad-number-of-axes (lambda () (ra-transpose (ra-iota 3) 0 1))))
  212. (let ((ra0 (make-ra 99))) (test-assert (ra-equal? ra0 (ra-transpose ra0))))
  213. ; other cases
  214. (test-equal (ra->string (ra-transpose ra7a)) "#%2d@1:2@1:3((1 2 3) (4 5 6))")
  215. (test-equal (ra->string (ra-transpose ra7b)) "#%2@1:2@1:3((1 2 3) (4 5 6))")
  216. (let ((ra1 (ra-i 3)))
  217. (test-assert (ra-equal? (ra-transpose ra1) (ra-transpose ra1 0)))
  218. (test-eq (ra-root ra1) (ra-root (ra-transpose ra1 0))))
  219. (let ((ra2 (ra-i 3 4)))
  220. (test-assert (ra-equal? (ra-transpose ra2) (ra-transpose ra2 0 1)))
  221. (test-eq (ra-root ra2) (ra-root (ra-transpose ra2))))
  222. (let ((ra3 (ra-i 3 4 5)))
  223. (test-assert (ra-equal? (ra-transpose ra3) (ra-transpose ra3 0 1 2)))
  224. (test-eq (ra-root ra3) (ra-root (ra-transpose ra3)))
  225. (test-assert (ra-equal? (ra-transpose ra3 1 0) (ra-transpose ra3 1 0 2)))
  226. ; these two have a dead axes so the cannot be matched one to the other.
  227. (test-equal (ra-dims (ra-transpose ra3 1)) (ra-dims (ra-transpose ra3 1 2 3))))
  228. ; untranspose
  229. (let* ((a (ra-copy #t (ra-i 2 3 4)))
  230. (b (ra-transpose a 2 0 1))
  231. (c (ra-untranspose b 2 0 1)))
  232. (test-eq (ra-root a) (ra-root c))
  233. (test-assert (ra-equal? a c))
  234. (test-equal (ra-dims a) (ra-dims c)))
  235. (let* ((a (ra-copy #t (ra-i 2 3 4 5)))
  236. (b (ra-transpose a 2 0 1))
  237. (c (ra-untranspose b 2 0 1)))
  238. (test-eq (ra-root a) (ra-root c))
  239. (test-assert (ra-equal? a c))
  240. (test-equal (ra-dims a) (ra-dims c)))
  241. ; -----------------------
  242. ; ra-reverse
  243. ; -----------------------
  244. (let ((ra (ra-i 2 3 2)))
  245. (test-assert (ra-equal? ra (ra-reverse ra)))
  246. (test-equal "#%3d:2:3:2(((6 7) (8 9) (10 11)) ((0 1) (2 3) (4 5)))" (ra->string (ra-reverse ra 0)))
  247. (test-equal "#%3d:2:3:2(((4 5) (2 3) (0 1)) ((10 11) (8 9) (6 7)))" (ra->string (ra-reverse ra 1)))
  248. (test-equal "#%3d:2:3:2(((1 0) (3 2) (5 4)) ((7 6) (9 8) (11 10)))" (ra->string (ra-reverse ra 2)))
  249. (test-equal "#%3d:2:3:2(((5 4) (3 2) (1 0)) ((11 10) (9 8) (7 6)))" (ra->string (ra-reverse ra 1 2)))
  250. (test-equal "#%3d:2:3:2(((7 6) (9 8) (11 10)) ((1 0) (3 2) (5 4)))" (ra->string (ra-reverse ra 2 0)))
  251. (test-assert (ra-equal? (ra-reverse ra 2 0) (ra-reverse ra 0 2)))
  252. (test-assert (ra-equal? (ra-reverse ra 2 0 1) (ra-reverse (ra-reverse (ra-reverse ra 0) 1) 2)))
  253. (test-eq (ra-root ra) (ra-root (ra-reverse ra 2 0))))
  254. (let ((ra (make-ra-root #(1 2 3 4) (vector (make-dim 4 -1)))))
  255. (test-equal "#%1@-1:4(4 3 2 1)" (ra->string (ra-reverse ra 0))))
  256. ; -----------------------
  257. ; ra-slice-for-each
  258. ; -----------------------
  259. (define ra-empty0 (make-ra-root (make-aseq 1) (c-dims '(1 0) '(2 1))))
  260. (define ra-empty1 (make-ra-root (make-aseq 1) (c-dims '(1 1) '(2 1))))
  261. (define ra-empty2 (make-ra-root (make-aseq 1) (c-dims '(1 0) '(2 2))))
  262. (test-equal 0 (ra-len ra-empty0))
  263. (test-equal 1 (ra-len ra-empty1))
  264. (test-equal 0 (ra-len ra-empty2))
  265. (for-each
  266. (lambda (ra-slice-for-each)
  267. (test-begin (procedure-name ra-slice-for-each))
  268. (test-equal "#%2d@1:0@2:0()\n"
  269. (call-with-output-string
  270. (lambda (s) (ra-slice-for-each 0 (lambda (o) (format s "~a\n" o)) ra-empty0))))
  271. (test-equal "#%2d@1:1@2:0(())\n"
  272. (call-with-output-string
  273. (lambda (s) (ra-slice-for-each 0 (lambda (o) (format s "~a\n" o)) ra-empty1))))
  274. (test-equal "#%2d@1:0@2:1()\n"
  275. (call-with-output-string
  276. (lambda (s) (ra-slice-for-each 0 (lambda (o) (format s "~a\n" o)) ra-empty2))))
  277. (test-equal "#%2@1:2@1:3((1 2 3) (4 5 6))\n"
  278. (call-with-output-string
  279. (lambda (s) (ra-slice-for-each 0 (lambda (o) (format s "~a\n" o)) ra6))))
  280. (test-equal "#%1@1:3(1 2 3)\n#%1@1:3(4 5 6)\n"
  281. (call-with-output-string
  282. (lambda (s) (ra-slice-for-each 1 (lambda (o) (format s "~a\n" o)) ra6))))
  283. (test-equal "1\n2\n3\n4\n5\n6\n"
  284. (call-with-output-string
  285. (lambda (s) (ra-slice-for-each 2 (lambda (o) (format s "~a\n" (ra-ref o))) ra6))))
  286. (test-equal "2\n4\n6\n8\n10\n12\n"
  287. (call-with-output-string
  288. (lambda (s) (ra-slice-for-each 2 (lambda (a b) (format s "~a\n" (+ (ra-ref a) (ra-ref b)))) ra6 ra7a))))
  289. (test-equal "2\n4\n6\n8\n10\n12\n"
  290. (call-with-output-string
  291. (lambda (s) (ra-slice-for-each 2 (lambda (a b) (format s "~a\n" (+ (ra-ref a) (ra-ref b)))) ra6 ra7b))))
  292. (test-equal "(#%2@1:2@1:3((1 2 3) (4 5 6)) #%2d@1:2@1:3((1 2 3) (4 5 6)) #%2@1:2@1:3((1 2 3) (4 5 6)))\n"
  293. (call-with-output-string
  294. (lambda (s) (ra-slice-for-each 0 (lambda x (format s "~a\n" x)) ra6 ra7a ra7b))))
  295. (test-equal "(#%1@1:3(1 2 3) #%1d@1:3(1 2 3) #%1@1:3(1 2 3))\n(#%1@1:3(4 5 6) #%1d@1:3(4 5 6) #%1@1:3(4 5 6))\n"
  296. (call-with-output-string
  297. (lambda (s) (ra-slice-for-each 1 (lambda x (format s "~a\n" x)) ra6 ra7a ra7b))))
  298. (test-equal "(#%0(1) #%0d(1) #%0(1))\n(#%0(2) #%0d(2) #%0(2))\n(#%0(3) #%0d(3) #%0(3))\n(#%0(4) #%0d(4) #%0(4))\n(#%0(5) #%0d(5) #%0(5))\n(#%0(6) #%0d(6) #%0(6))\n"
  299. (call-with-output-string
  300. (lambda (s) (ra-slice-for-each 2 (lambda x (format s "~a\n" x)) ra6 ra7a ra7b))))
  301. (test-end (procedure-name ra-slice-for-each)))
  302. (list ra-slice-for-each-1 ra-slice-for-each-2
  303. ra-slice-for-each-3 ra-slice-for-each-4))
  304. ; -----------------------
  305. ; ra-offset - from guile/test-suite/tests/arrays.test
  306. ; -----------------------
  307. (test-begin "ra-offset")
  308. ; plain vector
  309. (test-equal 0 (ra-offset (make-ra 0 4)))
  310. ; plain array rank 2
  311. (test-equal 0 (ra-offset (make-ra 0 4 4)))
  312. ; row of rank-2 array, I
  313. (test-equal 0 (ra-offset ((make-ra 0 5 3) 0)))
  314. ; row of rank-2 array, II
  315. (test-equal 4 (ra-offset ((make-ra 0 6 4) 1)))
  316. ; col of rank-2 array, I
  317. (test-equal 0 (ra-offset ((ra-transpose (make-ra 0 5 3) 1 0) 0)))
  318. ; col of rank-2 array, II
  319. (test-equal 1 (ra-offset ((ra-transpose (make-ra 0 6 4) 1 0) 1)))
  320. ; of inverted array; shared-array-root's doc is unclear as 'first' is unclear. But we do the same.
  321. (test-equal 2 (shared-array-offset (make-shared-array #(1 2 3) (lambda (i) (list (- 2 i))) 3)))
  322. (test-equal 2 (ra-offset (make-ra-shared (array->ra #(1 2 3)) (lambda (i) (list (- 2 i))) 3)))
  323. (test-end "ra-offset")
  324. ; -----------------------
  325. ; ra-slice-for-each compatibility - from guile/test-suite/tests/array-map.test
  326. ; -----------------------
  327. (for-each
  328. (match-lambda
  329. ((name ra-slice-for-each list->ra list->typed-ra make-ra ra-copy!
  330. make-ra-shared array->ra ra->array ra-set! ra-ref)
  331. (let ((test-name (format #f "~a" name)))
  332. (test-begin test-name)
  333. ; 1 argument frame rank 1
  334. (test-equal
  335. #2((1 3 9) (2 7 8))
  336. (ra->array
  337. (let* ((a (list->ra 2 '((9 1 3) (7 8 2)))))
  338. (ra-slice-for-each 1 (lambda (a) (sort! (ra->array a) <)) a)
  339. a)))
  340. ; 1 argument frame rank 1, non-zero base indices
  341. (test-equal
  342. #2@1@1((1 3 9) (2 7 8))
  343. (ra->array
  344. (let* ((a (make-ra *unspecified* '(1 2) '(1 3)))
  345. (b (array->ra #2@1@1((9 1 3) (7 8 2)))))
  346. (ra-copy! a b)
  347. (ra-slice-for-each 1 (lambda (a) (sort! (ra->array a) <)) a)
  348. a)))
  349. ; 2 arguments frame rank 1
  350. (test-equal
  351. #f64(8 -1)
  352. (ra->array
  353. (let* ((x (list->typed-ra 'f64 2 '((9 1) (7 8))))
  354. (y (array->ra (f64vector 99 99))))
  355. (ra-slice-for-each 1 (lambda (y x) (ra-set! y (- (ra-ref x 0) (ra-ref x 1)))) y x)
  356. y)))
  357. ; regression: zero-sized frame loop without unrolling
  358. (test-equal
  359. 99
  360. (let* ((x 99)
  361. (o (make-ra 0. 0 3 2)))
  362. (ra-slice-for-each 2
  363. (lambda (o a0 a1)
  364. (set! x 0))
  365. o
  366. (make-ra-shared (make-ra 1. 0 1) (const '(0 0)) 0 3)
  367. (make-ra 2. 0 3))
  368. x))
  369. (test-end test-name))))
  370. `(("oldra" ,array-slice-for-each ,list->array ,list->typed-array
  371. ,make-array ,(lambda (a b) (array-copy! b a)) ,make-shared-array
  372. ,(lambda (x) x) ,(lambda (x) x) ,array-set! ,array-ref)
  373. ("newra" ,ra-slice-for-each ,list->ra ,list->typed-ra
  374. ,make-ra ,ra-copy! ,make-ra-shared
  375. ,array->ra ,ra->array ,ra-set! ,ra-ref)
  376. ))
  377. ; -----------------------
  378. ; setter
  379. ; -----------------------
  380. (define ra9 (make-ra-root (make-vector 6) (c-dims '(-1 0) '(1 3))))
  381. (set! (ra9 -1 1) 99)
  382. (set! (ra9 -1 2) 77)
  383. (set! (ra9 -1 3) 88)
  384. (set! (ra9 0 1) 33)
  385. (set! (ra9 0 2) 11)
  386. (set! (ra9 0 3) 22)
  387. (test-equal (ra->string ra9) "#%2@-1:2@1:3((99 77 88) (33 11 22))")
  388. (test-equal 2 (ra-len ra9))
  389. (test-equal #2@-1:2@1:3((99 77 88) (33 44 22)) (ra->array (set! (ra9 0 2) 44)))
  390. ; -----------------------
  391. ; test through the ra-map! interface, also ra-copy!, ra-fill!, ra-swap! ra-equal?
  392. ; -----------------------
  393. (define ra11 (make-ra-new #t 0 (c-dims 10)))
  394. (define ra12 (make-ra-root (make-aseq) (c-dims 10)))
  395. (define ra13 (make-ra-root (make-aseq 10 -1) (c-dims 10)))
  396. (test-equal 10 (ra-len ra11))
  397. (test-equal 10 (ra-len ra12))
  398. (test-equal 10 (ra-len ra13))
  399. (test-equal "#%1:10(0 1 2 3 4 5 6 7 8 9)" (ra->string (ra-copy! ra11 ra12)))
  400. (test-equal "#%1:10(0 1 2 3 4 5 6 7 8 9)" (ra->string (ra-copy! ra11 (ra-copy #t ra12))))
  401. (let ((ra5a (make-ra-new #t 0 (c-dims '(1 2) '(1 3))))
  402. (ra6a (make-ra-root (vector-copy #(1 2 3 4 5 6)) (c-dims '(1 2) '(1 3)))))
  403. (test-equal "#%2@1:2@1:3((1 2 3) (4 5 6))" (ra->string (ra-copy! ra5a ra6a)))
  404. (test-assert (ra-equal? ra6a ra5a))
  405. (test-assert (ra-equal? ra6a ra5a ra6a))
  406. (set! (ra5a 1 1) 99)
  407. (test-assert (not (ra-equal? ra5a ra6a)))
  408. (set! (ra6a 1 1) 99)
  409. (test-assert (ra-equal? ra5a ra6a))
  410. (test-equal "#%2@1:2@1:3((x x x) (x x x))" (ra->string (ra-fill! ra5a 'x)))
  411. (test-equal "#%2@1:2@1:3((x x x) (x x x))" (ra->string ra5a))
  412. (test-assert (not (ra-equal? ra6a ra5a)))
  413. (test-assert (not (ra-equal? (string->ra "#%(1 2 3)") (string->ra "#%(1 2 3 4)"))))
  414. (test-assert (not (ra-equal? (string->ra "#%1f64(1 2 3)") (string->ra "#%(1 2 3)"))))
  415. (test-assert (ra-equal? (make-ra-root #(99 99 99 99) (c-dims '(1 2) '(1 2)))
  416. (ra-fill! (make-ra-root (vector 1 2 3 4) (c-dims '(1 2) '(1 2))) 99))))
  417. (test-begin "ra-for-each")
  418. (test-equal "(10 0 10)(9 1 9)(8 2 8)(7 3 7)(6 4 6)(5 5 5)(4 6 4)(3 7 3)(2 8 2)(1 9 1)"
  419. (call-with-output-string (lambda (s) (ra-for-each (lambda x (display x s)) ra13 ra12 ra13))))
  420. (test-end "ra-for-each")
  421. (ra-map! ra11 (lambda () (random 100)))
  422. (for-each
  423. (match-lambda
  424. ((ra-map! name)
  425. (test-begin (string-append "3 args - " name))
  426. (test-equal "#%1:10(-10 -8 -6 -4 -2 0 2 4 6 8)"
  427. (call-with-output-string (cute display (ra-map! ra11 - ra12 ra13) <>)))
  428. (test-end (string-append "3 args - " name))))
  429. `((,(cut ra-map*! ra-slice-for-each-1 <...>) "fe1")
  430. (,(cut ra-map*! ra-slice-for-each-2 <...>) "fe2")
  431. (,(cut ra-map*! ra-slice-for-each-3 <...>) "fe3")
  432. (,(cut ra-map*! ra-slice-for-each-4 <...>) "fe4")
  433. (,ra-map! "ra-map!")))
  434. ; test with enough args to hit the rest list version.
  435. (for-each
  436. (match-lambda
  437. ((ra-map! name)
  438. (test-begin (string-append "4 args - " name))
  439. (test-equal "#%1:10(-10 -9 -8 -7 -6 -5 -4 -3 -2 -1)"
  440. (call-with-output-string (cute display (ra-map! ra11 - ra12 ra13 ra12) <>)))
  441. (test-end (string-append "4 args - " name))))
  442. `((,(cut ra-map*! ra-slice-for-each-1 <...>) "fe1")
  443. (,(cut ra-map*! ra-slice-for-each-2 <...>) "fe2")
  444. (,(cut ra-map*! ra-slice-for-each-3 <...>) "fe3")
  445. (,(cut ra-map*! ra-slice-for-each-4 <...>) "fe4")
  446. (,ra-map! "ra-map!")))
  447. (test-begin "ra-for-each")
  448. (test-equal "(10 0 10 0)(9 1 9 1)(8 2 8 2)(7 3 7 3)(6 4 6 4)(5 5 5 5)(4 6 4 6)(3 7 3 7)(2 8 2 8)(1 9 1 9)"
  449. (call-with-output-string (lambda (s) (ra-for-each (lambda x (display x s)) ra13 ra12 ra13 ra12))))
  450. (test-end "ra-for-each")
  451. (test-begin "ra-swap!")
  452. (let* ((a (ra-copy #t (ra-i 3 2)))
  453. (root-a (ra-root a))
  454. (ca (ra-copy a))
  455. (b (list->ra 2 '((a b) (c d) (e f))))
  456. (root-b (ra-root b))
  457. (cb (ra-copy b)))
  458. (ra-swap! a b)
  459. (test-eq root-a (ra-root a))
  460. (test-eq root-b (ra-root b))
  461. (test-assert (ra-equal? ca b) (ra-equal? cb a)))
  462. (test-end "ra-swap!")
  463. ; -----------------------
  464. ; ra->list
  465. ; -----------------------
  466. (test-equal '(1 2 3) (ra->list (string->ra "#%(1 2 3)")))
  467. (test-equal '(1 2 3) (ra->list (string->ra "#%@1(1 2 3)")))
  468. (test-equal '((1 2) (3 4)) (ra->list (string->ra "#%2((1 2) (3 4))")))
  469. (test-equal '((1 2) (3 4)) (ra->list (string->ra "#%2@1@1((1 2) (3 4))")))
  470. (test-equal '(((1 2 3) (3 4 5)) ((4 5 6) (6 7 8))) (ra->list (string->ra "#%3@1@1@-1(((1 2 3) (3 4 5)) ((4 5 6) (6 7 8)))")))
  471. (test-equal 99 (ra->list (string->ra "#%0(99)")))
  472. ; -----------------------
  473. ; reader
  474. ; -----------------------
  475. (for-each
  476. (lambda (str)
  477. (test-equal (format #f "#%3~a:2:2:2(((1 2) (3 4)) ((5 6) (7 8)))" str)
  478. (ra->string (string->ra (format #f "#%3~a(((1 2) (3 4)) ((5 6) (7 8)))" str))))
  479. (test-equal (format #f "#%3~a:2:2:2(((1 2) (3 4)) ((5 6) (7 8)))" str)
  480. (ra->string (string->ra (format #f "#%3~a[((1 2) [3 4]) [[5 6] (7 8)]]" str))))
  481. (test-equal (format #f "#%2~a:2:2((1 2) (3 4))" str)
  482. (ra->string (string->ra (format #f "#%2~a((1 2) (3 4))" str))))
  483. (test-equal (format #f "#%1~a:4(1 2 3 4)" str)
  484. (ra->string (string->ra (format #f "#%1~a(1 2 3 4)" str))))
  485. (test-equal (format #f "#%1~a:12(1 2 3 4 5 6 7 8 9 10 11 12)" str)
  486. (ra->string (string->ra (format #f "#%1~a(1 2 3 4 5 6 7 8 9 10 11 12)" str))))
  487. (test-equal (format #f "#%2~a@1:2@1:2((1 2) (3 4))" str)
  488. (ra->string (string->ra (format #f "#%2~a@1@1((1 2) (3 4))" str))))
  489. (test-equal (format #f "#%2~a@1:2@1:2((1 2) (3 4))" str)
  490. (ra->string (string->ra (format #f "#%2~a@1@1:2((1 2) (3 4))" str))))
  491. (test-equal (format #f "#%2~a@-1:2@1:2((1 2) (3 4))" str)
  492. (ra->string (string->ra (format #f "#%2~a@-1@1((1 2) (3 4))" str)))))
  493. '("s32" ""))
  494. (test-equal "#%0(#(1 2 3))" (ra->string (string->ra "#%0(#(1 2 3))")))
  495. (test-equal "#%1f64:3(1.0 2.0 3.0)" (ra->string (string->ra "#%1f64(1 2 3)")))
  496. (test-equal "#%0(#%1:3(1 2 3))" (ra->string (string->ra "#%0[#%[1 2 3]]")))
  497. (test-equal "#%1f64:3(1.0 2.0 3.0)" (ra->string (string->ra "#%1f64[1 2 3]")))
  498. (test-equal "#%3:0:0:0()" (ra->string (string->ra "#%3()")))
  499. (test-equal "#%3:2:0:0(() ())" (ra->string (string->ra "#%3(() ())")))
  500. (test-equal "#%3:1:1:0((()))" (ra->string (string->ra "#%3((())))")))
  501. ; -----------------------
  502. ; list->ra, list->typed-ra
  503. ; -----------------------
  504. (test-equal "#%0(99)" (ra->string (list->ra 0 99)))
  505. (test-equal "#%1:3(1 2 3)" (ra->string (list->ra 1 '(1 2 3))))
  506. (test-equal "#%0((1 2 3))" (ra->string (list->ra 0 '(1 2 3))))
  507. (test-equal "#%2:2:2((1 2) (3 4))" (ra->string (list->ra 2 '((1 2) (3 4)))))
  508. (test-equal "#%2:2:3((1 2 3) (4 5 6))" (ra->string (list->ra 2 '((1 2 3) (4 5 6)))))
  509. (test-equal "#%2:3:2((1 2) (3 4) (5 6))" (ra->string (list->ra 2 '((1 2) (3 4) (5 6)))))
  510. (test-equal "#%1:2((1 2) (3 4))" (ra->string (list->ra 1 '((1 2) (3 4)))))
  511. (test-equal "#%0(((1 2) (3 4)))" (ra->string (list->ra 0 '((1 2) (3 4)))))
  512. (test-equal "#%0f64(99.0)" (ra->string (list->typed-ra 'f64 0 99)))
  513. (test-equal "#%1f64:3(1.0 2.0 3.0)" (ra->string (list->typed-ra 'f64 1 '(1 2 3))))
  514. (test-equal "#%2f64:2:2((1.0 2.0) (3.0 4.0))" (ra->string (list->typed-ra 'f64 2 '((1 2) (3 4)))))
  515. (test-equal "#%1f64@1:3(1.0 2.0 3.0)" (ra->string (list->typed-ra 'f64 '(1) '(1 2 3))))
  516. (test-equal "#%1f64@1:3(1.0 2.0 3.0)" (ra->string (list->typed-ra 'f64 '((1 3)) '(1 2 3))))
  517. (test-equal "#%1f64@-1:3(1.0 2.0 3.0)" (ra->string (list->ra 'f64 '(-1) '(1 2 3))))
  518. (test-equal "#%1f64@-1:3(1.0 2.0 3.0)" (ra->string (list->ra 'f64 '((-1 1)) '(1 2 3))))
  519. ; -----------------------
  520. ; ra-index-map!
  521. ; -----------------------
  522. (test-equal "#%2:2:3(((0 0) (0 1) (0 2)) ((1 0) (1 1) (1 2)))"
  523. (ra->string (let ((x (make-ra 0 2 3))) (ra-index-map! x (lambda x x)))))
  524. (test-equal "#%0(99)"
  525. (ra->string (let ((x (make-ra 0))) (ra-index-map! x (lambda x 99)))))
  526. ; -----------------------
  527. ; ra-dimensions, ra-shape
  528. ; -----------------------
  529. (test-equal '((-1 3) (0 4))
  530. (ra-shape (make-ra 'foo '(-1 3) 5)))
  531. (test-equal '((-1 3) 5)
  532. (ra-dimensions (make-ra 'foo '(-1 3) 5)))
  533. ; -----------------------
  534. ; raw prefix match
  535. ; -----------------------
  536. (let ((ra0 (ra-i 2 3))
  537. (ra1 (ra-i 2)))
  538. (test-equal
  539. "#%2d:2:3((0 1 2) (3 4 5))-#%1d:2(0 1)|"
  540. (call-with-output-string
  541. (lambda (o) (ra-slice-for-each 0 (lambda (ra0 ra1) (format o "~a-~a|" ra0 ra1)) ra0 ra1))))
  542. (test-equal
  543. "#%1d:3(0 1 2)-#%0d(0)|#%1d:3(3 4 5)-#%0d(1)|"
  544. (call-with-output-string
  545. (lambda (o) (ra-slice-for-each 1 (lambda (ra0 ra1) (format o "~a-~a|" ra0 ra1)) ra0 ra1))))
  546. (test-equal
  547. "#%0d(0)-#%0d(0)|#%0d(1)-#%0d(0)|#%0d(2)-#%0d(0)|#%0d(3)-#%0d(1)|#%0d(4)-#%0d(1)|#%0d(5)-#%0d(1)|"
  548. (call-with-output-string
  549. (lambda (o) (ra-slice-for-each 2 (lambda (ra0 ra1) (format o "~a-~a|" ra0 ra1)) ra0 ra1))))
  550. (test-assert
  551. (throws-exception? 'unset-len-for-dim
  552. (lambda () (ra-slice-for-each 3 (lambda (ra0 ra1) 0) ra0 ra1)))))
  553. ; -----------------------
  554. ; prefix match on item (not cell) variants
  555. ; -----------------------
  556. (test-assert
  557. (ra-equal?
  558. (string->ra "#%1:2(-2 -5)")
  559. (let ((ra0 (ra-copy #t (ra-i 2 3)))
  560. (ra1 (ra-copy #t (ra-i 2))))
  561. (ra-map! ra1 - ra0))))
  562. (test-assert
  563. (ra-equal?
  564. (string->ra "#%2:2:3((0 0 0) (-1 -1 -1))")
  565. (let ((ra0 (ra-copy #t (ra-i 2 3)))
  566. (ra1 (ra-copy #t (ra-i 2))))
  567. (ra-map! ra0 - ra1))))
  568. (test-assert
  569. (ra-equal?
  570. (string->ra "#%3:4:3:2(((0 0) (1 1) (2 2)) ((3 3) (4 4) (5 5)) ((6 6) (7 7) (8 8)) ((9 9) (10 10) (11 11)))")
  571. (ra-copy! (make-ra 99 4 3 2) (ra-i 4 3))))
  572. (test-assert
  573. (ra-equal?
  574. (string->ra "#%2:3:2((77 77) (77 77) (77 77))")
  575. (ra-copy! (make-ra 99 3 2) (make-ra 77))))
  576. ; -----------------------
  577. ; ra-fold
  578. ; -----------------------
  579. ; these are slow :-/
  580. ; numpy (1.16.2) - time(np.sum(np.arange(1e8))) ~ 0.15 s
  581. ; octave (4.4.1) - a = time(); b=sum(0:999999999); time()-a ~ 3.1 s
  582. ; newra - ,time (ra-fold + 0 (ra-iota #e1e8)) ~ 4.7 s
  583. (test-equal (* #e1e6 (- #e1e6 1) 1/2) (ra-fold + 0 (ra-iota #e1e6)))
  584. (test-equal (* #e1e6 (- #e1e6 1) 1/2) (ra-fold + 0 (ra-i 100 100 100)))
  585. ; -----------------------
  586. ; ra-any ra-every
  587. ; -----------------------
  588. (test-assert (ra-every positive? (list->ra 1 '(1 2 3 4 5))))
  589. (test-equal -3 (ra-any (lambda (x) (and (negative? x) x)) (list->ra 1 '(1 2 -3 4 5))))
  590. (test-equal #(0 2) (ra-any (lambda (a i j) (and (zero? a) (vector i j)))
  591. (list->ra 2 '((3 4 0) (1 2 9)))
  592. (ra-iota #f)
  593. (ra-transpose (ra-iota #f) 1)))
  594. ; -----------------------
  595. ; inf dims I - (make-dim #f) = (make-dim #f 0 1)
  596. ; -----------------------
  597. (test-assert (ra-equal? (ra-i 3) (make-ra-root (make-aseq) (c-dims 3))))
  598. ; inf dimension
  599. (test-assert (not (dim-len (make-dim #f))))
  600. ; make an array out of inf root
  601. (test-assert (ra-equal? (ra-i 3) (make-ra-root (make-aseq) (c-dims 3))))
  602. ; make an inf array
  603. (let ((rainf (make-ra-root (make-aseq) (c-dims #t))))
  604. (throws-exception? 'unset-len-for-dim (lambda () (ra-for-each pk rainf)))
  605. (test-equal #(10 8 6) (ra->array (ra-map! (make-ra #f 3) - (ra-iota 3 10 -1) rainf)))
  606. (test-equal #(-10 -8 -6) (ra->array (ra-map! (make-ra #f 3) - rainf (ra-iota 3 10 -1)))))
  607. (let ((rainf (ra-i #t 3 4)))
  608. (test-equal #(1204 1205 1206 1207) (ra->array (ra-copy #t (rainf 100 1))))
  609. (test-equal '(#f 3 4) (ra-dimensions rainf)))
  610. ; properties of inf arrays
  611. (test-equal '((#f #f)) (ra-shape (ra-iota)))
  612. ; -----------------------
  613. ; inf dims II - (make-dim #f 0 0) = dead axis
  614. ; -----------------------
  615. (test-equal
  616. #2((11 12 13) (21 22 23))
  617. (ra->array
  618. (ra-map! (make-ra #f 2 3) +
  619. (make-ra-root #(10 20) (vector (make-dim 2 0 1) (make-dim #f 0 0)))
  620. (make-ra-root #(1 2 3) (vector (make-dim #f 0 0) (make-dim 3 0 1))))))
  621. ; using generalized transpose
  622. (test-equal
  623. #2((11 12 13) (21 22 23))
  624. (ra->array
  625. (ra-map! (make-ra #f 2 3) +
  626. (ra-iota 2 10 10)
  627. (ra-transpose (ra-iota 3 1 1) 1))))
  628. ; copying arrays with dead axes
  629. (let ((ra (ra-copy #t (ra-transpose (ra-i 3) 1))))
  630. (test-equal "#%2:d:3((0 1 2))" (ra->string ra))
  631. (test-equal #(0 1 2) (ra-root ra)))
  632. ; -----------------------
  633. ; inf dims III - dimensions can be unbounded in both directions. For these the origin is 0.
  634. ; -----------------------
  635. (let ((ii (make-ra-root (make-aseq) (vector (make-dim #f #f 1)))))
  636. (test-equal 99 (ra-ref ii 99))
  637. (test-equal -99 (ra-ref ii -99)))
  638. ; -----------------------
  639. ; from
  640. ; -----------------------
  641. (define fromu (@ (newra from) fromu))
  642. (define fromb (@ (newra from) fromb))
  643. (define A (ra-map! (make-ra 0 10 10) + (ra-transpose (ra-iota 10) 1) (ra-iota 10 0 10)))
  644. (define b (ra-i 2))
  645. (define c (make-ra-root (make-aseq 10 2) (vector (make-dim 3 1))))
  646. (define d (ra-i 2 2))
  647. (define iz (ra-i 3))
  648. (ra-from A iz)
  649. (ra-from A 0)
  650. (test-equal "#%2:3:10((0 1 2 3 4 5 6 7 8 9) (10 11 12 13 14 15 16 17 18 19) (20 21 22 23 24 25 26 27 28 29))"
  651. (ra->string (ra-from A (ra-copy #t (ra-iota 3)))))
  652. (test-equal "#%2:3:2((0 1) (10 11) (20 21))" (ra->string (ra-from A (ra-iota 3) (ra-iota 2))))
  653. ; manual examples
  654. (let* ((a (list->ra 2 '((1 2 3) (a b c))))
  655. (b (ra-from a #t (ra-iota 3 2 -1)))
  656. (bc (ra-from-copy a #t (ra-iota 3 2 -1)))
  657. (c (ra-from a #t (list->ra 1 '(2 1 0)))))
  658. (test-equal "#%2:2:3((3 2 1) (c b a))" (ra->string b) (ra->string c))
  659. (test-assert (eq? (ra-root a) (ra-root b)))
  660. (test-assert (not (eq? (ra-root a) (ra-root bc))))
  661. (test-assert (not (eq? (ra-root a) (ra-root c)))))
  662. ; ------------------------
  663. ; tests
  664. ; ------------------------
  665. (define (test-from-from? id A . i)
  666. ; to be able to test integers on fromu
  667. (let ((ii (map (match-lambda ((? ra? x) x) ((? integer? x) (make-ra x))) i)))
  668. (test-begin id)
  669. ; beatable vs unbeatable
  670. (test-assert (ra-equal? (apply fromb A i) (apply fromu A ii)))
  671. ; general as unbeatable (except integers), vs unbeatable
  672. (test-assert (ra-equal? (apply ra-from A (map (lambda (x) (if (ra? x) (ra-copy #t x) x)) i))
  673. (apply fromu A ii)))
  674. ; general as beatable, vs beatable
  675. (let ((X (apply ra-from A i))
  676. (Y (apply fromb A i)))
  677. (test-assert (ra-equal? X Y))
  678. ; purely beatable indices preserve the root.
  679. (test-eq (ra-root A) (ra-root Y))
  680. (test-eq (ra-root A) (ra-root X)))
  681. ; general as beatable, vs unbeatable
  682. (test-assert (ra-equal? (apply ra-from A i) (apply fromu A ii)))
  683. ; general as unbeatable/beatable (2 args), vs unbeatable
  684. (match i
  685. ((i j)
  686. (match ii
  687. ((ii jj)
  688. (test-assert (ra-equal? (ra-from A (if (ra? i) (ra-copy #t i) i) j)
  689. (fromu A ii jj)))
  690. (test-assert (ra-equal? (ra-from A i (if (ra? j) (ra-copy #t j) j))
  691. (fromu A ii jj))))))
  692. (else #f))
  693. (test-end id)))
  694. ; ------------------------
  695. ; one arg
  696. ; rank 0
  697. (test-from-from? "00" A (make-ra-root (make-aseq 3) (vector)))
  698. (test-from-from? "01" A 2)
  699. (test-from-from? "02" A (make-ra 2))
  700. ; rank 1
  701. (test-from-from? "03" A (ra-iota 3))
  702. (test-from-from? "04" A (make-ra-root (make-aseq) (vector (make-dim 3 1 1))))
  703. (test-from-from? "05" A (make-ra-root (make-aseq 1 1) (vector (make-dim 3 1 1))))
  704. (test-from-from? "06" A (make-ra-root (make-aseq 1 2) (vector (make-dim 3 1 1))))
  705. (test-from-from? "07" A (make-ra-root (make-aseq 1 1) (vector (make-dim 3 1 2))))
  706. (test-from-from? "08" A (make-ra-root (make-aseq 3 2) (vector (make-dim 2 1 3))))
  707. ; rank 2
  708. (test-from-from? "09" A (ra-i 2 2))
  709. (test-from-from? "10" A (make-ra-root (make-aseq 3) (vector (make-dim 2 1 2) (make-dim 2 1 3))))
  710. ; ------------------------
  711. ; two args
  712. ; rank 0 0
  713. (test-from-from? "11" A (make-ra-root (make-aseq 3) (vector))
  714. (make-ra-root (make-aseq 2) (vector)))
  715. (test-from-from? "12" A 3 (make-ra-root (make-aseq 2) (vector)))
  716. (test-from-from? "13" A (make-ra-root (make-aseq 3) (vector)) 2)
  717. (test-from-from? "14" A 3 2)
  718. ; rank 1 1
  719. (test-from-from? "15" A (ra-iota 3) (ra-iota 2 4))
  720. (test-from-from? "16" A (make-ra-root (make-aseq) (vector (make-dim 3 1 1)))
  721. (make-ra-root (make-aseq) (vector (make-dim 3 1 2))))
  722. (test-from-from? "17" A (make-ra-root (make-aseq 1 1) (vector (make-dim 3 1 1)))
  723. (make-ra-root (make-aseq 1 2) (vector (make-dim 3 1 1))))
  724. (test-from-from? "18" A (make-ra-root (make-aseq 1 2) (vector (make-dim 3 1 1)))
  725. (make-ra-root (make-aseq 1 1) (vector (make-dim 3 1 2))))
  726. (test-from-from? "19" A (make-ra-root (make-aseq 1 1) (vector (make-dim 3 1 2)))
  727. (make-ra-root (make-aseq 1 1) (vector (make-dim 3 1 2))))
  728. (test-from-from? "20" A (make-ra-root (make-aseq 3 2) (vector (make-dim 2 1 3)))
  729. (make-ra-root (make-aseq 1 1) (vector (make-dim 3 1 2))))
  730. ; rank 2 2
  731. (test-from-from? "21" A (ra-i 3 3) (ra-i 2 2))
  732. (test-from-from? "22" A (make-ra-root (make-aseq 3) (vector (make-dim 2 1 2) (make-dim 2 1 3)))
  733. (make-ra-root (make-aseq 3) (vector (make-dim 2 1 2) (make-dim 2 1 3))))
  734. ; placeholders
  735. (let* ((a (ra-i 2 3 4 5 6))
  736. (ref0 (ra-from a 0 (ra-iota 3)))
  737. (ref1 (ra-from a 0 (ra-iota 3) 1))
  738. (ref2 (ra-from a 0 (ra-iota 3) (ra-iota 4) (ra-iota 5) 2)))
  739. (test-assert (ra-equal? a (ra-from a #t)))
  740. (test-assert (ra-equal? a (ra-from a (ldots 1))))
  741. (test-assert (ra-equal? a (ra-from a #t #t #t #t #t)))
  742. (test-assert (ra-equal? a (ra-from a (ldots))))
  743. (test-assert (ra-equal? ref0 (ra-from a 0 #t)))
  744. (test-assert (ra-equal? ref0 (ra-from a 0 (ldots 1))))
  745. (test-assert (ra-equal? ref0 (ra-from a 0 (ldots 0))))
  746. (test-assert (ra-equal? ref1 (ra-from a 0 #t 1)))
  747. (test-assert (ra-equal? ref1 (ra-from a 0 (ldots 1) 1)))
  748. (test-assert (ra-equal? ref2 (ra-from a 0 #t #t #t 2)))
  749. (test-assert (ra-equal? ref2 (ra-from a 0 (ldots 3) 2)))
  750. (test-assert (ra-equal? ref2 (ra-from a 0 (ldots) 2))))
  751. ; ------------------------
  752. ; other A
  753. (throws-exception? 'dim-check-out-of-range (lambda () (ra-from (ra-i 4) (ra-iota 6))))
  754. (throws-exception? 'dim-check-out-of-range (lambda () (ra-from (ra-i 4) 4)))
  755. (let ((A (make-ra-root (make-aseq) (vector (make-dim 4 -3 1)))))
  756. (test-equal 0 (ra-ref (fromu A (make-ra -3))))
  757. (test-equal 0 (ra-ref (fromb A -3)))
  758. (test-equal 0 (ra-ref (ra-from A -3)))
  759. (test-equal 0 (ra-ref (fromu A (make-ra -3))))
  760. (test-equal 0 (ra-ref (fromb A (make-ra -3))))
  761. (test-equal 0 (ra-ref (ra-from A (make-ra -3)))))
  762. (let ((A (make-ra-root #(0 1 2 3 4 5 6 7) (vector (make-dim 4 -3 1)))))
  763. (test-equal 0 (ra-ref (fromu A (make-ra -3))))
  764. (test-equal 0 (ra-ref (fromb A -3)))
  765. (test-equal 0 (ra-ref (ra-from A -3)))
  766. (test-equal 0 (ra-ref (fromu A (make-ra -3))))
  767. (test-equal 0 (ra-ref (fromb A (make-ra -3))))
  768. (test-equal 0 (ra-ref (ra-from A (make-ra -3)))))
  769. (test-equal "#%1d:2(0 1)" (ra->string (ra-from (ra-i 4) (ra-iota 2))))
  770. (test-equal "#%1d:4(0 1 2 3)" (ra->string (ra-from (ra-i #t) (ra-iota 4))))
  771. (test-equal "#%1d:4(0 -1 -2 -3)" (ra->string (ra-from (make-ra-root (make-aseq) (vector (make-dim 4 -3 -1))) (ra-iota 4 -3))))
  772. ; note that arrays are always indexed upwards, so you cannot have (lo hi) be (#f number).
  773. (throws-exception? 'dim-check-out-of-range (lambda () (ra-from (ra-i #f) (ra-iota 4 -3)))) ; error: -3 < 0
  774. (throws-exception? 'dim-check-out-of-range
  775. (lambda () (ra-from (make-ra-root (make-aseq) (vector (make-dim 4 -3 -1)))
  776. (ra-iota 5 -3)))) ; -3+5 > -3+4
  777. (throws-exception? 'dim-check-out-of-range (lambda () (ra-from (ra-i 4) (ra-iota #f))))
  778. (throws-exception? 'dim-check-out-of-range (lambda () (ra-from (ra-copy #t (ra-i 4)) (ra-iota #f))))
  779. (let ((A (make-ra-root (make-aseq) (vector (make-dim 4 1 3) (make-dim 3 1)))))
  780. (test-equal "#%1d@1:4(1 4 7 10)" (ra->string (ra-from A #t 2)))
  781. (test-equal "#%1d@1:3(3 4 5)" (ra->string (ra-from A 2 #t))))
  782. ; -----------------------
  783. ; ra-amend! FIXME needs more tests
  784. ; -----------------------
  785. (define (ra-I . i) (ra-copy #t (apply ra-i i)))
  786. (define (amend-case A . i) (ra->string (apply ra-amend! A i)))
  787. (test-equal "#%2:2:3((a b c) (3 4 5))" (amend-case (ra-I 2 3) (array->ra #(a b c)) 0))
  788. (test-equal "#%2:2:3((0 1 2) (x y z))" (amend-case (ra-I 2 3) (array->ra #(x y z)) 1))
  789. (test-equal "#%2:2:3((a 1 2) (b 4 5))" (amend-case (ra-I 2 3) (array->ra #(a b)) #t 0))
  790. (test-equal "#%2:2:3((0 x 2) (3 y 5))" (amend-case (ra-I 2 3) (array->ra #(x y)) #t 1))
  791. (test-equal "#%2:2:3((x x x) (x x x))" (amend-case (ra-I 2 3) 'x))
  792. (test-equal "#%2:2:3((x x x) (x x x))" (amend-case (ra-I 2 3) (make-ra 'x)))
  793. (test-equal "#%2:2:3((a a a) (b b b))" (amend-case (ra-I 2 3) (array->ra #(a b))))
  794. (test-equal "#%2:2:3((x y z) (x y z))" (amend-case (ra-I 2 3) (ra-transpose (array->ra #(x y z)) 1)))
  795. (test-equal "#%2:2:3((0 x 2) (3 x 5))" (amend-case (ra-I 2 3) 'x (array->ra #(0 1)) 1))
  796. (test-equal "#%2:2:3((0 x 2) (3 x 5))" (amend-case (ra-I 2 3) 'x (ra-i 2) 1))
  797. (test-equal "#%2:2:3((a b c) (3 4 5))" (amend-case (ra-I 2 3) (array->ra #2((a b c))) (array->ra #(0))))
  798. (test-equal "#%2:2:3((0 1 2) (x y z))" (amend-case (ra-I 2 3) (array->ra #2((x y z))) (array->ra #(1))))
  799. (test-equal "#%2:2:3((a 1 2) (b 4 5))" (amend-case (ra-I 2 3) (array->ra #(a b)) #t 0))
  800. (test-equal "#%2:2:3((0 x 2) (3 y 5))" (amend-case (ra-I 2 3) (array->ra #(x y)) #t 1))
  801. (test-equal "#%2:2:3((a 1 2) (b 4 5))" (amend-case (ra-I 2 3) (array->ra #2((a) (b))) #t (array->ra #(0))))
  802. (test-equal "#%2:2:3((0 x 2) (3 y 5))" (amend-case (ra-I 2 3) (array->ra #2((x) (y))) #t (array->ra #(1))))
  803. (test-equal "#%2:2:3((x y 2) (j k 5))" (amend-case (ra-I 2 3) (array->ra #2((x y) (j k))) #t (array->ra #(0 1))))
  804. (test-equal "#%2:2:3((a 1 b) (3 4 5))" (amend-case (ra-I 2 3) (array->ra #(a b)) 0 (array->ra #(0 2))))
  805. (test-equal "#%2:2:3((0 x 2) (3 y 5))" (amend-case (ra-I 2 3) (array->ra #(x y)) #t 1))
  806. (test-equal "#%1:3(b 2 a)" (amend-case (list->ra 1 '(1 2 3)) (array->ra #(a b)) (array->ra #(2 0))))
  807. (test-equal "#%2:2:3((k 1 j) (y 4 x))" (amend-case (ra-I 2 3) (array->ra #2((x y) (j k))) (array->ra #(1 0)) (array->ra #(2 0))))
  808. (test-equal "#%2:2:3((0 x 2) (3 4 5))" (amend-case (ra-I 2 3) 'x 0 1))
  809. ; adapted from guile-ploy
  810. (test-equal "#%1:20(#f a a b b #f c c #f d #f d #f #f #f #f #f #f #f #f)"
  811. (amend-case (make-ra #f 20) (array->ra #(a b c d)) (array->ra #2((1 2) (3 4) (6 7) (9 11)))))
  812. ; with placeholders
  813. (test-equal "#%3:4:3:2(((0 x) (2 x) (4 x)) ((6 x) (8 x) (10 x)) ((12 x) (14 x) (16 x)) ((18 x) (20 x) (22 x)))"
  814. (amend-case (ra-I 4 3 2) 'x (ldots) 1))
  815. ; -----------------------
  816. ; ra-ravel
  817. ; -----------------------
  818. (test-assert (ra-order-c? (ra-i)))
  819. (test-assert (ra-order-c? (ra-i 2)))
  820. (test-assert (ra-order-c? (ra-i 2 3)))
  821. (test-assert (ra-order-c? (ra-i 2 3 4)))
  822. (test-assert (not (ra-order-c? (ra-transpose (ra-i 2 3 4 5) 0 1 3 2))))
  823. (test-assert (not (ra-order-c? (ra-transpose (ra-i 2 3 4 5) 0 1 3 2) 3)))
  824. (test-assert (ra-order-c? (ra-transpose (ra-i 1 2 3 4) 0 1 3 2) 2))
  825. (test-assert (ra-order-c? (ra-transpose (ra-i 1 2 3 4) 0 1 3 2) 1))
  826. (test-assert (not (ra-order-c? (ra-from (ra-i 1 2 3 4) #t #t #t (ra-iota 2 0 2))))) ; last step 1, packed
  827. (test-assert (ra-order-c? (ra-from (ra-i 1 2 3 4) #t #t #t (ra-iota 2 0 2)) 4))
  828. (test-assert (ra-order-c? (ra-tile (ra-i 1 2 3 4) 0 1)))
  829. (test-assert (ra-order-c? (ra-transpose (ra-i 5 1 3 1 4) 0 3 2 1)))
  830. (test-assert (ra-order-c? (ra-transpose (ra-i 2 3 4 5) 1 0 2 3) 2 2))
  831. (test-assert (not (ra-order-c? (ra-transpose (ra-i 2 3 4 5) 1 0 2 3) 2 1)))
  832. (test-assert (ra-order-c? (ra-transpose (ra-i 2 3 4 5) 3 1 2 0) 2 1))
  833. (test-assert (not (ra-order-c? (ra-transpose (ra-i 2 3 4 5) 3 1 2 0) 2 2)))
  834. (test-equal "#%1:18(1 7 13 2 8 14 3 9 15 4 10 16 5 11 17 6 12 18)"
  835. (ra->string
  836. (ra-ravel
  837. (ra-transpose
  838. (make-ra-root (list->vector (iota 18 1)) (c-dims '(1 3) '(4 9)))
  839. 1 0))))
  840. (let ((ra (make-ra-root (list->vector (iota 18 1)) (c-dims '(1 3) '(4 9)))))
  841. (test-eq (ra-root ra) (ra-root (ra-ravel ra)))
  842. (test-equal "#%1:18(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18)"
  843. (ra->string (ra-ravel ra))))
  844. (test-equal "#%1:1(3)" (ra->string (ra-ravel (make-ra 3))))
  845. ; partial ravel
  846. (define (test-ravel-n ra keep-root?)
  847. (let loop ((i (ra-rank ra)))
  848. (when (>= i 0)
  849. (let ((ri (ra-ravel ra i)))
  850. (when keep-root?
  851. (test-assert (ra-equal? (ra-ravel ri) (ra-ravel ra)))
  852. (test-eq (ra-root ra) (ra-root ri)))
  853. (test-equal (ra->list (ra-ravel ri)) (ra->list (ra-ravel ra)))
  854. (test-equal (+ (ra-rank ra) 1 (- i)) (ra-rank ri)))
  855. (loop (- i 1)))))
  856. (let* ((ra (ra-i 2 3 4 5 6))
  857. (rb (ra-from (ra-i 2 3 4 5 6) #t #t #t #t (ra-iota 3 0 2))))
  858. (test-ravel-n ra #t)
  859. (test-ravel-n rb #t)
  860. (test-ravel-n (ra-transpose ra 1 0) #f)
  861. (test-ravel-n (ra-transpose rb 1 0) #f))
  862. ; not prefix, free ravel
  863. (test-equal "#%2d:2:12((0 1 2 3 4 5 6 7 8 9 10 11) (12 13 14 15 16 17 18 19 20 21 22 23))"
  864. (ra->string (ra-ravel (ra-i 2 3 4) 2 1)))
  865. ; not prefix, copy required
  866. (test-assert "#%2:2:12((0 4 8 1 5 9 2 6 10 3 7 11) (12 16 20 13 17 21 14 18 22 15 19 23))"
  867. (ra->string (ra-ravel (ra-transpose (ra-i 2 3 4) 0 2 1) 2 1)))
  868. ; -----------------------
  869. ; ra-reshape
  870. ; -----------------------
  871. (define (test-reshape k a shape check-shape)
  872. (let* ((b (apply ra-reshape a k shape)))
  873. (test-assert (ra-equal? (ra-ravel a) (ra-ravel b)))
  874. (test-eq (ra-root a) (ra-root b))
  875. (test-equal check-shape (ra-shape b))))
  876. (test-reshape 0 (ra-i 4 4)
  877. '(2 2) '((0 1) (0 1) (0 3)))
  878. (test-reshape 1 (ra-i 4 4)
  879. '(2 2) '((0 3) (0 1) (0 1)))
  880. (test-reshape 0 (ra-i 6)
  881. '(2 3) '((0 1) (0 2)))
  882. (test-reshape 0 (ra-i 6)
  883. '((2 4) (3 4)) '((2 4) (3 4)))
  884. (test-reshape 0 (ra-transpose (ra-i 3 2 4) 1 2 0)
  885. '(2 2) '((0 1) (0 1) (0 2) (0 1)))
  886. (test-reshape 0 (ra-from (make-ra-root (make-aseq) (c-dims '(4 9) '(1 4))) (ra-iota 4 5) (ra-iota 2 1))
  887. '((1 2) 2) '((1 2) (0 1) (0 1)))
  888. (test-reshape 0 (ra-transpose (make-ra-root (list->vector (iota 18 1)) (c-dims '(1 3) '(4 9))) 1 0)
  889. '(2 3) '((0 1) (0 2) (1 3)))
  890. (test-reshape 0 (ra-transpose (make-ra-root (make-aseq) (c-dims '(4 9) '(1 4))) 1 0)
  891. '((1 2) 2) '((1 2) (0 1) (4 9)))
  892. ; reshape of inf length - but lo must be set
  893. (let* ((a (ra-iota #f 9))
  894. (b (ra-reshape a 0 '(2 3))))
  895. (test-equal '((2 3)) (ra-shape b))
  896. (test-eq (ra-root a) (ra-root b))
  897. (test-equal 9 (ra-ref b 2))
  898. (test-equal 10 (ra-ref b 3)))
  899. ; -----------------------
  900. ; ra-tile
  901. ; -----------------------
  902. (define (test-tile a shape check-shape)
  903. (let* ((b (apply ra-tile a 0 shape)))
  904. (ra-slice-for-each 2 (lambda (b) (test-assert (ra-equal? a b)))
  905. ; enable loop in the dead axis case since there's only that argument.
  906. (ra-singletonize b))
  907. (test-assert (eq? (ra-root a) (ra-root b)))
  908. (test-equal check-shape (ra-shape b))))
  909. (test-tile (ra-i 5)
  910. '(2 3) '((0 1) (0 2) (0 4)))
  911. (test-tile (ra-transpose (make-ra-root (make-aseq) (c-dims '(4 9) '(1 4))) 1 0)
  912. '(2 3) '((0 1) (0 2) (1 4) (4 9)))
  913. (test-tile (ra-transpose (make-ra-root (make-aseq) (c-dims '(4 9) '(1 4))) 1 0)
  914. '((2 4) (-1 3)) '((2 4) (-1 3) (1 4) (4 9)))
  915. (test-tile (ra-i 5)
  916. '(2 #f) '((0 1) (0 #f) (0 4)))
  917. ; -----------------------
  918. ; ra-rotate!
  919. ; -----------------------
  920. (let ((a (ra-copy #t (ra-i 4 3))))
  921. (ra-rotate! 0 a)
  922. (test-assert (ra-equal? (string->ra "#%2:4:3((0 1 2) (3 4 5) (6 7 8) (9 10 11))") a))
  923. (ra-rotate! 1 a)
  924. (test-assert (ra-equal? (string->ra "#%2:4:3((3 4 5) (6 7 8) (9 10 11) (0 1 2))") a))
  925. (ra-rotate! 2 a)
  926. (test-assert (ra-equal? (string->ra "#%2:4:3((9 10 11) (0 1 2) (3 4 5) (6 7 8))") a))
  927. (ra-rotate! 3 a)
  928. (test-assert (ra-equal? (string->ra "#%2:4:3((6 7 8) (9 10 11) (0 1 2) (3 4 5))") a))
  929. (ra-rotate! -1 a)
  930. (test-assert (ra-equal? (string->ra "#%2:4:3((3 4 5) (6 7 8) (9 10 11) (0 1 2))") a)))
  931. ; -----------------------
  932. ; ra-singletonize
  933. ; -----------------------
  934. (test-equal '(1 2 1 3) (ra-dimensions (ra-singletonize (ra-transpose (ra-i 2 3) 1 3))))
  935. ; -----------------------
  936. ; ra-clip
  937. ; -----------------------
  938. (let* ((i0 (ra-transpose (ra-iota) 0))
  939. (i1 (ra-transpose (ra-iota) 1))
  940. (i2 (ra-transpose (ra-iota) 2))
  941. (f (lambda a (format #f "~{~a~}" a)))
  942. (b (ra-clip (ra-map! (make-ra-new #t 'a (c-dims '(4 6) '(0 2) '(0 4))) f i0 i1 i2)
  943. (ra-map! (make-ra-new #t 'b (c-dims '(2 9) '(1 4))) f i0 i1))))
  944. (test-equal '((4 6) (1 2) (0 4)) (ra-shape b))
  945. (test-equal
  946. "#%3@4:3@1:2:5(((\"410\" \"411\" \"412\" \"413\" \"414\") (\"420\" \"421\" \"422\" \"423\" \"424\")) ((\"510\" \"511\" \"512\" \"513\" \"514\") (\"520\" \"521\" \"522\" \"523\" \"524\")) ((\"610\" \"611\" \"612\" \"613\" \"614\") (\"620\" \"621\" \"622\" \"623\" \"624\")))"
  947. (ra->string b)))
  948. ; -----------------------
  949. ; a bug in c0f60b1b76118a601715d331c265d1126b0d1e7c & before
  950. ; -----------------------
  951. (let ()
  952. (define ra0 (make-ra-root #f64(0 1 2 3 4)))
  953. (define ra1 (ra-copy! (make-typed-ra 'f64 0 5) ra0))
  954. (test-assert (ra-equal? ra0 ra1))
  955. (test-equal (ra-ref ra0 4) (ra-ref ra1 4)))
  956. (let ()
  957. (define ra0 (make-ra-root #u8(0 1 2 3 4)))
  958. (define ra1 (ra-copy! (make-typed-ra 'u8 0 5) ra0))
  959. (test-assert (ra-equal? ra0 ra1))
  960. (test-equal (ra-ref ra0 4) (ra-ref ra1 4)))
  961. ; -----------------------
  962. ; ra-slice creates a new descriptor with no shared dim vector
  963. ; -----------------------
  964. (let ()
  965. (define ra0 (ra-i 2 3 4))
  966. (define v0 (vector-copy (ra-dims ra0)))
  967. (define ra1 (ra-slice ra0))
  968. (test-assert (not (eq? (ra-dims ra0) (ra-dims ra1))))
  969. (vector-for-each (lambda (a b) (test-equal a b))
  970. v0 (ra-dims ra1))
  971. (vector-fill! (ra-dims ra1) #f)
  972. (vector-for-each (lambda (a b) (test-equal a b))
  973. v0 (ra-dims ra0)))
  974. ; -----------------------
  975. ; concatenation
  976. ; -----------------------
  977. (test-assert (ra-equal? (ra-cat #t 0 (ra-i 1 2) (ra-i 2 2)) (array->ra #2((0 1) (0 1) (2 3)))))
  978. (test-assert (ra-equal? (ra-cat #t 0 (ra-iota 2 1) (ra-iota 3 3)) (array->ra #1(1 2 3 4 5))))
  979. (test-assert (ra-equal? (ra-cat #t -1 (ra-iota 2 1) (ra-iota 2 4)) (array->ra #2((1 2) (4 5)))))
  980. (test-assert (ra-equal? (ra-cat #t 1 (ra-iota 2 1) (ra-iota 2 4)) (array->ra #2((1 4) (2 5)))))
  981. (test-assert (ra-equal? (ra-cat #t 0 (make-ra 'a) (ra-iota 2)) (array->ra #1(a 0 1))))
  982. (test-assert (ra-equal? (ra-cat #t 1 (make-ra 'a) (ra-iota 2)) (array->ra #2((a 0) (a 1)))))
  983. (test-assert (ra-equal? (ra-cat #t -1 (make-ra 'a) (ra-iota 2)) (array->ra #2((a a) (0 1)))))
  984. (test-assert (ra-equal? (ra-cat #t 1 (array->ra #(a b)) (ra-i 2 2)) (array->ra #2((a 0 1) (b 2 3)))))
  985. (test-assert (ra-equal? (ra-cat #t 0 (array->ra #(a b)) (ra-i 2 2)) (array->ra #2((a a) (b b) (0 1) (2 3)))))
  986. (test-assert (ra-equal? (ra-scat #t 0 (make-ra 'a) (make-ra 'b) (make-ra 'c)) (array->ra #1(a b c))))
  987. (test-assert (ra-equal? (ra-scat #t 1 (make-ra 'a) (make-ra 'b) (make-ra 'c)) (array->ra #2((a) (b) (c)))))
  988. (test-assert (ra-equal? (ra-scat #t 0 (array->ra #(1 2 3)) (make-ra 4) (array->ra #(5 6))) (array->ra #1(1 2 3 4 5 6))))
  989. (test-assert (ra-equal? (ra-scat #t 0 (array->ra #2((0 1) (2 3))) (array->ra #(a b))) (array->ra #2((0 1 a b) (2 3 a b)))))
  990. (test-assert (ra-equal? (ra-scat #t 1 (array->ra #2((0 1) (2 3))) (array->ra #(a b))) (array->ra #2((0 1) (2 3) (a b)))))
  991. (test-assert (ra-equal? (ra-scat #t 0 (array->ra #2((0 1))) (array->ra #(a))) (array->ra #2((0 1 a)))))
  992. (test-assert (ra-equal? (ra-scat #t -1 (array->ra #(1 2 3)) (array->ra #(a b c))) (array->ra #2((1 a) (2 b) (3 c)))))
  993. (test-assert (ra-equal? (ra-scat #t -1 (make-ra 'a) (array->ra #(x y z))) (array->ra #2((a x) (a y) (a z)))))
  994. ; non-zero base indices on the concat axis
  995. (let* ((a0 (ra-i 2 4))
  996. (a1 (ra-reshape a0 0 '(1 2)))
  997. (b (ra-i 1 4)))
  998. (test-assert (ra-equal? (ra-cat #t 0 a0 b) (ra-cat #t 0 a1 b))))
  999. (let* ((a0 (ra-i 4 2))
  1000. (a1 (ra-untranspose (ra-reshape (ra-transpose a0 1 0) 0 '(1 2)) 1 0))
  1001. (b (ra-i 4 1)))
  1002. (test-assert (ra-equal? (ra-scat #t 0 a0 b) (ra-scat #t 0 a1 b))))
  1003. ; non-zero base indices on a non-concat axis
  1004. (let ((a (make-ra 'a '(1 2) '(1 4)))
  1005. (b (make-ra 'b '(1 3) '(1 4))))
  1006. (test-equal "#%2:5@1:4((a a a a) (a a a a) (b b b b) (b b b b) (b b b b))"
  1007. (ra->string (ra-cat #t 0 a b)))
  1008. (test-equal "#%2:5@1:4((a a a a) (a a a a) (b b b b) (b b b b) (b b b b))"
  1009. (ra->string (ra-scat #t 1 a b))))
  1010. ; -----------------------
  1011. ; ra-map
  1012. ; -----------------------
  1013. ; this requires ra-slice-for-each-check to fix axes where largest rank argument has dead
  1014. (test-equal "#%2f64:3:4((1.0 2.0 3.0 4.0) (2.0 4.0 6.0 8.0) (3.0 6.0 9.0 12.0))"
  1015. (ra->string (ra-map 'f64 * (ra-iota 3 1) (ra-transpose (ra-iota 4 1) 1))))
  1016. ; lower bounds are respected
  1017. (test-equal "#%2:2@1:3((9 9 9) (18 18 18))"
  1018. (ra->string (ra-map #t * (ra-iota 2 1) (ra-transpose (make-ra 9 '(1 3)) 1))))
  1019. (test-equal "#%2:3:4((1 2 3 4) (6 7 8 9) (11 12 13 14))"
  1020. (ra->string (ra-map #f + (ra-iota 3 1) (ra-i 3 4))))
  1021. ; -----------------------
  1022. ; demo of ra-format FIXME somehow check
  1023. ; -----------------------
  1024. (let* ((ra (ra-i 1 8 9 3))
  1025. (ra (ra-map! (ra-copy #t ra) sqrt ra)))
  1026. (ra-format ra #:fmt "~4,2f"))
  1027. (let ((ra (ra-set! (ra-set! (ra-copy #t (ra-i 3 4 3))
  1028. (ra-i 2 3) 1 2 1)
  1029. (make-ra-root #(hello world of ras) (c-dims 2 2))
  1030. 2 1 2)))
  1031. (ra-format ra #:fmt "~a"))
  1032. (let ((ra (ra-i 2 2 2 2 2 2 2 2)))
  1033. (ra-format ra #:compact? #t))
  1034. (let* ((ra (ra-set! (ra-copy #t (ra-i 7)) (make-ra-root #(hello world of ras) (c-dims 2 2)) 3))
  1035. (ra (ra-tile ra (ra-rank ra) 1)))
  1036. (ra-format ra))
  1037. ; example from srfi-163.
  1038. (let* ((arr
  1039. #2@1:2@1:3((#2((1 2) (3 4)) 9 #2((3 4) (5 6)))
  1040. (#(42 43) #2((8 7 6)) #2((90 91) (100 101)))))
  1041. (ra (array->ra arr))
  1042. (ra (ra-map! (ra-copy ra) (lambda (x) (if (array? x) (array->ra x) x)) ra)))
  1043. (ra-format ra #:prefix? #t #:compact? #t)
  1044. (ra-format ra #:prefix? #t #:compact? #f))
  1045. (let ((ra (array->ra #2@1:2@1:3((1 2 3) (4 5 6)))))
  1046. (ra-format ra))
  1047. (let ((ra (make-ra 'zero)))
  1048. (ra-format ra))
  1049. ; shorter than the prefix; was a bug
  1050. (let ((ra (make-ra 'x)))
  1051. (ra-format ra))
  1052. ; when size is 0, just print the prefix
  1053. (ra-format (ra-i 3 0 4))
  1054. ; when size is unbounded, just print the prefix. Not ideal...
  1055. (ra-format (ra-i #t 3 4))
  1056. ; when there are dead axes, print the result of ra-singletonize, except for the prefix. Not ideal...
  1057. (ra-format (ra-i 3 #f 4))
  1058. ; -----------------------
  1059. ; the end.
  1060. ; -----------------------
  1061. ;; (define error-count (test-runner-fail-count (test-runner-current)))
  1062. ;; (test-end "newra")
  1063. ;; (exit error-count)