;;; CHICKEN Transducers - Transducers for working with foldable data types.
;;;
;;; Copyright (c) 2022 Jeremy Steward
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in all
;;; copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;; SOFTWARE.

(import test
        (chicken port)
        srfi-4
        transducers)

(test-group "(transducers base)"
  (test-group "Reduced values"
    (test "make-reduced and unwrap are symmetric"
          'a
          (unwrap (make-reduced 'a)))

    (test-assert "reduced? is #t for make-reduced"
                 (reduced? (make-reduced 'a))))

  (test-group "any and all collectors"
    (test-assert "transducing-all over every #t in list is true"
                 (transduce list-fold
                            values
                            (collect-all values)
                            (list #t #t #t)))

    (test-assert "transducing-all over single #f in list is false"
                 (not (transduce list-fold
                                 values
                                 (collect-all values)
                                 (list #t #f #t))))

    (test-assert "transducing-any over every #f in list is false"
                 (not (transduce list-fold
                                 values
                                 (collect-any values)
                                 (list #f #f #f))))

    (let ((xs (list 1 2 3 4 5 6)))
      (test-assert "transducing-all odd? over (list 1 2 3 4 5 6) is false"
                   (not (transduce list-fold values (collect-all odd?) xs)))

      (test-assert "transducing-all even? over (list 1 2 3 4 5 6) is false"
                   (not (transduce list-fold values (collect-all even?) xs)))

      (test-assert "transducing-all odd? over filtered odd? list is true"
                   (transduce list-fold (filter odd?) (collect-all odd?) xs))

      (test-assert "transducing-all even? over filtered odd? list is false"
                   (not (transduce list-fold (filter odd?) (collect-all even?) xs)))

      (test-assert "transducing-all odd? over filtered even? list is false"
                   (not (transduce list-fold (filter even?) (collect-all odd?) xs)))))

  (test-group "count collector"
    (let ((xs (list 'a 'b 'c 1 2 3)))
      (test "length of list is same as transducer count"
            (length xs)
            (transduce list-fold values (collect-count) xs))

      (test "length of filtered list is same as filtered transducer count"
            3
            (transduce list-fold (filter symbol?) (collect-count) xs))))

  (test-group "max and min collectors"
    (let ((xs (list 1 2 4 5 -1 -4444 5)))
      (test "max value in transduced list is 5"
            ; Necessary to make this change because max compares to -inf.0 by default
            (exact->inexact 5)
            (transduce list-fold values (collect-max) xs))

      (test "max value in transduced list is 999999"
            999999
            (transduce list-fold values (collect-max 999999) xs))

      (test "min value in transduced list is -4444"
            ; Necessary to make this change because min compares to +inf.0 by default
            (exact->inexact -4444)
            (transduce list-fold values (collect-min) xs))

      (test "min value in transduced list is -999999"
            -999999
            (transduce list-fold values (collect-min -999999) xs))))

  (test-group "first and last collectors"
    (test "first of (list 1 2 3) is 1"
          1
          (transduce list-fold values (collect-first) (list 1 2 3)))

    (test "last of (list 1 2 3) is 3"
          3
          (transduce list-fold values (collect-last) (list 1 2 3))))

  (test-group "sum and product collectors"
    (test "product identity"
          1
          (transduce list-fold values (collect-product) (list 1 1 1 1 1 1)))

    (test "sum identity"
          0
          (transduce list-fold values (collect-sum) (list 0 0 0 0 0 0 0)))

    (test "product of 1 3 5"
          (* 1 3 5)
          (transduce list-fold values (collect-product) (list 1 3 5)))

    (test "sum of 2 4 6"
          (+ 2 4 6)
          (transduce list-fold values (collect-sum) (list 2 4 6))))

  (test-group "void collector"
    (test "Undefined collector always returns <unspecified>"
          (void)
          (transduce list-fold values (collect-void) (list 1 2 3 4 5)))

    (test "for-each always transduces into an <unspecified>"
          (void)
          (for-each list-fold values (list 1 2 3 4 5))))

  (test-group "map transducers"
    (test "map add1 to list is (list 2 3 4)"
          (list 2 3 4)
          (transduce list-fold (map add1) (collect-list) (list 1 2 3)))

    (test "map sub1 to list is (list 0 1 2)"
          (list 0 1 2)
          (transduce list-fold (map sub1) (collect-list) (list 1 2 3))))

  (test-group "filter transducers"
    (test "filter odd? to list is (list 1 3 5)"
          (list 1 3 5)
          (transduce list-fold (filter odd?) (collect-list) (list 1 2 3 4 5 6)))

    (test "filter even? to list is (list 2 4 6)"
          (list 2 4 6)
          (transduce list-fold (filter even?) (collect-list) (list 1 2 3 4 5 6))))

  (test-group "drop transducers"
    (let ((xs (list 1 2 3 4 5 6)))
      (test "drop 2 items from list is (list 3 4 5 6)"
            (list 3 4 5 6)
            (transduce list-fold (drop 2) (collect-list) xs))

      (test "drop number larger than list length drops everything"
            (list)
            (transduce list-fold
                       (drop (+ (length xs) 1))
                       (collect-list)
                       xs))

      (test "drop zero is full list"
            xs
            (transduce list-fold (drop 0) (collect-list) xs))

      (test "drop-while less-than-5 from list is (list 5 6)"
            (list 5 6)
            (transduce list-fold
                       (drop-while (lambda (x) (< x 5)))
                       (collect-list)
                       xs))

      (test "drop-while less-than-1000 is null list"
            (list)
            (transduce list-fold
                       (drop-while (lambda (x) (< x 1000)))
                       (collect-list)
                       xs))))

  (test-group "take transducers"
    (let ((xs (list 1 2 3 4 5 6)))
      (test "take 2 items from list is (list 1 2)"
            (list 1 2)
            (transduce list-fold (take 2) (collect-list) xs))

      (test "take number larger than list length takes everything"
            xs
            (transduce list-fold
                       (take (+ (length xs) 1))
                       (collect-list)
                       xs))

      (test-error "take zero is error"
            (transduce list-fold (take 0) (collect-list) xs))

      (test "take-while less-than-5 from list is (list 1 2 3 4)"
            (list 1 2 3 4)
            (transduce list-fold
                       (take-while (lambda (x) (< x 5)))
                       (collect-list)
                       xs))

      (test "take-while less-than-1000 is entire list"
            xs
            (transduce list-fold
                       (take-while (lambda (x) (< x 1000)))
                       (collect-list)
                       xs))))

  (test-group "flatten transducers"
    (let ((xs (list (list 1 2 3) (list 4 5 6) 7)))
      (test "flatten-list returns flattened list"
            (list 1 2 3 4 5 6 7)
            (transduce list-fold flatten-list (collect-list) xs))

      (test "flatten-vector returns same list"
            xs
            (transduce list-fold flatten-vector (collect-list) xs))))

  (test-group "chain transducers"
    (let ((xs (list 1 2 3)))
      (test "chain-list (list 4 5 6)"
            (list 1 2 3 4 5 6)
            (transduce list-fold (chain-list (list 4 5 6)) (collect-list) xs))

      (test "chain-vector (vector 4 5 6)"
            (list 1 2 3 4 5 6)
            (transduce list-fold (chain-vector (vector 4 5 6)) (collect-list) xs))))

  (test-group "interleave transducers"
    (test "interleaving two lists same length"
          (list 1 'a 2 'b 3 'c)
          (transduce list-fold
                     (interleave-list (list 'a 'b 'c))
                     (collect-list)
                     (list 1 2 3)))

    (test "interleaving two lists with different lengths 1"
          (list 1 'a 2 'b 3 'c)
          (transduce list-fold
                     (interleave-list (list 'a 'b 'c 'd 'e 'f 'g))
                     (collect-list)
                     (list 1 2 3)))

    (test "interleaving two lists with different lengths 2"
          (list 1 'a 2 'b)
          (transduce list-fold
                     (interleave-list (list 'a 'b))
                     (collect-list)
                     (list 1 2 3 4 5 6 7 8 9)))

    (test "interleaving a vector with a list"
          (list 1 'a 2 'b 3 'c)
          (transduce list-fold
                     (interleave-vector (vector 'a 'b 'c))
                     (collect-list)
                     (list 1 2 3))))

  (test-group "zip transducers"
    (test "zip list onto vector"
          (list (cons 'a 'd)
                (cons 'b 'e)
                (cons 'c 'f))
          (transduce vector-fold
                     (zip-list (list 'd 'e 'f))
                     (collect-list)
                     (vector 'a 'b 'c)))

    (test "zip vector onto list"
          (list (cons 'a 'd)
                (cons 'b 'e)
                (cons 'c 'f))
          (transduce list-fold
                     (zip-vector (vector 'd 'e 'f))
                     (collect-list)
                     (list 'a 'b 'c)))

    (test "zip has shorter length than input"
          (list (cons 'a 'd))
          (transduce list-fold
                     (zip-list (list 'd))
                     (collect-list)
                     (list 'a 'b 'c)))

    (test "zip has greater length than input"
          (list (cons 'a 'd))
          (transduce list-fold
                     (zip-list (list 'd 'e 'f))
                     (collect-list)
                     (list 'a))))

  (test-group "enumerate transducer"
    (test "enumerate enumerates values"
          (list (cons 0 'a)
                (cons 1 'b)
                (cons 2 'c)
                (cons 3 'd))
          (transduce list-fold enumerate (collect-list) (list 'a 'b 'c 'd)))))

(test-group "(transducers vectors)"
  (test "u8vector can be collected"
        (u8vector 1 2 3)
        (transduce u8vector-fold
                   values
                   (collect-u8vector)
                   (u8vector 1 2 3)))

  (test "u8vector can be transduced in reverse"
        (u8vector 3 2 1)
        (transduce reverse-u8vector-fold
                   values
                   (collect-u8vector)
                   (u8vector 1 2 3))))

(test-group "(transducers ports)"
  (with-input-from-string "abcd"
    (lambda ()
      (test "taking 2 from string 'abcd' is (list a b)"
          (list #\a #\b)
          (transduce reader-fold
                     (take 2)
                     (collect-list)
                     read-char))

      (test "take is not greedy"
        #\c
        (read-char))))

  (test "reader ends immediately on eof-object"
        (list)
        (transduce reader-fold
                   values
                   (collect-list)
                   (lambda () #!eof)))

  (test "writer converts list of chars to string"
        "abcd"
        (with-output-to-string
          (lambda ()
            (transduce list-fold
                       values
                       (collect-writer write-char)
                       (list #\a #\b #\c #\d))))))

(test-group "(transducers numbers)"
  (test "taking from counter produces expected list"
        (list 0 1 2 3 4)
        (transduce range-fold
                   (take 5)
                   (collect-list)
                   (counter 0)))

  (test "collecting range into list produces expected list"
        (list 0 1 2 3 4)
        (transduce range-fold
                   values
                   (collect-list)
                   (range 0 5)))

  (test "collecting iota into list behaves as iota in SRFI-1"
        (list 0 1 2 3 4)
        (transduce range-fold
                   values
                   (collect-list)
                   (iota 5)))

  (test "collecting iota into list with extra args behaves as iota in SRFI-1"
        (list -2 -4 -6 -8 -10)
        (transduce range-fold
                   values
                   (collect-list)
                   (iota 5 -2 -2)))

  (test "flattening ranges produces expected list"
        (list 0 1 2 5 6 7)
        (transduce list-fold
                   flatten-range
                   (collect-list)
                   (list (range 0 3) (range 5 8))))

  (test "chaining range produces expected list"
        (list 'a 'b 'c 0 1 2)
        (transduce list-fold
                   (chain-range (range 0 3))
                   (collect-list)
                   (list 'a 'b 'c)))

  (test "interleaving range produces expected list"
        (list 'a 0 'b 1 'c 2)
        (transduce list-fold
                   (interleave-range (range 0 3))
                   (collect-list)
                   (list 'a 'b 'c)))

  (test "zipping range produces expected assoc-list"
        (list (cons 'a 0)
              (cons 'b 1)
              (cons 'c 2))
        (transduce list-fold
                   (zip-range (range 0 3))
                   (collect-list)
                   (list 'a 'b 'c))))

(test-exit)