;;; Copyright (c) 2023 Jeremy Steward
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions are met:
;;;
;;; 1. Redistributions of source code must retain the above copyright notice,
;;; this list of conditions and the following disclaimer.
;;;
;;; 2. Redistributions in binary form must reproduce the above copyright notice,
;;; this list of conditions and the following disclaimer in the documentation
;;; and/or other materials provided with the distribution.
;;;
;;; 3. Neither the name of the copyright holder nor the names of its
;;; contributors may be used to endorse or promote products derived from this
;;; software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;;; CONSEQUENTIAL DAMAGES  INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;; POSSIBILITY OF SUCH DAMAGE.

(cond-expand
  (chicken-5
    (declare (safe-globals) (specialize))))

(define-library (arrays storage)
  (import (scheme base)
          (scheme case-lambda)
          (srfi 4)
          (srfi 128)
          (srfi 133)
          (only (srfi 160 u8) u8? u8vector-copy u8vector-copy!)
          (only (srfi 160 u16) u16? u16vector-copy u16vector-copy!)
          (only (srfi 160 u32) u32? u32vector-copy u32vector-copy!)
          (only (srfi 160 u64) u64? u64vector-copy u64vector-copy!)
          (only (srfi 160 s8) s8? s8vector-copy s8vector-copy!)
          (only (srfi 160 s16) s16? s16vector-copy s16vector-copy!)
          (only (srfi 160 s32) s32? s32vector-copy s32vector-copy!)
          (only (srfi 160 s64) s64? s64vector-copy s64vector-copy!)
          (only (srfi 160 f32) f32? f32vector-copy f32vector-copy!)
          (only (srfi 160 f64) f64? f64vector-copy f64vector-copy!)
          (only (srfi 160 c64)
                make-c64vector
                c64?
                c64vector?
                c64vector-length
                c64vector-ref
                c64vector-set!
                c64vector-copy
                c64vector-copy!)
          (only (srfi.160 c128)
                make-c128vector
                c128?
                c128vector?
                c128vector-length
                c128vector-ref
                c128vector-set!
                c128vector-copy
                c128vector-copy!)
          (transducers vectors))

  (cond-expand
    (chicken-5
      (import (only (chicken base) void)
              (rename (chicken fixnum)
                      (fx= fx=?)
                      (fx< fx<?)
                      (fx<= fx<=?)
                      (fx> fx>?)
                      (fx>= fx>=?))
              (only (check-errors)
                    define-check+error-type
                    check-non-negative-fixnum)))
    (else
      (error "Storage-classes does not yet support this R7RS Scheme implementation")))

  (include-library-declarations "src/arrays.storage.exports.scm")

  (begin
    ;; A storage class is a type-class object that covers types that can "store" values.
    ;;
    ;; Specifically, storage classes refer to contiguous containers that can be
    ;; accessed randomly. They are meant to exist as the backend data storage
    ;; for generalized-arrays.
    (define-record-type <storage-class>
      ;; Constructs a storage class.
      (make-storage-class short-id
                          constructor
                          ref
                          set
                          length
                          copy
                          copy!
                          transducible
                          comparator
                          default-element)

      ;; Predicate for testing if an object is a storage class.
      storage-class?

      ;; A short ID for the storage class.
      ;;
      ;; This identifier exists to be a unique short-code for a storage class'
      ;; type or kind. For example, a vector-storage-class (which uses a Scheme
      ;; vector as the underlying storage type) would have a short ID that is
      ;; the symbol 'v.
      (short-id storage-class-short-id)

      ;; A procedure of the form (make-storage size #!optional fill) which
      ;; constructs a new storage object of the implementing storage class.
      (constructor storage-class-constructor)

      ;; A procedure of the form (storage-ref storage index) which gets an
      ;; individual element at `index` from the `storage` object.
      (ref storage-class-ref)

      ;; A procedure of the form (storage-set! storage index value) which sets
      ;; `value` to the element at `index` in `storage` object.
      (set storage-class-set)

      ;; A procedure of the form (storage-length storage) which gets the number
      ;; of total elements in the `storage` object.
      (length storage-class-length)

      ;; A procedure of the form (storage-copy storage) which creates a direct
      ;; copy of the `storage` object and returns it.
      (copy storage-class-copy)

      ;; A procedure of the form (storage-copy storage) which creates a direct
      ;; copy of the `storage` object and returns it.
      (copy! storage-class-copy!)

      ;; A transducible type-class over the storage object kind.
      ;;
      ;; See the documentation of transducible type-classes in the transducers
      ;; library for more details.
      (transducible storage-class-transducible)

      ;; A SRFI-128 comparator for storage objects of the storage class.
      (comparator storage-class-comparator)

      ;; A value which represents the default element of the storage object.
      ;;
      ;; This is used when producing a default storage object, or filling
      ;; individual elements with a default value when filtered.
      (default-element storage-class-default-element))

    (define-check+error-type storage-class storage-class?)

    ;;; Invokers
    ;;
    ;; The following procedures are for invoking stored procedures in the
    ;; argument storage-classes. The naming is slightly different than just
    ;; plain-invoking the storage-class procedures themselves. In fact, these
    ;; are all named `storage-object` to differentiate them from storage-class
    ;; procedures.
    ;;
    ;; Functionally speaking these shouldn't be any different from calling the
    ;; storage-class procedures directly but may offer a cleaner interface.

    ;; Constructs a storage object of the provided storage-class with `n`
    ;; elements defaulting to the provided `fill` value. If `fill` is not
    ;; provided, the storage-class' default element will be used instead.
    (define make-storage-object
      (case-lambda
        ((storage-class n fill)
         (let ((constructor (storage-class-constructor storage-class)))
           (constructor n fill)))
        ((storage-class n)
         (let ((fill (storage-class-default-element storage-class)))
           (make-storage-object storage-class n fill)))))

    ;; Gets the `i`th element contained inside the storage object `obj`.
    (define (storage-object-ref storage-class obj i)
      (check-storage-class 'storage-object-ref storage-class 'storage-class)
      (let ((comparator (storage-class-comparator storage-class)))
        (comparator-check-type comparator obj)
        (check-non-negative-fixnum 'storage-object-ref i 'i)
        (let ((storage-ref (storage-class-ref storage-class)))
          (storage-ref obj i))))

    ;; Sets the `i`th element contained inside the storage object `obj` to
    ;; `value`.
    (define (storage-object-set! storage-class obj i value)
      (check-storage-class 'storage-object-set! storage-class 'storage-class)
      (let ((comparator (storage-class-comparator storage-class)))
        (comparator-check-type comparator obj)
        (check-non-negative-fixnum 'storage-object-ref i 'i)
        (let ((storage-set! (storage-class-set storage-class)))
          (storage-set! obj i value))))

    ;; Gets the length (number of elements contained within) an `obj` of class
    ;; `storage-class`.
    (define (storage-object-length storage-class obj)
      (check-storage-class 'storage-object-length storage-class 'storage-class)
      (let ((comparator (storage-class-comparator storage-class)))
        (comparator-check-type comparator obj)
        (let ((storage-length (storage-class-length storage-class)))
          (storage-length obj))))

    (define (storage-object-copy-impl! storage-class to at from start end)
      (check-storage-class 'storage-object-copy! storage-class 'storage-class)
      (let ((comparator (storage-class-comparator storage-class)))
        (comparator-check-type comparator to)
        (comparator-check-type comparator from)
        (let ((storage-copy! (storage-class-copy! storage-class)))
          (storage-copy! to at from start end))))

    ;; Copies the elements in the `[start end)` range from storage object
    ;; `from` to storage object `to`, starting at index `at`.
    (define storage-object-copy!
      (case-lambda
        ((storage-class to at from start end)
         (storage-object-copy-impl! storage-class to at from start end))
        ((storage-class to at from start)
         (let ((end (storage-object-length storage-class from)))
           (storage-object-copy-impl! storage-class to at from start end)))
        ((storage-class to at from)
         (storage-object-copy! storage-class to at from 0))))

    (define storage-object-copy
      (case-lambda
        ((storage-class object start end)
         (check-storage-class 'storage-object-copy storage-class 'storage-class)
         (comparator-check-type (storage-class-comparator storage-class) object)
         (let ((storage-copy (storage-class-copy storage-class)))
           (storage-copy object start end)))
        ((storage-class object start)
         (storage-object-copy storage-class
                              object
                              start
                              ((storage-class-length storage-class) object)))
        ((storage-class object)
         (storage-object-copy storage-class
                              object
                              0
                              ((storage-class-length storage-class) object)))))

    ;;; Standard storage classes
    (define vector-storage-class
      (make-storage-class 'v
                          make-vector
                          vector-ref
                          vector-set!
                          vector-length
                          vector-copy
                          vector-copy!
                          vector-transducible
                          (make-vector-comparator (make-default-comparator)
                                                  vector?
                                                  vector-length
                                                  vector-ref)
                          (void)))

    (define (make-fixnum-comparator type-test?)
      (make-comparator type-test? fx=? fx<? number-hash))

    (define (make-flonum-comparator type-test?)
      (make-comparator type-test? = < number-hash))

    (define u8vector-storage-class
      (make-storage-class 'u8
                          make-u8vector
                          u8vector-ref
                          u8vector-set!
                          u8vector-length
                          u8vector-copy
                          u8vector-copy!
                          u8vector-transducible
                          (make-vector-comparator (make-fixnum-comparator u8?)
                                                  u8vector?
                                                  u8vector-length
                                                  u8vector-ref)
                          0))

    (define s8vector-storage-class
      (make-storage-class 's8
                          make-s8vector
                          s8vector-ref
                          s8vector-set!
                          s8vector-length
                          s8vector-copy
                          s8vector-copy!
                          s8vector-transducible
                          (make-vector-comparator (make-fixnum-comparator s8?)
                                                  s8vector?
                                                  s8vector-length
                                                  s8vector-ref)
                          0))

    (define u16vector-storage-class
      (make-storage-class 'u16
                          make-u16vector
                          u16vector-ref
                          u16vector-set!
                          u16vector-length
                          u16vector-copy
                          u16vector-copy!
                          u16vector-transducible
                          (make-vector-comparator (make-fixnum-comparator u16?)
                                                  u16vector?
                                                  u16vector-length
                                                  u16vector-ref)
                          0))

    (define s16vector-storage-class
      (make-storage-class 's16
                          make-s16vector
                          s16vector-ref
                          s16vector-set!
                          s16vector-length
                          s16vector-copy
                          s16vector-copy!
                          s16vector-transducible
                          (make-vector-comparator (make-fixnum-comparator s16?)
                                                  s16vector?
                                                  s16vector-length
                                                  s16vector-ref)
                          0))

    (define u32vector-storage-class
      (make-storage-class 'u32
                          make-u32vector
                          u32vector-ref
                          u32vector-set!
                          u32vector-length
                          u32vector-copy
                          u32vector-copy!
                          u32vector-transducible
                          (make-vector-comparator (make-fixnum-comparator u32?)
                                                  u32vector?
                                                  u32vector-length
                                                  u32vector-ref)
                          0))

    (define s32vector-storage-class
      (make-storage-class 's32
                          make-s32vector
                          s32vector-ref
                          s32vector-set!
                          s32vector-length
                          s32vector-copy
                          s32vector-copy!
                          s32vector-transducible
                          (make-vector-comparator (make-fixnum-comparator s32?)
                                                  s32vector?
                                                  s32vector-length
                                                  s32vector-ref)
                          0))

    (define u64vector-storage-class
      (make-storage-class 'u64
                          make-u64vector
                          u64vector-ref
                          u64vector-set!
                          u64vector-length
                          u64vector-copy
                          u64vector-copy!
                          u64vector-transducible
                          (make-vector-comparator (make-fixnum-comparator u64?)
                                                  u64vector?
                                                  u64vector-length
                                                  u64vector-ref)
                          0))

    (define s64vector-storage-class
      (make-storage-class 's64
                          make-s64vector
                          s64vector-ref
                          s64vector-set!
                          s64vector-length
                          s64vector-copy
                          s64vector-copy!
                          s64vector-transducible
                          (make-vector-comparator (make-fixnum-comparator s64?)
                                                  s64vector?
                                                  s64vector-length
                                                  s64vector-ref)
                          0))

    (define f32vector-storage-class
      (make-storage-class 'f32
                          make-f32vector
                          f32vector-ref
                          f32vector-set!
                          f32vector-length
                          f32vector-copy
                          f32vector-copy!
                          f32vector-transducible
                          (make-vector-comparator (make-flonum-comparator f32?)
                                                  f32vector?
                                                  f32vector-length
                                                  f32vector-ref)
                          0.0))

    (define f64vector-storage-class
      (make-storage-class 'f64
                          make-f64vector
                          f64vector-ref
                          f64vector-set!
                          f64vector-length
                          f64vector-copy
                          f64vector-copy!
                          f64vector-transducible
                          (make-vector-comparator (make-flonum-comparator f64?)
                                                  f64vector?
                                                  f64vector-length
                                                  f64vector-ref)
                          0.0))

    (define c64vector-storage-class
      (make-storage-class 'c64
                          make-c64vector
                          c64vector-ref
                          c64vector-set!
                          c64vector-length
                          c64vector-copy
                          c64vector-copy!
                          c64vector-transducible
                          (make-vector-comparator (make-flonum-comparator c64?)
                                                  c64vector?
                                                  c64vector-length
                                                  c64vector-ref)
                          0.0+0.0i))

    (define c128vector-storage-class
      (make-storage-class 'c128
                          make-c128vector
                          c128vector-ref
                          c128vector-set!
                          c128vector-length
                          c128vector-copy
                          c128vector-copy!
                          c128vector-transducible
                          (make-vector-comparator (make-flonum-comparator c128?)
                                                  c128vector?
                                                  c128vector-length
                                                  c128vector-ref)
                          0.0+0.0i))
    ))