srfi-171.test 9.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268
  1. ;; Copyright (C) 2020 Free Software Foundation, Inc.
  2. ;;
  3. ;; This library is free software; you can redistribute it and/or
  4. ;; modify it under the terms of the GNU Lesser General Public
  5. ;; License as published by the Free Software Foundation; either
  6. ;; version 3 of the License, or (at your option) any later version.
  7. ;;
  8. ;; This library is distributed in the hope that it will be useful,
  9. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. ;; Lesser General Public License for more details.
  12. ;;
  13. ;; You should have received a copy of the GNU Lesser General Public
  14. ;; License along with this library; if not, write to the Free Software
  15. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. (define-module (test-srfi-171)
  17. #:use-module (test-suite lib)
  18. #:use-module (ice-9 hash-table)
  19. #:use-module (srfi srfi-171)
  20. #:use-module (srfi srfi-171 gnu)
  21. #:use-module (rnrs bytevectors)
  22. #:use-module ((rnrs hashtables) #:prefix rnrs:)
  23. #:use-module ((srfi srfi-69) #:prefix srfi:))
  24. (define (add1 x) (+ x 1))
  25. (define numeric-list (iota 5))
  26. (define numeric-vec (list->vector numeric-list))
  27. (define bv (list->u8vector numeric-list))
  28. (define test-string "0123456789abcdef")
  29. (define list-of-chars (string->list test-string))
  30. ;; for testing all treplace variations
  31. (define replace-alist '((1 . s) (2 . c) (3 . h) (4 . e) (5 . m)))
  32. (define guile-hashtable (alist->hash-table replace-alist))
  33. (define srfi69-hashtable (srfi:alist->hash-table replace-alist))
  34. (define rnrs-hashtable (rnrs:make-eq-hashtable))
  35. (rnrs:hashtable-set! rnrs-hashtable 1 's)
  36. (rnrs:hashtable-set! rnrs-hashtable 2 'c)
  37. (rnrs:hashtable-set! rnrs-hashtable 3 'h)
  38. (rnrs:hashtable-set! rnrs-hashtable 4 'e)
  39. (rnrs:hashtable-set! rnrs-hashtable 5 'm)
  40. (define (replace-function val)
  41. (case val
  42. ((1) 's)
  43. ((2) 'c)
  44. ((3) 'h)
  45. ((4) 'e)
  46. ((5) 'm)
  47. (else val)))
  48. ;; Test procedures for port-transduce
  49. ;; broken out to properly close port
  50. (define (port-transduce-test)
  51. (let* ((port (open-input-string "0 1 2 3 4"))
  52. (res (equal? 15 (port-transduce (tmap add1) + read
  53. (open-input-string "0 1 2 3 4")))))
  54. (close-port port)
  55. res))
  56. (define (port-transduce-with-identity-test)
  57. (let* ((port (open-input-string "0 1 2 3 4"))
  58. (res (equal? 15 (port-transduce (tmap add1)
  59. +
  60. 0
  61. read
  62. (open-input-string "0 1 2 3 4")))))
  63. (close-port port)
  64. res))
  65. (with-test-prefix "transducers"
  66. (pass-if "tmap" (equal? '(1 2 3 4 5) (list-transduce (tmap add1)
  67. rcons
  68. numeric-list)))
  69. (pass-if "tfilter" (equal? '(0 2 4) (list-transduce (tfilter even?)
  70. rcons
  71. numeric-list)))
  72. (pass-if "tfilter+tmap" (equal?
  73. '(1 3 5)
  74. (list-transduce (compose (tfilter even?) (tmap add1))
  75. rcons
  76. numeric-list)))
  77. (pass-if "tfilter-map"
  78. (equal? '(1 3 5)
  79. (list-transduce (tfilter-map
  80. (lambda (x)
  81. (if (even? x)
  82. (+ x 1)
  83. #f)))
  84. rcons numeric-list)))
  85. (pass-if "tremove"
  86. (equal? (list-transduce (tremove char-alphabetic?)
  87. rcount
  88. list-of-chars)
  89. (string-transduce (tremove char-alphabetic?)
  90. rcount
  91. test-string)))
  92. (pass-if "treplace with alist"
  93. (equal? '(s c h e m e r o c k s)
  94. (list-transduce (treplace replace-alist)
  95. rcons
  96. '(1 2 3 4 5 4 r o c k s) )))
  97. (pass-if "treplace with replace-function"
  98. (equal? '(s c h e m e r o c k s)
  99. (list-transduce (treplace replace-function)
  100. rcons
  101. '(1 2 3 4 5 4 r o c k s))))
  102. (pass-if "treplace with guile hash-table"
  103. (equal? '(s c h e m e r o c k s)
  104. (list-transduce (treplace guile-hashtable)
  105. rcons
  106. '(1 2 3 4 5 4 r o c k s))))
  107. (pass-if "treplace with srfi-69 hash-table"
  108. (equal? '(s c h e m e r o c k s)
  109. (list-transduce (treplace srfi69-hashtable)
  110. rcons
  111. '(1 2 3 4 5 4 r o c k s))))
  112. (pass-if "treplace with rnrs hash-table"
  113. (equal? '(s c h e m e r o c k s)
  114. (list-transduce (treplace rnrs-hashtable)
  115. rcons
  116. '(1 2 3 4 5 4 r o c k s))))
  117. (pass-if "ttake"
  118. (equal? 6 (list-transduce (ttake 4) + numeric-list)))
  119. (pass-if "tdrop"
  120. (equal? 7 (list-transduce (tdrop 3) + numeric-list)))
  121. (pass-if "tdrop-while"
  122. (equal? '(3 4)
  123. (list-transduce (tdrop-while (lambda (x) (< x 3)))
  124. rcons
  125. numeric-list)))
  126. (pass-if "ttake-while"
  127. (equal? '(0 1 2)
  128. (list-transduce (ttake-while (lambda (x) (< x 3)))
  129. rcons
  130. numeric-list)))
  131. (pass-if "tconcatenate"
  132. (equal? '(0 1 2 3 4) (list-transduce tconcatenate
  133. rcons
  134. '((0 1) (2 3) (4)))))
  135. (pass-if "tappend-map"
  136. (equal? '(1 2 2 4 3 6)
  137. (list-transduce (tappend-map (lambda (x) (list x (* x 2))))
  138. rcons
  139. '(1 2 3))))
  140. (pass-if "tdelete-neighbor-duplicates"
  141. (equal? '(1 2 1 2 3)
  142. (list-transduce (tdelete-neighbor-duplicates)
  143. rcons
  144. '(1 1 1 2 2 1 2 3 3))))
  145. (pass-if "tdelete-neighbor-duplicates with equality predicate"
  146. (equal? '(a b c "hej" "hej")
  147. (list-transduce (tdelete-neighbor-duplicates eq?)
  148. rcons
  149. (list 'a 'a 'b 'c 'c "hej" (string #\h #\e #\j)))))
  150. (pass-if "tdelete-duplicates"
  151. (equal? '(1 2 3 4)
  152. (list-transduce (tdelete-duplicates)
  153. rcons
  154. '(1 1 2 1 2 3 3 1 2 3 4))))
  155. (pass-if "tdelete-duplicates with predicate"
  156. (equal? '("hej" "hopp")
  157. (list-transduce (tdelete-duplicates string-ci=?)
  158. rcons
  159. (list "hej" "HEJ" "hopp" "HOPP" "heJ"))))
  160. (pass-if "tflatten"
  161. (equal? '(1 2 3 4 5 6 7 8 9)
  162. (list-transduce tflatten rcons '((1 2) 3 (4 (5 6) 7) 8 (9)))))
  163. (pass-if "tpartition"
  164. (equal? '((1 1 1 1) (2 2 2 2) (3 3 3) (4 4 4 4))
  165. (list-transduce (tpartition even?)
  166. rcons
  167. '(1 1 1 1 2 2 2 2 3 3 3 4 4 4 4))))
  168. (pass-if "tsegment"
  169. (equal? '((0 1) (2 3) (4))
  170. (vector-transduce (tsegment 2) rcons numeric-vec)))
  171. (pass-if "tadd-between"
  172. (equal? '(0 and 1 and 2 and 3 and 4)
  173. (list-transduce (tadd-between 'and) rcons numeric-list)))
  174. (pass-if "tenumerate"
  175. (equal? '((-1 . 0) (0 . 1) (1 . 2) (2 . 3) (3 . 4))
  176. (list-transduce (tenumerate (- 1)) rcons numeric-list)))
  177. (pass-if "tbatch"
  178. (equal?
  179. '((0 1) (2 3) (4))
  180. (list-transduce (tbatch (ttake 2) rcons) rcons numeric-list)))
  181. (pass-if "tfold"
  182. (equal?
  183. '(0 1 3 6 10)
  184. (list-transduce (tfold +) rcons numeric-list))))
  185. (with-test-prefix "x-transduce"
  186. (pass-if "list-transduce"
  187. (equal? 15 (list-transduce (tmap add1) + numeric-list)))
  188. (pass-if "list-transduce with identity"
  189. (equal? 15 (list-transduce (tmap add1) + 0 numeric-list)))
  190. (pass-if "vector-transduce"
  191. (equal? 15 (vector-transduce (tmap add1) + numeric-vec)))
  192. (pass-if "vector-transduce with identity"
  193. (equal? 15
  194. (vector-transduce (tmap add1) + 0 numeric-vec)))
  195. (pass-if "port-transduce" (port-transduce-test))
  196. (pass-if "port-transduce with identity" (port-transduce-with-identity-test))
  197. ;; Converts each numeric char to it's corresponding integer and sums them.
  198. (pass-if "string-transduce"
  199. (equal?
  200. 15
  201. (string-transduce (tmap (lambda (x) (- (char->integer x) 47))) + "01234")))
  202. (pass-if "string-transduce with identity"
  203. (equal?
  204. 15
  205. (string-transduce (tmap (lambda (x) (- (char->integer x) 47)))
  206. +
  207. 0
  208. "01234")))
  209. (pass-if "generator-transduce"
  210. (equal?
  211. '(1 2 3)
  212. (parameterize ((current-input-port (open-input-string "1 2 3")))
  213. (generator-transduce (tmap (lambda (x) x)) rcons read))))
  214. (pass-if "generator-transduce with identity"
  215. (equal?
  216. '(1 2 3)
  217. (parameterize ((current-input-port (open-input-string "1 2 3")))
  218. (generator-transduce (tmap (lambda (x) x)) rcons '() read))))
  219. (pass-if "bytevector-u8-transduce"
  220. (equal? 15 (bytevector-u8-transduce (tmap add1) + bv)))
  221. (pass-if "bytevector-u8-transduce with identity"
  222. (equal? 15 (bytevector-u8-transduce (tmap add1) + 0 bv))))