srfi-41.test 30 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681
  1. ;;; srfi-41.test -- test suite for SRFI 41
  2. ;; Copyright (c) 2007 Philip L. Bewig
  3. ;; Copyright (c) 2011, 2012, 2013 Free Software Foundation, Inc.
  4. ;; Permission is hereby granted, free of charge, to any person obtaining
  5. ;; a copy of this software and associated documentation files (the
  6. ;; "Software"), to deal in the Software without restriction, including
  7. ;; without limitation the rights to use, copy, modify, merge, publish,
  8. ;; distribute, sublicense, and/or sell copies of the Software, and to
  9. ;; permit persons to whom the Software is furnished to do so, subject to
  10. ;; the following conditions:
  11. ;;
  12. ;; The above copyright notice and this permission notice shall be
  13. ;; included in all copies or substantial portions of the Software.
  14. ;;
  15. ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16. ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  17. ;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND
  18. ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
  19. ;; BE LIABLE FOR ANY CLAIM, DAMAGES, OR OTHER LIABILITY, WHETHER IN AN
  20. ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF, OR IN
  21. ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  22. ;; SOFTWARE.
  23. (define-module (test-srfi-41)
  24. #:use-module (srfi srfi-1)
  25. #:use-module (srfi srfi-8)
  26. #:use-module (srfi srfi-26)
  27. #:use-module (srfi srfi-31)
  28. #:use-module (srfi srfi-41)
  29. #:use-module (test-suite lib))
  30. (define-stream (qsort lt? strm)
  31. (if (stream-null? strm) stream-null
  32. (let ((x (stream-car strm))
  33. (xs (stream-cdr strm)))
  34. (stream-append
  35. (qsort lt? (stream-filter (cut lt? <> x) xs))
  36. (stream x)
  37. (qsort lt? (stream-filter (cut (negate lt?) <> x) xs))))))
  38. (define-stream (isort lt? strm)
  39. (define-stream (insert strm x)
  40. (stream-match strm
  41. (() (stream x))
  42. ((y . ys) (if (lt? y x)
  43. (stream-cons y (insert ys x))
  44. (stream-cons x strm)))))
  45. (stream-fold insert stream-null strm))
  46. (define-stream (stream-merge lt? . strms)
  47. (stream-let loop ((strms strms))
  48. (cond ((null? strms) stream-null)
  49. ((null? (cdr strms)) (car strms))
  50. (else (stream-let merge ((xx (car strms))
  51. (yy (loop (cdr strms))))
  52. (stream-match xx
  53. (() yy)
  54. ((x . xs)
  55. (stream-match yy
  56. (() xx)
  57. ((y . ys)
  58. (if (lt? y x)
  59. (stream-cons y (merge xx ys))
  60. (stream-cons x (merge xs yy))))))))))))
  61. (define-stream (msort lt? strm)
  62. (let* ((n (quotient (stream-length strm) 2))
  63. (ts (stream-take n strm))
  64. (ds (stream-drop n strm)))
  65. (if (zero? n) strm
  66. (stream-merge lt? (msort < ts) (msort < ds)))))
  67. (define-stream (stream-unique eql? strm)
  68. (if (stream-null? strm) stream-null
  69. (stream-cons (stream-car strm)
  70. (stream-unique eql?
  71. (stream-drop-while (cut eql? (stream-car strm) <>) strm)))))
  72. (define nats
  73. (stream-cons 1
  74. (stream-map 1+ nats)))
  75. (define hamming
  76. (stream-unique =
  77. (stream-cons 1
  78. (stream-merge <
  79. (stream-map (cut * 2 <>) hamming)
  80. (stream-merge <
  81. (stream-map (cut * 3 <>) hamming)
  82. (stream-map (cut * 5 <>) hamming))))))
  83. (define primes (let ()
  84. (define-stream (next base mult strm)
  85. (let ((first (stream-car strm))
  86. (rest (stream-cdr strm)))
  87. (cond ((< first mult)
  88. (stream-cons first
  89. (next base mult rest)))
  90. ((< mult first)
  91. (next base (+ base mult) strm))
  92. (else (next base
  93. (+ base mult) rest)))))
  94. (define-stream (sift base strm)
  95. (next base (+ base base) strm))
  96. (stream-let sieve ((strm (stream-from 2)))
  97. (let ((first (stream-car strm))
  98. (rest (stream-cdr strm)))
  99. (stream-cons first (sieve (sift first rest)))))))
  100. (define strm123 (stream 1 2 3))
  101. (define (stream-equal? s1 s2)
  102. (cond ((and (stream-null? s1) (stream-null? s2)) #t)
  103. ((or (stream-null? s1) (stream-null? s2)) #f)
  104. ((equal? (stream-car s1) (stream-car s2))
  105. (stream-equal? (stream-cdr s1) (stream-cdr s2)))
  106. (else #f)))
  107. (with-test-prefix "stream-null"
  108. (pass-if "is a stream" (stream? stream-null))
  109. (pass-if "is a null stream" (stream-null? stream-null))
  110. (pass-if "is not a stream pair" (not (stream-pair? stream-null))))
  111. (with-test-prefix "stream-cons"
  112. (pass-if "is a stream" (stream? (stream-cons 1 stream-null)))
  113. (pass-if "is not a null stream" (not (stream-null? (stream-cons 1 stream-null))))
  114. (pass-if "is a stream pair" (stream-pair? (stream-cons 1 stream-null))))
  115. (with-test-prefix "stream?"
  116. (pass-if "is true for null stream" (stream? stream-null))
  117. (pass-if "is true for stream pair" (stream? (stream-cons 1 stream-null)))
  118. (pass-if "is false for non-stream" (not (stream? "four"))))
  119. (with-test-prefix "stream-null?"
  120. (pass-if "is true for null stream" (stream-null? stream-null))
  121. (pass-if "is false for stream pair" (not (stream-null? (stream-cons 1 stream-null))))
  122. (pass-if "is false for non-stream" (not (stream-null? "four"))))
  123. (with-test-prefix "stream-pair?"
  124. (pass-if "is false for null stream" (not (stream-pair? stream-null)))
  125. (pass-if "is true for stream pair" (stream-pair? (stream-cons 1 stream-null)))
  126. (pass-if "is false for non-stream" (not (stream-pair? "four"))))
  127. (with-test-prefix "stream-car"
  128. (pass-if-exception "throws for non-stream"
  129. '(wrong-type-arg . "non-stream")
  130. (stream-car "four"))
  131. (pass-if-exception "throws for null stream"
  132. '(wrong-type-arg . "null stream")
  133. (stream-car stream-null))
  134. (pass-if "returns first of stream" (eqv? (stream-car strm123) 1)))
  135. (with-test-prefix "stream-cdr"
  136. (pass-if-exception "throws for non-stream"
  137. '(wrong-type-arg . "non-stream")
  138. (stream-cdr "four"))
  139. (pass-if-exception "throws for null stream"
  140. '(wrong-type-arg . "null stream")
  141. (stream-cdr stream-null))
  142. (pass-if "returns rest of stream" (eqv? (stream-car (stream-cdr strm123)) 2)))
  143. (with-test-prefix "stream-lambda"
  144. (pass-if "returns correct result"
  145. (stream-equal?
  146. ((rec double (stream-lambda (strm)
  147. (if (stream-null? strm) stream-null
  148. (stream-cons (* 2 (stream-car strm))
  149. (double (stream-cdr strm))))))
  150. strm123)
  151. (stream 2 4 6))))
  152. (with-test-prefix "define-stream"
  153. (pass-if "returns correct result"
  154. (stream-equal?
  155. (let ()
  156. (define-stream (double strm)
  157. (if (stream-null? strm) stream-null
  158. (stream-cons (* 2 (stream-car strm))
  159. (double (stream-cdr strm)))))
  160. (double strm123))
  161. (stream 2 4 6))))
  162. (with-test-prefix "list->stream"
  163. (pass-if-exception "throws for non-list"
  164. '(wrong-type-arg . "non-list argument")
  165. (list->stream "four"))
  166. (pass-if "returns empty stream for empty list"
  167. (stream-null? (list->stream '())))
  168. (pass-if "returns stream with same content as given list"
  169. (stream-equal? (list->stream '(1 2 3)) strm123)))
  170. (with-test-prefix "port->stream"
  171. (pass-if-exception "throws for non-input-port"
  172. '(wrong-type-arg . "non-input-port argument")
  173. (port->stream "four"))
  174. (call-with-input-string "Hello, world!"
  175. (lambda (p)
  176. (pass-if-equal "reads input string correctly"
  177. "Hello, world!"
  178. (list->string (stream->list (port->stream p)))))))
  179. (with-test-prefix "stream"
  180. (pass-if-equal "with empty stream"
  181. '()
  182. (stream->list (stream)))
  183. (pass-if-equal "with one-element stream"
  184. '(1)
  185. (stream->list (stream 1)))
  186. (pass-if-equal "with three-element stream"
  187. '(1 2 3)
  188. (stream->list strm123)))
  189. (with-test-prefix "stream->list"
  190. (pass-if-exception "throws for non-stream"
  191. '(wrong-type-arg . "non-stream argument")
  192. (stream->list '()))
  193. (pass-if-exception "throws for non-integer count"
  194. '(wrong-type-arg . "non-integer count")
  195. (stream->list "four" strm123))
  196. (pass-if-exception "throws for negative count"
  197. '(wrong-type-arg . "negative count")
  198. (stream->list -1 strm123))
  199. (pass-if-equal "returns empty list for empty stream"
  200. '()
  201. (stream->list (stream)))
  202. (pass-if-equal "without count"
  203. '(1 2 3)
  204. (stream->list strm123))
  205. (pass-if-equal "with count longer than stream"
  206. '(1 2 3)
  207. (stream->list 5 strm123))
  208. (pass-if-equal "with count shorter than stream"
  209. '(1 2 3)
  210. (stream->list 3 (stream-from 1))))
  211. (with-test-prefix "stream-append"
  212. (pass-if-exception "throws for non-stream"
  213. '(wrong-type-arg . "non-stream argument")
  214. (stream-append "four"))
  215. (pass-if "with one stream"
  216. (stream-equal? (stream-append strm123) strm123))
  217. (pass-if "with two streams"
  218. (stream-equal? (stream-append strm123 strm123) (stream 1 2 3 1 2 3)))
  219. (pass-if "with three streams"
  220. (stream-equal? (stream-append strm123 strm123 strm123)
  221. (stream 1 2 3 1 2 3 1 2 3)))
  222. (pass-if "append with null is noop"
  223. (stream-equal? (stream-append strm123 stream-null) strm123))
  224. (pass-if "prepend with null is noop"
  225. (stream-equal? (stream-append stream-null strm123) strm123)))
  226. (with-test-prefix "stream-concat"
  227. (pass-if-exception "throws for non-stream"
  228. '(wrong-type-arg . "non-stream argument")
  229. (stream-concat "four"))
  230. (pass-if "with one stream"
  231. (stream-equal? (stream-concat (stream strm123)) strm123))
  232. (pass-if "with two streams"
  233. (stream-equal? (stream-concat (stream strm123 strm123))
  234. (stream 1 2 3 1 2 3))))
  235. (with-test-prefix "stream-constant"
  236. (pass-if "circular stream of 1 has >100 elements"
  237. (eqv? (stream-ref (stream-constant 1) 100) 1))
  238. (pass-if "circular stream of 2 has >100 elements"
  239. (eqv? (stream-ref (stream-constant 1 2) 100) 1))
  240. (pass-if "circular stream of 3 repeats after 3"
  241. (eqv? (stream-ref (stream-constant 1 2 3) 3) 1))
  242. (pass-if "circular stream of 1 repeats at 1"
  243. (stream-equal? (stream-take 8 (stream-constant 1))
  244. (stream 1 1 1 1 1 1 1 1)))
  245. (pass-if "circular stream of 2 repeats at 2"
  246. (stream-equal? (stream-take 8 (stream-constant 1 2))
  247. (stream 1 2 1 2 1 2 1 2)))
  248. (pass-if "circular stream of 3 repeats at 3"
  249. (stream-equal? (stream-take 8 (stream-constant 1 2 3))
  250. (stream 1 2 3 1 2 3 1 2))))
  251. (with-test-prefix "stream-drop"
  252. (pass-if-exception "throws for non-integer count"
  253. '(wrong-type-arg . "non-integer argument")
  254. (stream-drop "four" strm123))
  255. (pass-if-exception "throws for negative count"
  256. '(wrong-type-arg . "negative argument")
  257. (stream-drop -1 strm123))
  258. (pass-if-exception "throws for non-stream"
  259. '(wrong-type-arg . "non-stream argument")
  260. (stream-drop 2 "four"))
  261. (pass-if "returns null when given null"
  262. (stream-null? (stream-drop 0 stream-null)))
  263. (pass-if "returns same stream when count is zero"
  264. (eq? (stream-drop 0 strm123) strm123))
  265. (pass-if "returns dropped-by-one stream when count is one"
  266. (stream-equal? (stream-drop 1 strm123) (stream 2 3)))
  267. (pass-if "returns null if count is longer than stream"
  268. (stream-null? (stream-drop 5 strm123))))
  269. (with-test-prefix "stream-drop-while"
  270. (pass-if-exception "throws for invalid predicate"
  271. '(wrong-type-arg . "non-procedural argument")
  272. (stream-drop-while "four" strm123))
  273. (pass-if-exception "throws for non-stream"
  274. '(wrong-type-arg . "non-stream argument")
  275. (stream-drop-while odd? "four"))
  276. (pass-if "returns null when given null"
  277. (stream-null? (stream-drop-while odd? stream-null)))
  278. (pass-if "returns dropped stream when first element matches"
  279. (stream-equal? (stream-drop-while odd? strm123) (stream 2 3)))
  280. (pass-if "returns whole stream when first element doesn't match"
  281. (stream-equal? (stream-drop-while even? strm123) strm123))
  282. (pass-if "returns empty stream if all elements match"
  283. (stream-null? (stream-drop-while positive? strm123)))
  284. (pass-if "return whole stream if no elements match"
  285. (stream-equal? (stream-drop-while negative? strm123) strm123)))
  286. (with-test-prefix "stream-filter"
  287. (pass-if-exception "throws for invalid predicate"
  288. '(wrong-type-arg . "non-procedural argument")
  289. (stream-filter "four" strm123))
  290. (pass-if-exception "throws for non-stream"
  291. '(wrong-type-arg . "non-stream argument")
  292. (stream-filter odd? '()))
  293. (pass-if "returns null when given null"
  294. (stream-null? (stream-filter odd? (stream))))
  295. (pass-if "filters out even numbers"
  296. (stream-equal? (stream-filter odd? strm123) (stream 1 3)))
  297. (pass-if "filters out odd numbers"
  298. (stream-equal? (stream-filter even? strm123) (stream 2)))
  299. (pass-if "returns all elements if predicate matches all"
  300. (stream-equal? (stream-filter positive? strm123) strm123))
  301. (pass-if "returns null if predicate matches none"
  302. (stream-null? (stream-filter negative? strm123)))
  303. (pass-if "all elements of an odd-filtered stream are odd"
  304. (every odd? (stream->list 10 (stream-filter odd? (stream-from 0)))))
  305. (pass-if "no elements of an odd-filtered stream are even"
  306. (not (any even? (stream->list 10 (stream-filter odd? (stream-from 0)))))))
  307. (with-test-prefix "stream-fold"
  308. (pass-if-exception "throws for invalid function"
  309. '(wrong-type-arg . "non-procedural argument")
  310. (stream-fold "four" 0 strm123))
  311. (pass-if-exception "throws for non-stream"
  312. '(wrong-type-arg . "non-stream argument")
  313. (stream-fold + 0 '()))
  314. (pass-if "returns the correct result" (eqv? (stream-fold + 0 strm123) 6)))
  315. (with-test-prefix "stream-for-each"
  316. (pass-if-exception "throws for invalid function"
  317. '(wrong-type-arg . "non-procedural argument")
  318. (stream-for-each "four" strm123))
  319. (pass-if-exception "throws if given no streams" exception:wrong-num-args
  320. (stream-for-each display))
  321. (pass-if-exception "throws for non-stream"
  322. '(wrong-type-arg . "non-stream argument")
  323. (stream-for-each display "four"))
  324. (pass-if "function is called for stream elements"
  325. (eqv? (let ((sum 0))
  326. (stream-for-each (lambda (x)
  327. (set! sum (+ sum x)))
  328. strm123)
  329. sum)
  330. 6)))
  331. (with-test-prefix "stream-from"
  332. (pass-if-exception "throws for non-numeric start"
  333. '(wrong-type-arg . "non-numeric starting number")
  334. (stream-from "four"))
  335. (pass-if-exception "throws for non-numeric step"
  336. '(wrong-type-arg . "non-numeric step size")
  337. (stream-from 1 "four"))
  338. (pass-if "works for default values"
  339. (eqv? (stream-ref (stream-from 0) 100) 100))
  340. (pass-if "works for non-default start and step"
  341. (eqv? (stream-ref (stream-from 1 2) 100) 201))
  342. (pass-if "works for negative step"
  343. (eqv? (stream-ref (stream-from 0 -1) 100) -100)))
  344. (with-test-prefix "stream-iterate"
  345. (pass-if-exception "throws for invalid function"
  346. '(wrong-type-arg . "non-procedural argument")
  347. (stream-iterate "four" 0))
  348. (pass-if "returns correct iterated stream with 1+"
  349. (stream-equal? (stream-take 3 (stream-iterate 1+ 1)) strm123))
  350. (pass-if "returns correct iterated stream with exact-integer-sqrt"
  351. (stream-equal? (stream-take 5 (stream-iterate exact-integer-sqrt 65536))
  352. (stream 65536 256 16 4 2))))
  353. (with-test-prefix "stream-length"
  354. (pass-if-exception "throws for non-stream"
  355. '(wrong-type-arg . "non-stream argument")
  356. (stream-length "four"))
  357. (pass-if "returns 0 for empty stream" (zero? (stream-length (stream))))
  358. (pass-if "returns correct stream length" (eqv? (stream-length strm123) 3)))
  359. (with-test-prefix "stream-let"
  360. (pass-if "returns correct result"
  361. (stream-equal?
  362. (stream-let loop ((strm strm123))
  363. (if (stream-null? strm)
  364. stream-null
  365. (stream-cons (* 2 (stream-car strm))
  366. (loop (stream-cdr strm)))))
  367. (stream 2 4 6))))
  368. (with-test-prefix "stream-map"
  369. (pass-if-exception "throws for invalid function"
  370. '(wrong-type-arg . "non-procedural argument")
  371. (stream-map "four" strm123))
  372. (pass-if-exception "throws if given no streams" exception:wrong-num-args
  373. (stream-map odd?))
  374. (pass-if-exception "throws for non-stream"
  375. '(wrong-type-arg . "non-stream argument")
  376. (stream-map odd? "four"))
  377. (pass-if "works for one stream"
  378. (stream-equal? (stream-map - strm123) (stream -1 -2 -3)))
  379. (pass-if "works for two streams"
  380. (stream-equal? (stream-map + strm123 strm123) (stream 2 4 6)))
  381. (pass-if "returns finite stream for finite first stream"
  382. (stream-equal? (stream-map + strm123 (stream-from 1)) (stream 2 4 6)))
  383. (pass-if "returns finite stream for finite last stream"
  384. (stream-equal? (stream-map + (stream-from 1) strm123) (stream 2 4 6)))
  385. (pass-if "works for three streams"
  386. (stream-equal? (stream-map + strm123 strm123 strm123) (stream 3 6 9))))
  387. (with-test-prefix "stream-match"
  388. (pass-if-exception "throws for non-stream"
  389. '(wrong-type-arg . "non-stream argument")
  390. (stream-match '(1 2 3) (_ 'ok)))
  391. (pass-if-exception "throws when no pattern matches"
  392. '(match-error . "no matching pattern")
  393. (stream-match strm123 (() 42)))
  394. (pass-if-equal "matches empty stream correctly"
  395. 'ok
  396. (stream-match stream-null (() 'ok)))
  397. (pass-if-equal "matches non-empty stream correctly"
  398. 'ok
  399. (stream-match strm123 (() 'no) (else 'ok)))
  400. (pass-if-equal "matches stream of one element"
  401. 1
  402. (stream-match (stream 1) (() 'no) ((a) a)))
  403. (pass-if-equal "matches wildcard"
  404. 'ok
  405. (stream-match (stream 1) (() 'no) ((_) 'ok)))
  406. (pass-if-equal "matches stream of three elements"
  407. '(1 2 3)
  408. (stream-match strm123 ((a b c) (list a b c))))
  409. (pass-if-equal "matches first element with wildcard rest"
  410. 1
  411. (stream-match strm123 ((a . _) a)))
  412. (pass-if-equal "matches first two elements with wildcard rest"
  413. '(1 2)
  414. (stream-match strm123 ((a b . _) (list a b))))
  415. (pass-if-equal "rest variable matches as stream"
  416. '(1 2 3)
  417. (stream-match strm123 ((a b . c) (list a b (stream-car c)))))
  418. (pass-if-equal "rest variable can match whole stream"
  419. '(1 2 3)
  420. (stream-match strm123 (s (stream->list s))))
  421. (pass-if-equal "successful guard match"
  422. 'ok
  423. (stream-match strm123 ((a . _) (= a 1) 'ok)))
  424. (pass-if-equal "unsuccessful guard match"
  425. 'no
  426. (stream-match strm123 ((a . _) (= a 2) 'yes) (_ 'no)))
  427. (pass-if-equal "unsuccessful guard match with two variables"
  428. 'no
  429. (stream-match strm123 ((a b c) (= a b) 'yes) (_ 'no)))
  430. (pass-if-equal "successful guard match with two variables"
  431. 'yes
  432. (stream-match (stream 1 1 2) ((a b c) (= a b) 'yes) (_ 'no))))
  433. (with-test-prefix "stream-of"
  434. (pass-if "all 3 clause types work"
  435. (stream-equal? (stream-of (+ y 6)
  436. (x in (stream-range 1 6))
  437. (odd? x)
  438. (y is (* x x)))
  439. (stream 7 15 31)))
  440. (pass-if "using two streams creates cartesian product"
  441. (stream-equal? (stream-of (* x y)
  442. (x in (stream-range 1 4))
  443. (y in (stream-range 1 5)))
  444. (stream 1 2 3 4 2 4 6 8 3 6 9 12)))
  445. (pass-if "using no clauses returns just the expression"
  446. (stream-equal? (stream-of 1) (stream 1))))
  447. (with-test-prefix "stream-range"
  448. (pass-if-exception "throws for non-numeric start"
  449. '(wrong-type-arg . "non-numeric starting number")
  450. (stream-range "four" 0))
  451. (pass-if-exception "throws for non-numeric end"
  452. '(wrong-type-arg . "non-numeric ending number")
  453. (stream-range 0 "four"))
  454. (pass-if-exception "throws for non-numeric step"
  455. '(wrong-type-arg . "non-numeric step size")
  456. (stream-range 1 2 "three"))
  457. (pass-if "returns increasing range if start < end"
  458. (stream-equal? (stream-range 0 5) (stream 0 1 2 3 4)))
  459. (pass-if "returns decreasing range if start > end"
  460. (stream-equal? (stream-range 5 0) (stream 5 4 3 2 1)))
  461. (pass-if "returns increasing range of step 2"
  462. (stream-equal? (stream-range 0 5 2) (stream 0 2 4)))
  463. (pass-if "returns decreasing range of step 2"
  464. (stream-equal? (stream-range 5 0 -2) (stream 5 3 1)))
  465. (pass-if "returns empty range if start is past end value"
  466. (stream-null? (stream-range 0 1 -1))))
  467. (with-test-prefix "stream-ref"
  468. (pass-if-exception "throws for non-stream"
  469. '(wrong-type-arg . "non-stream argument")
  470. (stream-ref '() 4))
  471. (pass-if-exception "throws for non-integer index"
  472. '(wrong-type-arg . "non-integer argument")
  473. (stream-ref nats 3.5))
  474. (pass-if-exception "throws for negative index"
  475. '(wrong-type-arg . "negative argument")
  476. (stream-ref nats -3))
  477. (pass-if-exception "throws if index goes past end of stream"
  478. '(wrong-type-arg . "beyond end of stream")
  479. (stream-ref strm123 5))
  480. (pass-if-equal "returns first element when index = 0"
  481. 1
  482. (stream-ref nats 0))
  483. (pass-if-equal "returns second element when index = 1"
  484. 2
  485. (stream-ref nats 1))
  486. (pass-if-equal "returns third element when index = 2"
  487. 3
  488. (stream-ref nats 2)))
  489. (with-test-prefix "stream-reverse"
  490. (pass-if-exception "throws for non-stream"
  491. '(wrong-type-arg . "non-stream argument")
  492. (stream-reverse '()))
  493. (pass-if "returns null when given null"
  494. (stream-null? (stream-reverse (stream))))
  495. (pass-if "returns (3 2 1) for (1 2 3)"
  496. (stream-equal? (stream-reverse strm123) (stream 3 2 1))))
  497. (with-test-prefix "stream-scan"
  498. (pass-if-exception "throws for invalid function"
  499. '(wrong-type-arg . "non-procedural argument")
  500. (stream-scan "four" 0 strm123))
  501. (pass-if-exception "throws for non-stream"
  502. '(wrong-type-arg . "non-stream argument")
  503. (stream-scan + 0 '()))
  504. (pass-if "returns the correct result"
  505. (stream-equal? (stream-scan + 0 strm123) (stream 0 1 3 6))))
  506. (with-test-prefix "stream-take"
  507. (pass-if-exception "throws for non-stream"
  508. '(wrong-type-arg . "non-stream argument")
  509. (stream-take 5 "four"))
  510. (pass-if-exception "throws for non-integer index"
  511. '(wrong-type-arg . "non-integer argument")
  512. (stream-take "four" strm123))
  513. (pass-if-exception "throws for negative index"
  514. '(wrong-type-arg . "negative argument")
  515. (stream-take -4 strm123))
  516. (pass-if "returns null for empty stream"
  517. (stream-null? (stream-take 5 stream-null)))
  518. (pass-if "using 0 index returns null for empty stream"
  519. (stream-null? (stream-take 0 stream-null)))
  520. (pass-if "using 0 index returns null for non-empty stream"
  521. (stream-null? (stream-take 0 strm123)))
  522. (pass-if "returns first 2 elements of stream"
  523. (stream-equal? (stream-take 2 strm123) (stream 1 2)))
  524. (pass-if "returns whole stream when index is same as length"
  525. (stream-equal? (stream-take 3 strm123) strm123))
  526. (pass-if "returns whole stream when index exceeds length"
  527. (stream-equal? (stream-take 5 strm123) strm123)))
  528. (with-test-prefix "stream-take-while"
  529. (pass-if-exception "throws for non-stream"
  530. '(wrong-type-arg . "non-stream argument")
  531. (stream-take-while odd? "four"))
  532. (pass-if-exception "throws for invalid predicate"
  533. '(wrong-type-arg . "non-procedural argument")
  534. (stream-take-while "four" strm123))
  535. (pass-if "returns stream up to first non-matching item"
  536. (stream-equal? (stream-take-while odd? strm123) (stream 1)))
  537. (pass-if "returns empty stream if first item doesn't match"
  538. (stream-null? (stream-take-while even? strm123)))
  539. (pass-if "returns whole stream if every item matches"
  540. (stream-equal? (stream-take-while positive? strm123) strm123))
  541. (pass-if "return empty stream if no item matches"
  542. (stream-null? (stream-take-while negative? strm123))))
  543. (with-test-prefix "stream-unfold"
  544. (pass-if-exception "throws for invalid mapper"
  545. '(wrong-type-arg . "non-procedural mapper")
  546. (stream-unfold "four" odd? + 0))
  547. (pass-if-exception "throws for invalid predicate"
  548. '(wrong-type-arg . "non-procedural pred?")
  549. (stream-unfold + "four" + 0))
  550. (pass-if-exception "throws for invalid generator"
  551. '(wrong-type-arg . "non-procedural generator")
  552. (stream-unfold + odd? "four" 0))
  553. (pass-if "returns the correct result"
  554. (stream-equal? (stream-unfold (cut expt <> 2) (cut < <> 10) 1+ 0)
  555. (stream 0 1 4 9 16 25 36 49 64 81))))
  556. (with-test-prefix "stream-unfolds"
  557. (pass-if "returns the correct result"
  558. (stream-equal? (stream-unfolds
  559. (lambda (x)
  560. (receive (n s) (car+cdr x)
  561. (if (zero? n)
  562. (values 'dummy '())
  563. (values
  564. (cons (- n 1) (stream-cdr s))
  565. (list (stream-car s))))))
  566. (cons 5 (stream-from 0)))
  567. (stream 0 1 2 3 4)))
  568. (pass-if "handles returns of multiple elements correctly"
  569. (stream-equal? (stream-take 16 (stream-unfolds
  570. (lambda (n)
  571. (values (1+ n) (iota n)))
  572. 1))
  573. (stream 0 0 1 0 1 2 0 1 2 3 0 1 2 3 4 0)))
  574. (receive (p np)
  575. (stream-unfolds (lambda (x)
  576. (receive (n p) (car+cdr x)
  577. (if (= n (stream-car p))
  578. (values (cons (1+ n) (stream-cdr p))
  579. (list n) #f)
  580. (values (cons (1+ n) p)
  581. #f (list n)))))
  582. (cons 1 primes))
  583. (pass-if "returns first stream correctly"
  584. (stream-equal? (stream-take 15 p)
  585. (stream 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47)))
  586. (pass-if "returns second stream correctly"
  587. (stream-equal? (stream-take 15 np)
  588. (stream 1 4 6 8 9 10 12 14 15 16 18 20 21 22 24)))))
  589. (with-test-prefix "stream-zip"
  590. (pass-if-exception "throws if given no streams" exception:wrong-num-args
  591. (stream-zip))
  592. (pass-if-exception "throws for non-stream"
  593. '(wrong-type-arg . "non-stream argument")
  594. (stream-zip "four"))
  595. (pass-if-exception "throws if any argument is non-stream"
  596. '(wrong-type-arg . "non-stream argument")
  597. (stream-zip strm123 "four"))
  598. (pass-if "returns null when given null as any argument"
  599. (stream-null? (stream-zip strm123 stream-null)))
  600. (pass-if "returns single-element lists when given one stream"
  601. (stream-equal? (stream-zip strm123) (stream '(1) '(2) '(3))))
  602. (pass-if "returns double-element lists when given two streams"
  603. (stream-equal? (stream-zip strm123 strm123)
  604. (stream '(1 1) '(2 2) '(3 3))))
  605. (pass-if "returns finite stream if at least one given stream is"
  606. (stream-equal? (stream-zip strm123 (stream-from 1))
  607. (stream '(1 1) '(2 2) '(3 3))))
  608. (pass-if "returns triple-element lists when given three streams"
  609. (stream-equal? (stream-zip strm123 strm123 strm123)
  610. (stream '(1 1 1) '(2 2 2) '(3 3 3)))))
  611. (with-test-prefix "other tests"
  612. (pass-if-equal "returns biggest prime under 1000"
  613. 997
  614. (stream-car
  615. (stream-reverse (stream-take-while (cut < <> 1000) primes))))
  616. (pass-if "quicksort returns same result as insertion sort"
  617. (stream-equal? (qsort < (stream 3 1 5 2 4))
  618. (isort < (stream 2 5 1 4 3))))
  619. (pass-if "merge sort returns same result as insertion sort"
  620. (stream-equal? (msort < (stream 3 1 5 2 4))
  621. (isort < (stream 2 5 1 4 3))))
  622. ;; http://www.research.att.com/~njas/sequences/A051037
  623. (pass-if-equal "returns 1000th Hamming number"
  624. 51200000
  625. (stream-ref hamming 999)))