;;; 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.

(define-library (transducers vectors)
  (import (scheme))

  (cond-expand
    (chicken-5
      (import (chicken base)
              (chicken type)
              (check-errors)
              (only type-checks-numbers
                    check-non-negative-fixnum)
              (srfi-143)
              (srfi-4)
              (only srfi-133 vector-copy!)
              (only (srfi.160 u8) u8vector-copy!)
              (only (srfi.160 u16) u16vector-copy!)
              (only (srfi.160 u32) u32vector-copy!)
              (only (srfi.160 u64) u64vector-copy!)
              (only (srfi.160 s8) s8vector-copy!)
              (only (srfi.160 s16) s16vector-copy!)
              (only (srfi.160 s32) s32vector-copy!)
              (only (srfi.160 s64) s64vector-copy!)
              (only (srfi.160 f32) f32vector-copy!)
              (only (srfi.160 f64) f64vector-copy!)
              (only (srfi.160 c64)
                    make-c64vector
                    c64vector?
                    c64vector-length
                    c64vector-ref
                    c64vector-set!
                    c64vector-copy!)
              (only (srfi.160 c128)
                    make-c128vector
                    c128vector?
                    c128vector-length
                    c128vector-ref
                    c128vector-set!
                    c128vector-copy!)))
    (else
      (error "Transducers does not yet support this R7RS Scheme implementation.")))

  (import (transducers base))

  ;; Scheme vectors
  (export vector-fold reverse-vector-fold collect-vector flatten-vector
          chain-vector interleave-vector zip-vector)

  ;; Unsigned int vectors
  (export u8vector-fold reverse-u8vector-fold collect-u8vector chain-u8vector
          interleave-u8vector zip-u8vector)
  (export u16vector-fold reverse-u16vector-fold collect-u16vector
          chain-u16vector  interleave-u16vector zip-u16vector)
  (export u32vector-fold reverse-u32vector-fold collect-u32vector
          chain-u32vector interleave-u32vector zip-u32vector)
  (export u64vector-fold reverse-u64vector-fold collect-u64vector
          chain-u64vector interleave-u64vector zip-u64vector)

  ;; Signed int vectors
  (export s8vector-fold reverse-s8vector-fold collect-s8vector chain-s8vector
          interleave-s8vector zip-s8vector)
  (export s16vector-fold chain-s16vector reverse-s16vector-fold
          collect-s16vector interleave-s16vector zip-s16vector)
  (export s32vector-fold reverse-s32vector-fold collect-s32vector
          chain-s32vector interleave-s32vector zip-s32vector)
  (export s64vector-fold reverse-s64vector-fold collect-s64vector
          chain-s64vector interleave-s64vector zip-s64vector)

  ;; Floating point vectors
  (export f32vector-fold reverse-f32vector-fold collect-f32vector
          chain-f32vector interleave-f32vector zip-f32vector)
  (export f64vector-fold reverse-f64vector-fold collect-f64vector
          chain-f64vector interleave-f64vector zip-f64vector)

  ;; Complex vectors
  (export c64vector-fold reverse-c64vector-fold collect-c64vector
          chain-c64vector interleave-c64vector zip-c64vector)
  (export c128vector-fold reverse-c128vector-fold collect-c128vector
          chain-c128vector interleave-c128vector zip-c128vector)

  ;; Transducible type-classes
  (export vector-transducible
          u8vector-transducible
          u16vector-transducible
          u32vector-transducible
          u64vector-transducible
          s8vector-transducible
          s16vector-transducible
          s32vector-transducible
          s64vector-transducible
          f32vector-transducible
          f64vector-transducible
          c64vector-transducible
          c128vector-transducible)

  (export ##define-vector-fold ##define-collect-vector)

  (begin
    ;; A record type for collecting / pushing to a vector-like type in an
    ;; amortized O(1) way.
    (define-record-type <collector>
      ;; Internal constructor for collector records
      (make-collector-internal vec pos maker capacity setter copier)
      ;; Predicate to check if a record is a collector
      collector?
      ;; The internal vector held by the collector
      (vec collector-vector set-collector-vector!)
      ;; The current position (size) in the vector. This will always point to the
      ;; last index that was pushed to, plus one.
      (pos collector-position set-collector-position!)
      ;; A procedure of the form `(make-vec capacity)` which will make a vector
      ;; of the desired capacity.
      (maker collector-make-vec)
      ;; A procedure of the form `(capacity vec)` which returns the length
      ;; (capacity) of the vector.
      (capacity collector-capacity)
      ;; A procedure of the form `(setter! vec position item)` which sets the
      ;; slot at `position` to `item`.
      (setter collector-setter)
      ;; A procedure of the form `(copy! to-vec at from-vec)` that performs a
      ;; copy of the `from-vec` into `to-vec` starting at position `at`.
      (copier collector-copy))

    ;; External constructor that will initialize the internal vector used for
    ;; collection before constructing the collector record directly, but uses a
    ;; size-hint to initialize the vector with a minimum capacity to begin with.
    (cond-expand
      (chicken-5
        (: make-collector-with-capacity ((fixnum -> *)
                                         (* -> fixnum)
                                         (* fixnum * -> undefined)
                                         (* fixnum * -> undefined)
                                         fixnum
                                         -> (struct <collector>)))))
    (define (make-collector-with-capacity maker capacity setter copier size-hint)
      (let ((vec (maker size-hint))
            (position 0))
        (make-collector-internal vec position maker capacity setter copier)))

    ;; A procedure that grows the capacity of a given collector in an
    ;; exponential, amortized fashion.
    ;;
    ;; It effectively doubles the capacity each time we grow the collector, which
    ;; should guarantee exponential growth of the underlying vector. This isn't
    ;; always optimal, but provides amortized O(1) push semantics in
    ;; collector-push!.
    (cond-expand
      (chicken-5
        (: collector-grow-amortized! ((struct <collector>) fixnum -> undefined))))
    (define (collector-grow-amortized! collector additional-size)
      (let* ((required-capacity (fx+ (collector-position collector) additional-size))
             (capacity (fxmax 8 ; We allocate a min of 8 so as to get a multiple of a word size
                              ; Not sure if that works as well when you're
                              ; using regular scheme vectors but srfi-4 vectors
                              ; will probably appreciate this.
                              (fxmax (fx* 2 ((collector-capacity collector)
                                             (collector-vector collector)))
                                     required-capacity)))
             (new-vector ((collector-make-vec collector) capacity)))
        ((collector-copy collector) new-vector 0 (collector-vector collector))
        (set-collector-vector! collector new-vector)))

    ;; Pushes an item into the vector collector.
    ;;
    ;; This operation is amortized to O(1) time, as the vector will grow
    ;; exponentially as more and more items are pushed to it.
    (cond-expand
      (chicken-5
        (: collector-push! ((struct <collector>) * -> undefined))))
    (define (collector-push! collector item)
      (let ((vec (collector-vector collector))
            (pos (collector-position collector)))
        (when (fx=? ((collector-capacity collector) vec) pos)
          (collector-grow-amortized! collector 1))
        ((collector-setter collector) (collector-vector collector) pos item)
        (set-collector-position! collector (fx+ pos 1))
        collector))

    ;; "Collects" the final vector and returns it at its appropriate size,
    ;; determined by the internal collector's position.
    (cond-expand
      (chicken-5
        (: collector-collect ((struct <collector>) -> *))))
    (define (collector-collect collector)
      (let ((vec (collector-vector collector))
            (pos (collector-position collector)))
        (if (fx=? ((collector-capacity collector) vec) pos)
          vec
          (let ((new-vec ((collector-make-vec collector) pos)))
            ((collector-copy collector) new-vec 0 vec 0 pos)
            new-vec))))

    ;; A macro that generates <X>vector-fold and reverse-<X>vector-fold procedures.
    (define-syntax ##define-vector-fold
      (syntax-rules ()
        ((_ fold-name reverse-fold-name check length ref)
         (begin
           ;; A transducer aware folding operation on vectors.
           ;;
           ;; This procedure takes in a reducer `f`, a `sentinel` value for that
           ;; reducer, and a vector `vec` to call `(f sentinel item)` on repeatedly,
           ;; taking the result of the reducer as the new sentinel value each time.
           (define (fold-name f sentinel vec)
             (check (quote fold-name) vec 'vec)
             (let ((len (length vec)))
               (let loop ((collector sentinel)
                          (i 0))
                 (if (fx>=? i len)
                   collector
                   (let ((result (f collector (ref vec i))))
                     (if (reduced? result)
                       (unwrap result)
                       (loop result (fx+ i 1))))))))

           ;; A transducer aware folding operation on vectors.
           ;;
           ;; This procedure takes in a reducer `f`, a `sentinel` value for that
           ;; reducer, and a vector `vec` to call `(f sentinel item)` on repeatedly,
           ;; taking the result of the reducer as the new sentinel value each time.
           (define (reverse-fold-name f sentinel vec)
             (check (quote fold-name) vec 'vec)
             (let loop ((collector sentinel)
                        (i (fx- (length vec) 1)))
               (if (fx<? i 0)
                 collector
                 (let ((result (f collector (ref vec i))))
                   (if (reduced? result)
                     (unwrap result)
                     (loop result (fx- i 1)))))))))))

    ;; A macro that generates a definition of collect-<X>vector. The macro
    ;; requires several procedures in order to be properly defined:
    ;;
    ;; - make-vec: A constructor for the vector type
    ;; - vec-length: A procedure for getting the length of a vector
    ;; - vec-set!: A procedure for setting a slot within a vector
    ;; - vec-copy!: A procedure for copying a vector to another vector
    ;;
    ;; The generated procedure takes an optional size-hint. That size-hint is
    ;; used to initialize the vector with a given length / capacity such that
    ;; fewer internal allocations are needed as items are pushed to the vector.
    (define-syntax ##define-collect-vector
      (syntax-rules ()
        ((_ name make-vec vec-length vec-set! vec-copy!)
         (define name
           (case-lambda
             (() (name 0))
             ((size-hint)
              (check-non-negative-fixnum (quote name) size-hint 'size-hint)
              (case-lambda
                (() (make-collector-with-capacity make-vec
                                                  vec-length
                                                  vec-set!
                                                  vec-copy!
                                                  size-hint))
                ((result) (collector-collect result))
                ((result item)
                 (collector-push! result item)))))))))

    ;;; Scheme Vectors

    (##define-vector-fold vector-fold reverse-vector-fold check-vector vector-length vector-ref)
    (##define-collect-vector collect-vector make-vector vector-length vector-set! vector-copy!)

    (define-flatten-transducer flatten-vector vector? vector-fold)
    (define-chain-transducer chain-vector vector-fold)

    (define-interleave-transducer
      interleave-vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (vector-length coll)))
      vector-ref
      (lambda (_ s) (fx+ s 1)))

    (define-zip-transducer
      zip-vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (vector-length coll)))
      vector-ref
      (lambda (_ s) (fx+ s 1)))

    ;; A transducible type-class over vectors.
    (define vector-transducible
      (make-transducible vector-fold
                         collect-vector
                         flatten-vector
                         chain-vector
                         interleave-vector
                         zip-vector))

    ;;; SRFI-4 Vectors

    ;; Unsigned int vectors

    (##define-vector-fold u8vector-fold reverse-u8vector-fold check-u8vector u8vector-length u8vector-ref)
    (##define-collect-vector collect-u8vector make-u8vector u8vector-length u8vector-set! u8vector-copy!)

    (define-flatten-transducer flatten-u8vector u8vector? u8vector-fold)
    (define-chain-transducer chain-u8vector u8vector-fold)

    (define-interleave-transducer
      interleave-u8vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (u8vector-length coll)))
      u8vector-ref
      (lambda (_ s) (fx+ s 1)))

    (define-zip-transducer
      zip-u8vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (u8vector-length coll)))
      u8vector-ref
      (lambda (_ s) (fx+ s 1)))

    ;; A transducible type-class over u8vectors.
    (define u8vector-transducible
      (make-transducible u8vector-fold
                         collect-u8vector
                         flatten-u8vector
                         chain-u8vector
                         interleave-u8vector
                         zip-u8vector))

    (##define-vector-fold u16vector-fold reverse-u16vector-fold check-u16vector u16vector-length u16vector-ref)
    (##define-collect-vector collect-u16vector make-u16vector u16vector-length u16vector-set! u16vector-copy!)

    (define-flatten-transducer flatten-u16vector u16vector? u16vector-fold)
    (define-chain-transducer chain-u16vector u16vector-fold)

    (define-interleave-transducer
      interleave-u16vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (u16vector-length coll)))
      u16vector-ref
      (lambda (_ s) (fx+ s 1)))

    (define-zip-transducer
      zip-u16vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (u16vector-length coll)))
      u16vector-ref
      (lambda (_ s) (fx+ s 1)))

    ;; A transducible type-class over u16vectors.
    (define u16vector-transducible
      (make-transducible u16vector-fold
                         collect-u16vector
                         flatten-u16vector
                         chain-u16vector
                         interleave-u16vector
                         zip-u16vector))

    (##define-vector-fold u32vector-fold reverse-u32vector-fold check-u32vector u32vector-length u32vector-ref)
    (##define-collect-vector collect-u32vector make-u32vector u32vector-length u32vector-set! u32vector-copy!)

    (define-flatten-transducer flatten-u32vector u32vector? u32vector-fold)
    (define-chain-transducer chain-u32vector u32vector-fold)

    (define-interleave-transducer
      interleave-u32vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (u32vector-length coll)))
      u32vector-ref
      (lambda (_ s) (fx+ s 1)))

    (define-zip-transducer
      zip-u32vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (u32vector-length coll)))
      u32vector-ref
      (lambda (_ s) (fx+ s 1)))

    ;; A transducible type-class over u32vectors.
    (define u32vector-transducible
      (make-transducible u32vector-fold
                         collect-u32vector
                         flatten-u32vector
                         chain-u32vector
                         interleave-u32vector
                         zip-u32vector))

    (##define-vector-fold u64vector-fold reverse-u64vector-fold check-u64vector u64vector-length u64vector-ref)
    (##define-collect-vector collect-u64vector make-u64vector u64vector-length u64vector-set! u64vector-copy!)

    (define-flatten-transducer flatten-u64vector u64vector? u64vector-fold)
    (define-chain-transducer chain-u64vector u64vector-fold)

    (define-interleave-transducer
      interleave-u64vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (u64vector-length coll)))
      u64vector-ref
      (lambda (_ s) (fx+ s 1)))

    (define-zip-transducer
      zip-u64vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (u64vector-length coll)))
      u64vector-ref
      (lambda (_ s) (fx+ s 1)))

    ;; A transducible type-class over u64vectors.
    (define u64vector-transducible
      (make-transducible u64vector-fold
                         collect-u64vector
                         flatten-u64vector
                         chain-u64vector
                         interleave-u64vector
                         zip-u64vector))

    ;; Signed int vectors

    (##define-vector-fold s8vector-fold reverse-s8vector-fold check-s8vector s8vector-length s8vector-ref)
    (##define-collect-vector collect-s8vector make-s8vector s8vector-length s8vector-set! s8vector-copy!)

    (define-flatten-transducer flatten-s8vector s8vector? s8vector-fold)
    (define-chain-transducer chain-s8vector s8vector-fold)

    (define-interleave-transducer
      interleave-s8vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (s8vector-length coll)))
      s8vector-ref
      (lambda (_ s) (fx+ s 1)))

    (define-zip-transducer
      zip-s8vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (s8vector-length coll)))
      s8vector-ref
      (lambda (_ s) (fx+ s 1)))

    ;; A transducible type-class over s8vectors.
    (define s8vector-transducible
      (make-transducible s8vector-fold
                         collect-s8vector
                         flatten-s8vector
                         chain-s8vector
                         interleave-s8vector
                         zip-s8vector))

    (##define-vector-fold s16vector-fold reverse-s16vector-fold check-s16vector s16vector-length s16vector-ref)
    (##define-collect-vector collect-s16vector make-s16vector s16vector-length s16vector-set! s16vector-copy!)

    (define-flatten-transducer flatten-s16vector s16vector? s16vector-fold)
    (define-chain-transducer chain-s16vector s16vector-fold)

    (define-interleave-transducer
      interleave-s16vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (s16vector-length coll)))
      s16vector-ref
      (lambda (_ s) (fx+ s 1)))

    (define-zip-transducer
      zip-s16vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (s16vector-length coll)))
      s16vector-ref
      (lambda (_ s) (fx+ s 1)))

    ;; A transducible type-class over s16vectors.
    (define s16vector-transducible
      (make-transducible s16vector-fold
                         collect-s16vector
                         flatten-s16vector
                         chain-s16vector
                         interleave-s16vector
                         zip-s16vector))

    (##define-vector-fold s32vector-fold reverse-s32vector-fold check-s32vector s32vector-length s32vector-ref)
    (##define-collect-vector collect-s32vector make-s32vector s32vector-length s32vector-set! s32vector-copy!)

    (define-flatten-transducer flatten-s32vector s32vector? s32vector-fold)
    (define-chain-transducer chain-s32vector s32vector-fold)

    (define-interleave-transducer
      interleave-s32vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (s32vector-length coll)))
      s32vector-ref
      (lambda (_ s) (fx+ s 1)))

    (define-zip-transducer
      zip-s32vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (s32vector-length coll)))
      s32vector-ref
      (lambda (_ s) (fx+ s 1)))

    ;; A transducible type-class over s32vectors.
    (define s32vector-transducible
      (make-transducible s32vector-fold
                         collect-s32vector
                         flatten-s32vector
                         chain-s32vector
                         interleave-s32vector
                         zip-s32vector))

    (##define-vector-fold s64vector-fold reverse-s64vector-fold check-s64vector s64vector-length s64vector-ref)
    (##define-collect-vector collect-s64vector make-s64vector s64vector-length s64vector-set! s64vector-copy!)

    (define-flatten-transducer flatten-s64vector s64vector? s64vector-fold)
    (define-chain-transducer chain-s64vector s64vector-fold)

    (define-interleave-transducer
      interleave-s64vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (s64vector-length coll)))
      s64vector-ref
      (lambda (_ s) (fx+ s 1)))

    (define-zip-transducer
      zip-s64vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (s64vector-length coll)))
      s64vector-ref
      (lambda (_ s) (fx+ s 1)))

    ;; A transducible type-class over s64vectors.
    (define s64vector-transducible
      (make-transducible s64vector-fold
                         collect-s64vector
                         flatten-s64vector
                         chain-s64vector
                         interleave-s64vector
                         zip-s64vector))

    ;; Floating point vectors

    (##define-vector-fold f32vector-fold reverse-f32vector-fold check-f32vector f32vector-length f32vector-ref)
    (##define-collect-vector collect-f32vector make-f32vector f32vector-length f32vector-set! f32vector-copy!)

    (define-flatten-transducer flatten-f32vector f32vector? f32vector-fold)
    (define-chain-transducer chain-f32vector f32vector-fold)

    (define-interleave-transducer
      interleave-f32vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (f32vector-length coll)))
      f32vector-ref
      (lambda (_ s) (fx+ s 1)))

    (define-zip-transducer
      zip-f32vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (f32vector-length coll)))
      f32vector-ref
      (lambda (_ s) (fx+ s 1)))

    ;; A transducible type-class over f32vectors.
    (define f32vector-transducible
      (make-transducible f32vector-fold
                         collect-f32vector
                         flatten-f32vector
                         chain-f32vector
                         interleave-f32vector
                         zip-f32vector))

    (##define-vector-fold f64vector-fold reverse-f64vector-fold check-f64vector f64vector-length f64vector-ref)
    (##define-collect-vector collect-f64vector make-f64vector f64vector-length f64vector-set! f64vector-copy!)

    (define-flatten-transducer flatten-f64vector f64vector? f64vector-fold)
    (define-chain-transducer chain-f64vector f64vector-fold)

    (define-interleave-transducer
      interleave-f64vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (f64vector-length coll)))
      f64vector-ref
      (lambda (_ s) (fx+ s 1)))

    (define-zip-transducer
      zip-f64vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (f64vector-length coll)))
      f64vector-ref
      (lambda (_ s) (fx+ s 1)))

    ;; A transducible type-class over f64vectors.
    (define f64vector-transducible
      (make-transducible f64vector-fold
                         collect-f64vector
                         flatten-f64vector
                         chain-f64vector
                         interleave-f64vector
                         zip-f64vector))

    ;; Complex vectors

    (define-check+error-type c64vector c64vector?)
    (define-check+error-type c128vector c128vector?)

    (##define-vector-fold c64vector-fold reverse-c64vector-fold check-c64vector c64vector-length c64vector-ref)
    (##define-collect-vector collect-c64vector make-c64vector c64vector-length c64vector-set! c64vector-copy!)

    (define-flatten-transducer flatten-c64vector c64vector? c64vector-fold)
    (define-chain-transducer chain-c64vector c64vector-fold)

    (define-interleave-transducer
      interleave-c64vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (c64vector-length coll)))
      c64vector-ref
      (lambda (_ s) (fx+ s 1)))

    (define-zip-transducer
      zip-c64vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (c64vector-length coll)))
      c64vector-ref
      (lambda (_ s) (fx+ s 1)))

    ;; A transducible type-class over c64vectors.
    (define c64vector-transducible
      (make-transducible c64vector-fold
                         collect-c64vector
                         flatten-c64vector
                         chain-c64vector
                         interleave-c64vector
                         zip-c64vector))

    (##define-vector-fold c128vector-fold reverse-c128vector-fold check-c128vector c128vector-length c128vector-ref)
    (##define-collect-vector collect-c128vector make-c128vector c128vector-length c128vector-set! c128vector-copy!)

    (define-flatten-transducer flatten-c128vector c128vector? c128vector-fold)
    (define-chain-transducer chain-c128vector c128vector-fold)

    (define-interleave-transducer
      interleave-c128vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (c128vector-length coll)))
      c128vector-ref
      (lambda (_ s) (fx+ s 1)))

    (define-zip-transducer
      zip-c128vector
      (lambda (coll) 0)
      (lambda (coll s) (fx>=? s (c128vector-length coll)))
      c128vector-ref
      (lambda (_ s) (fx+ s 1)))

    ;; A transducible type-class over c128vectors.
    (define c128vector-transducible
      (make-transducible c128vector-fold
                         collect-c128vector
                         flatten-c128vector
                         chain-c128vector
                         interleave-c128vector
                         zip-c128vector)))

  ;; End-of-module
  )