;;; Copyright (c) 2020 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 default-storage-classes
  (list vector-storage-class
        u8vector-storage-class
        s8vector-storage-class
        u16vector-storage-class
        s16vector-storage-class
        u32vector-storage-class
        s32vector-storage-class
        u64vector-storage-class
        s64vector-storage-class
        f32vector-storage-class
        f64vector-storage-class
        c64vector-storage-class
        c128vector-storage-class))

(test-group "make-storage-class"
  (test-assert "make-storage-class returns something that passes storage-class?"
               (storage-class? vector-storage-class))

  (test-assert "all default storage classes pass storage-class?"
               (transduce list-fold
                          values
                          (collect-all storage-class?)
                          default-storage-classes)))

;; Testing construction of storage class types
(test-group "make-storage-object"
  (test "vector storage object constructor makes vector primitive"
        (vector "Value" "Value" "Value")
        (make-storage-object vector-storage-class 3 "Value"))

  (test "u8 vector storage object constructor makes u8vector primitive"
        (u8vector 42 42 42)
        (make-storage-object u8vector-storage-class 3 42))

  (test "s8 vector storage object constructor makes s8vector primitive"
        (s8vector 42 42 42)
        (make-storage-object s8vector-storage-class 3 42))

  (test "u16 vector storage object constructor makes u16vector primitive"
        (u16vector 42 42 42)
        (make-storage-object u16vector-storage-class 3 42))

  (test "s16 vector storage object constructor makes s16vector primitive"
        (s16vector 42 42 42)
        (make-storage-object s16vector-storage-class 3 42))

  (test "u32 vector storage object constructor makes u32vector primitive"
        (u32vector 42 42 42)
        (make-storage-object u32vector-storage-class 3 42))

  (test "s32 vector storage object constructor makes s32vector primitive"
        (s32vector 42 42 42)
        (make-storage-object s32vector-storage-class 3 42))

  (test "f32 vector storage object constructor makes f32vector primitive"
        (f32vector 42.4 42.4 42.4)
        (make-storage-object f32vector-storage-class 3 42.4))

  (test "f64 vector storage object constructor makes f64vector primitive"
        (f64vector 42.4 42.4 42.4)
        (make-storage-object f64vector-storage-class 3 42.4))

  (test "c64 vector storage object constructor makes c64vector primitive"
        (c64vector 42+5i 42+5i 42+5i)
        (make-storage-object c64vector-storage-class 3 42+5i))

  (test "c128 vector storage object constructor makes c128vector primitive"
        (c128vector 42+5i 42+5i 42+5i)
        (make-storage-object c128vector-storage-class 3 42+5i)))


;; Testing size / length operations on a storage object for storage class types
(test-group "storage-object-length"
  (define len 11)
  (for-each list-fold
            (inspect
              (lambda (storage-class)
                (test (format #f "~S vector object has correct length."
                              (storage-class-short-id storage-class))
                      len
                      (let ((obj (make-storage-object storage-class len)))
                        (storage-object-length storage-class obj)))))
            default-storage-classes))

(test-group "storage-object-ref"
  (define sample-vectors
    (list (vector 1 2 3 4 5)
          (u8vector 1 2 3 4 5)
          (s8vector 1 2 3 4 5)
          (u16vector 1 2 3 4 5)
          (s16vector 1 2 3 4 5)
          (u32vector 1 2 3 4 5)
          (s32vector 1 2 3 4 5)
          (u64vector 1 2 3 4 5)
          (s64vector 1 2 3 4 5)
          (f32vector 3 4 -9 42.4 0)
          (f64vector 3 4 -9 42.4 0)
          (c64vector 1+2i 3+4i 5+6i 42+5i 8+9i 10+11i)
          (c128vector 1+2i 3+4i 5+6i 42+5i 8+9i 10+11i)))

  (define third-elements
    (list 4 4 4 4 4 4 4 4 4 42.4 42.4 42.0+5.0i 42.0+5.0i))

  (for-each list-fold
            (compose
              (zip-list sample-vectors)
              (zip-list third-elements)
              (inspect
                (lambda (vals)
                  (let ((storage-class (caar vals))
                        (object (cdar vals))
                        (expected-value (cdr vals)))
                    (test (format #f "~S storage-object-ref gets correct element"
                                  (storage-class-short-id storage-class))
                          expected-value
                          (storage-object-ref storage-class object 3))))))
            default-storage-classes))


(test-group "storage-object-set"
  (define original-value 42)
  (define mutated-value 50)
  (define len 20)
  (define index-to-mutate 11)

  (define (harness original-value mutated-value)
    (lambda (storage-class)
      (let ((object (make-storage-object storage-class len original-value)))
        ;; First test that constructing the object sets every value to `original-value`
        (test-assert
          (format #f "~S vector before mutation has every value set to ~S"
                  (storage-class-short-id storage-class)
                  original-value)
          (transduce (transducible-folder (storage-class-transducible storage-class))
                     values
                     (collect-all (lambda (i) (eqv? i original-value)))
                     object))
        ;; Mutate the element at index-to-mutate to the mutated-value
        (storage-object-set! storage-class
                             object
                             index-to-mutate
                             mutated-value)
        ;; Lastly, we now test every value to ensure that they are
        ;; `original-value`, except when we are at `index-to-mutate`,
        ;; whereupon it should be the `mutated-value`.
        (test-assert
          (format #f "~S vector after mutation has only one index set to ~S"
                  (storage-class-short-id storage-class)
                  mutated-value)
          (transduce (transducible-folder (storage-class-transducible storage-class) )
                     enumerate
                     (collect-all
                       (lambda (pair)
                         (let ((idx (car pair))
                               (val (cdr pair)))
                           (if (eq? idx index-to-mutate)
                             (eqv? val mutated-value)
                             (eqv? val original-value)))))
                     object)))))

  (for-each list-fold
            (inspect (harness 42 50))
            (list vector-storage-class
                  u8vector-storage-class
                  s8vector-storage-class
                  u16vector-storage-class
                  s16vector-storage-class
                  u32vector-storage-class
                  s32vector-storage-class
                  u64vector-storage-class
                  s64vector-storage-class))

  (for-each list-fold
            (inspect (harness 42.0 50.0))
            (list f32vector-storage-class
                  f64vector-storage-class))

  (for-each list-fold
            (inspect (harness 0.0+1.0i 42.0+5.0i))
            (list c64vector-storage-class
                  c128vector-storage-class)))

(test-group "storage-object-copy!"
  (define original-fill 1)
  (define len 20)

  (for-each list-fold
            (compose
              ;; This harness tests that a full copy is equal to the original
              (inspect
                (lambda (storage-class)
                  (let ((original-object (make-storage-object storage-class len original-fill))
                        (object-to-copy-into (make-storage-object storage-class len)))
                    (test (format #f "~S vector and its copy are equal"
                                  (storage-class-short-id storage-class))
                          original-object
                          (begin
                            (storage-object-copy! storage-class
                                                  object-to-copy-into
                                                  0
                                                  original-object)
                            object-to-copy-into)))))
              ;; This harness tests that whne given a custom range (e.g. first
              ;; three elements) that only those elements are copied.
              (inspect
                (lambda (storage-class)
                  (let ((original-object (make-storage-object storage-class len original-fill))
                        (object-to-copy-into (make-storage-object storage-class len)))
                    (test-assert
                      (format #f "~S vector storage copy first three elements only"
                              (storage-class-short-id storage-class))
                      (begin
                        (storage-object-copy! storage-class
                                              object-to-copy-into
                                              0
                                              original-object
                                              0
                                              3)
                        (transduce
                          (transducible-folder (storage-class-transducible storage-class))
                          enumerate
                          (collect-all
                            (lambda (pair)
                              (let ((idx (car pair))
                                    (value (cdr pair)))
                                (if (< idx 3)
                                  (equal? value
                                       (storage-object-ref storage-class
                                                           original-object
                                                           idx))
                                  (equal? value
                                       (storage-class-default-element storage-class))))))
                          object-to-copy-into)))))))
            default-storage-classes))