123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268 |
- ;; Copyright (C) 2020 Free Software Foundation, Inc.
- ;;
- ;; This library is free software; you can redistribute it and/or
- ;; modify it under the terms of the GNU Lesser General Public
- ;; License as published by the Free Software Foundation; either
- ;; version 3 of the License, or (at your option) any later version.
- ;;
- ;; This library is distributed in the hope that it will be useful,
- ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- ;; Lesser General Public License for more details.
- ;;
- ;; You should have received a copy of the GNU Lesser General Public
- ;; License along with this library; if not, write to the Free Software
- ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
- (define-module (test-srfi-171)
- #:use-module (test-suite lib)
- #:use-module (ice-9 hash-table)
- #:use-module (srfi srfi-171)
- #:use-module (srfi srfi-171 gnu)
- #:use-module (rnrs bytevectors)
- #:use-module ((rnrs hashtables) #:prefix rnrs:)
- #:use-module ((srfi srfi-69) #:prefix srfi:))
- (define (add1 x) (+ x 1))
- (define numeric-list (iota 5))
- (define numeric-vec (list->vector numeric-list))
- (define bv (list->u8vector numeric-list))
- (define test-string "0123456789abcdef")
- (define list-of-chars (string->list test-string))
- ;; for testing all treplace variations
- (define replace-alist '((1 . s) (2 . c) (3 . h) (4 . e) (5 . m)))
- (define guile-hashtable (alist->hash-table replace-alist))
- (define srfi69-hashtable (srfi:alist->hash-table replace-alist))
- (define rnrs-hashtable (rnrs:make-eq-hashtable))
- (rnrs:hashtable-set! rnrs-hashtable 1 's)
- (rnrs:hashtable-set! rnrs-hashtable 2 'c)
- (rnrs:hashtable-set! rnrs-hashtable 3 'h)
- (rnrs:hashtable-set! rnrs-hashtable 4 'e)
- (rnrs:hashtable-set! rnrs-hashtable 5 'm)
- (define (replace-function val)
- (case val
- ((1) 's)
- ((2) 'c)
- ((3) 'h)
- ((4) 'e)
- ((5) 'm)
- (else val)))
- ;; Test procedures for port-transduce
- ;; broken out to properly close port
- (define (port-transduce-test)
- (let* ((port (open-input-string "0 1 2 3 4"))
- (res (equal? 15 (port-transduce (tmap add1) + read
- (open-input-string "0 1 2 3 4")))))
- (close-port port)
- res))
- (define (port-transduce-with-identity-test)
- (let* ((port (open-input-string "0 1 2 3 4"))
- (res (equal? 15 (port-transduce (tmap add1)
- +
- 0
- read
- (open-input-string "0 1 2 3 4")))))
- (close-port port)
- res))
- (with-test-prefix "transducers"
- (pass-if "tmap" (equal? '(1 2 3 4 5) (list-transduce (tmap add1)
- rcons
- numeric-list)))
- (pass-if "tfilter" (equal? '(0 2 4) (list-transduce (tfilter even?)
- rcons
- numeric-list)))
- (pass-if "tfilter+tmap" (equal?
- '(1 3 5)
- (list-transduce (compose (tfilter even?) (tmap add1))
- rcons
- numeric-list)))
- (pass-if "tfilter-map"
- (equal? '(1 3 5)
- (list-transduce (tfilter-map
- (lambda (x)
- (if (even? x)
- (+ x 1)
- #f)))
- rcons numeric-list)))
- (pass-if "tremove"
- (equal? (list-transduce (tremove char-alphabetic?)
- rcount
- list-of-chars)
- (string-transduce (tremove char-alphabetic?)
- rcount
- test-string)))
- (pass-if "treplace with alist"
- (equal? '(s c h e m e r o c k s)
- (list-transduce (treplace replace-alist)
- rcons
- '(1 2 3 4 5 4 r o c k s) )))
- (pass-if "treplace with replace-function"
- (equal? '(s c h e m e r o c k s)
- (list-transduce (treplace replace-function)
- rcons
- '(1 2 3 4 5 4 r o c k s))))
- (pass-if "treplace with guile hash-table"
- (equal? '(s c h e m e r o c k s)
- (list-transduce (treplace guile-hashtable)
- rcons
- '(1 2 3 4 5 4 r o c k s))))
- (pass-if "treplace with srfi-69 hash-table"
- (equal? '(s c h e m e r o c k s)
- (list-transduce (treplace srfi69-hashtable)
- rcons
- '(1 2 3 4 5 4 r o c k s))))
- (pass-if "treplace with rnrs hash-table"
- (equal? '(s c h e m e r o c k s)
- (list-transduce (treplace rnrs-hashtable)
- rcons
- '(1 2 3 4 5 4 r o c k s))))
- (pass-if "ttake"
- (equal? 6 (list-transduce (ttake 4) + numeric-list)))
- (pass-if "tdrop"
- (equal? 7 (list-transduce (tdrop 3) + numeric-list)))
- (pass-if "tdrop-while"
- (equal? '(3 4)
- (list-transduce (tdrop-while (lambda (x) (< x 3)))
- rcons
- numeric-list)))
- (pass-if "ttake-while"
- (equal? '(0 1 2)
- (list-transduce (ttake-while (lambda (x) (< x 3)))
- rcons
- numeric-list)))
- (pass-if "tconcatenate"
- (equal? '(0 1 2 3 4) (list-transduce tconcatenate
- rcons
- '((0 1) (2 3) (4)))))
- (pass-if "tappend-map"
- (equal? '(1 2 2 4 3 6)
- (list-transduce (tappend-map (lambda (x) (list x (* x 2))))
- rcons
- '(1 2 3))))
- (pass-if "tdelete-neighbor-duplicates"
- (equal? '(1 2 1 2 3)
- (list-transduce (tdelete-neighbor-duplicates)
- rcons
- '(1 1 1 2 2 1 2 3 3))))
- (pass-if "tdelete-neighbor-duplicates with equality predicate"
- (equal? '(a b c "hej" "hej")
- (list-transduce (tdelete-neighbor-duplicates eq?)
- rcons
- (list 'a 'a 'b 'c 'c "hej" (string #\h #\e #\j)))))
- (pass-if "tdelete-duplicates"
- (equal? '(1 2 3 4)
- (list-transduce (tdelete-duplicates)
- rcons
- '(1 1 2 1 2 3 3 1 2 3 4))))
- (pass-if "tdelete-duplicates with predicate"
- (equal? '("hej" "hopp")
- (list-transduce (tdelete-duplicates string-ci=?)
- rcons
- (list "hej" "HEJ" "hopp" "HOPP" "heJ"))))
- (pass-if "tflatten"
- (equal? '(1 2 3 4 5 6 7 8 9)
- (list-transduce tflatten rcons '((1 2) 3 (4 (5 6) 7) 8 (9)))))
- (pass-if "tpartition"
- (equal? '((1 1 1 1) (2 2 2 2) (3 3 3) (4 4 4 4))
- (list-transduce (tpartition even?)
- rcons
- '(1 1 1 1 2 2 2 2 3 3 3 4 4 4 4))))
- (pass-if "tsegment"
- (equal? '((0 1) (2 3) (4))
- (vector-transduce (tsegment 2) rcons numeric-vec)))
- (pass-if "tadd-between"
- (equal? '(0 and 1 and 2 and 3 and 4)
- (list-transduce (tadd-between 'and) rcons numeric-list)))
- (pass-if "tenumerate"
- (equal? '((-1 . 0) (0 . 1) (1 . 2) (2 . 3) (3 . 4))
- (list-transduce (tenumerate (- 1)) rcons numeric-list)))
- (pass-if "tbatch"
- (equal?
- '((0 1) (2 3) (4))
- (list-transduce (tbatch (ttake 2) rcons) rcons numeric-list)))
- (pass-if "tfold"
- (equal?
- '(0 1 3 6 10)
- (list-transduce (tfold +) rcons numeric-list))))
- (with-test-prefix "x-transduce"
- (pass-if "list-transduce"
- (equal? 15 (list-transduce (tmap add1) + numeric-list)))
- (pass-if "list-transduce with identity"
- (equal? 15 (list-transduce (tmap add1) + 0 numeric-list)))
- (pass-if "vector-transduce"
- (equal? 15 (vector-transduce (tmap add1) + numeric-vec)))
- (pass-if "vector-transduce with identity"
- (equal? 15
- (vector-transduce (tmap add1) + 0 numeric-vec)))
- (pass-if "port-transduce" (port-transduce-test))
- (pass-if "port-transduce with identity" (port-transduce-with-identity-test))
- ;; Converts each numeric char to it's corresponding integer and sums them.
- (pass-if "string-transduce"
- (equal?
- 15
- (string-transduce (tmap (lambda (x) (- (char->integer x) 47))) + "01234")))
- (pass-if "string-transduce with identity"
- (equal?
- 15
- (string-transduce (tmap (lambda (x) (- (char->integer x) 47)))
- +
- 0
- "01234")))
- (pass-if "generator-transduce"
- (equal?
- '(1 2 3)
- (parameterize ((current-input-port (open-input-string "1 2 3")))
- (generator-transduce (tmap (lambda (x) x)) rcons read))))
- (pass-if "generator-transduce with identity"
- (equal?
- '(1 2 3)
- (parameterize ((current-input-port (open-input-string "1 2 3")))
- (generator-transduce (tmap (lambda (x) x)) rcons '() read))))
- (pass-if "bytevector-u8-transduce"
- (equal? 15 (bytevector-u8-transduce (tmap add1) + bv)))
- (pass-if "bytevector-u8-transduce with identity"
- (equal? 15 (bytevector-u8-transduce (tmap add1) + 0 bv))))
|