;;;; Copyright (c) 2017, 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.

(define-record-type storage-class
  (%make-storage-class short-id constructor accessor mutator sizer predicate fill)
  storage-class?
  (short-id %storage-class-short-id : symbol)
  (constructor %storage-class-constructor : procedure)
  (accessor %storage-class-accessor : procedure)
  (mutator %storage-class-mutator : procedure)
  (sizer %storage-class-sizer : procedure)
  (predicate %storage-class-predicate : procedure)
  (fill %storage-class-default-fill))

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

;; Means to check if a storage object corresponds to a given storage class
(define-error-type storage-object "storage object is not of same type as storage class.")
(define (check-storage-object loc storage-class storage-object)
  (unless ((%storage-class-predicate storage-class) storage-object)
    (error-storage-object loc storage-object)))

(define *UNSPECIFIED* (list 'UNSPECIFIED)) ; Used to check fill values.

;;; Constructors

;; Returns a storage class with the specified procedures as constructor,
;; accessor, mutator, sizer, and default fill value.
(define (make-storage-class short-id constructor accessor mutator sizer predicate default-fill)
  (%make-storage-class short-id constructor accessor mutator sizer predicate default-fill))

;;; Predicates

;; Returns #t if obj is a storage class, and #f otherwise.
;; Note that this is defined as a part of the record type.
;; (define (storage-class? obj))

;;; Accessors

;; Returns the symbol representing the storage-class's short ID.
(define (storage-class-short-id storage-class)
  (check-storage-class 'storage-class-short-id storage-class)
  (%storage-class-short-id storage-class))

;; Returns the constructor of storage-class. This procedure returns a storage
;; object belonging to the storage class, and can be called with one or two
;; arguments: the first is an exact non-negative integer specifying the size of
;; the object. If objects of the class do not have a fixed size, the size must be
;; specified as #f. The second is a value to fill all the elements with. If the
;; second argument is omitted, the elements will have arbitrary contents. If the
;; class does not require storage objects (because the values are
;; algorithmically generated, for example), the constructor returns #f.
(define (storage-class-constructor storage-class)
  (check-storage-class 'storage-class-constructor storage-class)
  (%storage-class-constructor storage-class))

;; Returns the accessor of storage-class as a procedure. This procedure takes two
;; arguments, a storage object and an exact non-negative integer, and returns the
;; value of the element indexed by the integer. It is an error if the index is
;; greater than or equal to the size.
(define (storage-class-accessor storage-class)
  (check-storage-class 'storage-class-accessor storage-class)
  (%storage-class-accessor storage-class))

;; Returns the mutator of storage-class as a procedure. This procedure takes three
;; arguments, a storage object, an exact non-negative integer, and a value. It
;; mutates the element of the object specified by the index to be the value. It is
;; an error if the index is greater than or equal to the size, or if the object is
;; not capable of storing the value.
(define (storage-class-mutator storage-class)
  (check-storage-class 'storage-class-mutator storage-class)
  (%storage-class-mutator storage-class))

;; Returns the sizer of storage-class as a procedure. This procedure takes one
;; argument, a storage object. It returns the size of the object specified when the
;; object was created. This may be an exact non-negative integer or #f.
(define (storage-class-sizer storage-class)
  (check-storage-class 'storage-class-sizer storage-class)
  (%storage-class-sizer storage-class))

;; Returns the predicate for testing a storage class' storage object. This
;; procedure takes one argument, a storage object. It evaluates #t if a storage
;; object is of the type described by the storage class, and #f otherwise.
(define (storage-class-predicate storage-class)
  (check-storage-class 'storage-class-predicate storage-class)
  (%storage-class-predicate storage-class))

;; Returns the default fill value of a storage-class as a value. This procedure
;; takes one argument a storage object. It returns the default fill value for
;; the storage object when it was created.
(define (storage-class-default-fill storage-class)
  (check-storage-class 'storage-class-default-fill storage-class)
  (%storage-class-default-fill storage-class))

;;; Invokers

;; Returns a newly allocated storage object with class storage-class and length
;; n, filled with value fill, if specified. If fill is not specified, then the
;; default fill value for the storage object is used.
(define (make-storage-object storage-class n #!optional (fill *UNSPECIFIED*))
  (check-storage-class 'make-storage-object storage-class)
  (check-natural-fixnum 'make-storage-object n)
  (let ((kons (%storage-class-constructor storage-class))
        (fill (if (eq? fill *UNSPECIFIED*)
                (%storage-class-default-fill storage-class)
                fill)))
    (kons n fill)))

;; Returns the nth element of storage-object as seen through the lens of
;; storage-class. It is an error if n is not less than the size of
;; storage-object.
(define (storage-object-ref storage-class storage-object n)
  (check-storage-class 'storage-object-ref storage-class)
  (check-storage-object 'storage-object-ref storage-class storage-object)
  (let ((storage-ref (%storage-class-accessor storage-class)))
   (storage-ref storage-object n)))

;; Mutates the nth element of storage-object as seen through the lens of
;; storage-class so that its value is value. It is an error if n is not less
;; than the size of storage-object.
(define (storage-object-set! storage-class storage-object n value)
  (check-storage-class 'storage-object-set! storage-class)
  (check-storage-object 'storage-object-set! storage-class storage-object)
  (let ((storage-set! (%storage-class-mutator storage-class)))
   (storage-set! storage-object n value)))

;; Returns the size of storage-object as seen through the lens of storage-class.
(define (storage-object-length storage-class storage-object)
  (check-storage-class 'storage-object-length storage-class)
  (check-storage-object 'storage-object-length storage-class storage-object)
  (let ((storage-length (%storage-class-sizer storage-class)))
   (storage-length storage-object)))

;;; Standard storage classes

(define vector-storage-class
  (make-storage-class 'v
                      make-vector
                      vector-ref
                      vector-set!
                      vector-length
                      vector?
                      (void)))

(define u8vector-storage-class
  (make-storage-class 'u8
                      make-u8vector
                      u8vector-ref
                      u8vector-set!
                      u8vector-length
                      u8vector?
                      #f))

(define s8vector-storage-class
  (make-storage-class 's8
                      make-s8vector
                      s8vector-ref
                      s8vector-set!
                      s8vector-length
                      s8vector?
                      #f)  )

(define u16vector-storage-class
  (make-storage-class 'u16
                      make-u16vector
                      u16vector-ref
                      u16vector-set!
                      u16vector-length
                      u16vector?
                      #f))

(define s16vector-storage-class
  (make-storage-class 's16
                      make-s16vector
                      s16vector-ref
                      s16vector-set!
                      s16vector-length
                      s16vector?
                      #f))

(define u32vector-storage-class
  (make-storage-class 'u32
                      make-u32vector
                      u32vector-ref
                      u32vector-set!
                      u32vector-length
                      u32vector?
                      #f))

(define s32vector-storage-class
  (make-storage-class 's32
                      make-s32vector
                      s32vector-ref
                      s32vector-set!
                      s32vector-length
                      s32vector?
                      #f))

;;; {u,s}64vectors are not currently supported by CHICKEN's srfi-4
;;; implementation. Complain to the maintainers, or wait until CHICKEN 5.
;;(define u64vector-storage-class
;;  )
;;
;;(define s64vector-storage-class
;;  )

(define f32vector-storage-class
  (make-storage-class 'f32
                      make-f32vector
                      f32vector-ref
                      f32vector-set!
                      f32vector-length
                      f32vector?
                      #f))

(define f64vector-storage-class
  (make-storage-class 'f64
                      make-f64vector
                      f64vector-ref
                      f64vector-set!
                      f64vector-length
                      f64vector?
                      #f))

;; Complex number storage classes need a whole new set of procedures to
;; describe them. To align with BLAS conventions, I will make c64 vectors such
;; that they are f32 vectors, except that real components will be aligned to
;; even indices, and imaginary components to odd indices. Thus if you want a
;; vector of 3 complex numbers (e.g. 1+2i, 3+4i, 5+6i), then you would have an
;; f32vector as follows:
;;
;;   #f32(1 2 3 4 5 6)
;;
;; The length is twice as long, as can be seen in the above example. This
;; complies with BLAS / LAPACK(E) conventions for passing in arrays of complex
;; numbers. In C this usually gets muddled because the types specify
;; complex_t[n], which is usually just a struct of two double values for the
;; real and imaginary parts. The memory layout for such structs is no different
;; than the memory layout of a float_t[n * 2].
(define (make-c64vector n #!optional (fill #f))
  (make-f32vector (fx* n 2) fill))

(define (c64vector-length c64vector)
  (fx/ (f32vector-length c64vector) 2))

(define (c64vector-ref c64vector n)
  (check-natural-fixnum 'c64vector-ref n)
  (check-half-closed-interval 'c64vector-ref n 0 (c64vector-length c64vector))
  (let ((index (fx* n 2)))
   (make-rectangular (f32vector-ref c64vector index)
                     (f32vector-ref c64vector (fx+ index 1)))))

(define (c64vector-set! c64vector n value)
  (check-natural-fixnum 'c64vector-ref n)
  (check-half-closed-interval 'c64vector-ref n 0 (c64vector-length c64vector))
  (let ((index (fx* n 2)))
   (f32vector-set! c64vector index (real-part value))
   (f32vector-set! c64vector (fx+ index 1) (imag-part value))))

(define c64vector-storage-class
  (make-storage-class 'c64
                      make-c64vector
                      c64vector-ref
                      c64vector-set!
                      c64vector-length
                      f32vector?
                      #f))

;; For c128vectors, I use the same technique, just with f64vectors instead
;; of f32vectors.
(define (make-c128vector n #!optional (fill #f))
  (make-f64vector (fx* n 2) fill))

(define (c128vector-length c128vector)
  (fx/ (f64vector-length c128vector) 2))

(define (c128vector-ref c128vector n)
  (check-natural-fixnum 'c128vector-ref n)
  (check-half-closed-interval 'c128vector-ref n 0 (c128vector-length c128vector))
  (let ((index (fx* n 2)))
   (make-rectangular (f64vector-ref c128vector index)
                     (f64vector-ref c128vector (fx+ index 1)))))

(define (c128vector-set! c128vector n value)
  (check-natural-fixnum 'c128vector-ref n)
  (check-half-closed-interval 'c128vector-ref n 0 (c128vector-length c128vector))
  (let ((index (fx* n 2)))
   (f64vector-set! c128vector index (real-part value))
   (f64vector-set! c128vector (fx+ index 1) (imag-part value))))

(define c128vector-storage-class
  (make-storage-class 'c128
                      make-c128vector
                      c128vector-ref
                      c128vector-set!
                      c128vector-length
                      f64vector?
                      #f))