;;; CHICKEN Transducers - Transducers for working with foldable data types.
;;;
;;; Copyright (c) 2023 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)
        (chicken sort)
        (srfi 4)
        (only (srfi 128) make-default-comparator)
        (except (srfi 146)
                mapping-fold
                mapping-fold/reverse)
        (except (srfi 146 hash)
                hashmap-fold)
        transducers)

(test-group "(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 "interleaving iota produces expected list"
          (list 'a 1 'b 2 'c 3 'd 4 'e 5)
          (transduce list-fold
                     (interleave-range (iota 5 1))
                     (collect-list)
                     (list 'a 'b 'c 'd 'e)))

    (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 "zipping iota produces expected list"
          (list '(a . 1)
                '(b . 2)
                '(c . 3)
                '(d . 4)
                '(e . 5))
          (transduce list-fold
                     (zip-range (iota 5 1))
                     (collect-list)
                     (list 'a 'b 'c 'd 'e))))

  (test-group "(transducers mappings)"
    (test-group "(transducers mappings) - mappings"
      (define m
        (transduce list-fold
                   (zip-range (iota 5 1))
                   (collect-mapping)
                   (list 'a 'b 'c 'd 'e)))

      (test "sample mapping can be expressed as equivalent alist."
            (list (cons 'a 1)
                  (cons 'b 2)
                  (cons 'c 3)
                  (cons 'd 4)
                  (cons 'e 5))
            (mapping->alist m))

      (test "sample mapping transduces to equivalent alist."
            (mapping->alist m)
            (transduce mapping-fold
                       values
                       (collect-list)
                       m))

      (test "sample mapping transduces to equivalent reverse-alist."
            (reverse (mapping->alist m))
            (transduce reverse-mapping-fold
                       values
                       (collect-list)
                       m))

      (test "flattening mappings into list produces expected alist."
            (append (mapping->alist m)
                    (mapping->alist m))
            (transduce list-fold
                       flatten-mapping
                       (collect-list)
                       (list m m)))

      (test "collecting enumerated list into mapping."
            (list '(0 . a)
                  '(1 . b)
                  '(2 . c)
                  '(3 . d)
                  '(4 . e))
            (mapping->alist
              (transduce list-fold
                         enumerate
                         (collect-mapping)
                         (list 'a 'b 'c 'd 'e))))

      (test "chaining mappings produces expected alist."
            (list '(0 . a)
                  '(1 . b)
                  '(2 . c)
                  '(3 . d))
            (transduce mapping-fold
                       (chain-mapping (mapping (make-default-comparator)
                                               2 'c
                                               3 'd))
                       (collect-list)
                       (mapping (make-default-comparator)
                                0 'a
                                1 'b)))

      (test "chaining mappings in reverse produces expected alist."
            (list '(0 . a)
                  '(1 . b)
                  '(3 . d)
                  '(2 . c))
            (transduce mapping-fold
                       (chain-reverse-mapping (mapping (make-default-comparator)
                                                       2 'c
                                                       3 'd))
                       (collect-list)
                       (mapping (make-default-comparator)
                                0 'a
                                1 'b)))

      (test "interleaving mapping produces expected alist."
            (list '(0 . a)
                  '(2 . c)
                  '(1 . b)
                  '(3 . d))
            (transduce mapping-fold
                       (interleave-mapping (mapping (make-default-comparator)
                                                    2 'c
                                                    3 'd))
                       (collect-list)
                       (mapping (make-default-comparator)
                                0 'a
                                1 'b)))

      (test "zipping mapping produces expected alist."
            (list '(0 . (a . z))
                  '(1 . (b . y))
                  '(2 . (c . x)))
            (transduce range-fold
                       (zip-mapping (mapping (make-default-comparator)
                                             'a 'z
                                             'b 'y
                                             'c 'x))
                       (collect-list)
                       (iota 20)))
      ;; End of (transducers mappings) - mappings
      )

    (test-group "(transducers mappings) - hashmaps"
      (let ((hm (transduce list-fold
                           enumerate
                           (collect-hashmap)
                           (list 'a 'b 'c 'd 'e 'f)))
            (assoc-list (list '(0 . a)
                              '(1 . b)
                              '(2 . c)
                              '(3 . d)
                              '(4 . e)
                              '(5 . f))))

        (test "sample hashmap can be expressed as equivalent sorted list."
              assoc-list
              (sort (hashmap->alist hm)
                    (lambda (a b) (< (car a) (car b)))))

        (test "hashmap can be expressed as equivalent sorted list."
              assoc-list
              (sort (transduce hashmap-fold
                               values
                               (collect-list)
                               hm)
                    (lambda (a b) (< (car a) (car b)))))

        (test "flattening hashmap into list produces expected alist."
              assoc-list
              (sort (transduce list-fold
                               flatten-hashmap
                               (collect-list)
                               (list hm))
                    (lambda (a b) (< (car a) (car b)))))

        (test "chaining hashmap onto list produces expected alist."
              (list 'x 'y 'z '(0 . a))
              (transduce list-fold
                         (chain-hashmap (hashmap (make-default-comparator) 0 'a))
                         (collect-list)
                         (list 'x 'y 'z))))
      ;; End of test-group (transducers mappings) - hashmap
      )

    ;; End of test-group (transducers mappings)
    )

  ;; End of test-group (transducers)
  )

(test-exit)