(test-group "hsl constructor"
  (define (do-test h s l a)
    (let ((c (hsl h s l a))
          (v (f32vector h s l a)))
      (test-assert (sprintf "(hsl ~A ~A ~A ~A)" h s l a)
        (and (hsl? c)
             (= (hsl-h c) (f32vector-ref v 0))
             (= (hsl-s c) (f32vector-ref v 1))
             (= (hsl-l c) (f32vector-ref v 2))
             (= (hsl-a c) (f32vector-ref v 3))))))

  (do-test 0 0 0 0)
  (do-test 0.1 0.2 0.3 0.4)
  (do-test 1 1 1 1)
  (do-test 1 2 3 4)
  (do-test 1.0 2.0 3.0 4.0)
  (do-test -1.0 -2.0 -3.0 -4.0)

  (test #f (hsl-parent (hsl 1 2 3 4)))

  (test-error (hsl))
  (test-error (hsl 1))
  (test-error (hsl 1 2))
  (test 1.0 (hsl-a (hsl 1 2 3))))


(test-group "hsl setters"
  ;; Setters
  (let ((c (hsl 0.1 0.2 0.3 0.4)))
    (test c (hsl-h-set! c 32.1))
    (test-assert (hsl= (hsl 32.1 0.2 0.3 0.4) c))
    (test c (hsl-s-set! c 43.2))
    (test-assert (hsl= (hsl 32.1 43.2 0.3 0.4) c))
    (test c (hsl-l-set! c 54.3))
    (test-assert (hsl= (hsl 32.1 43.2 54.3 0.4) c))
    (test c (hsl-a-set! c 65.4))
    (test-assert (hsl= (hsl 32.1 43.2 54.3 65.4) c)))

  ;; set! with getters
  (let ((c (hsl 0.1 0.2 0.3 0.4)))
    (test c (set! (hsl-h c) 32.1))
    (test-assert (hsl= (hsl 32.1 0.2 0.3 0.4) c))
    (test c (set! (hsl-s c) 43.2))
    (test-assert (hsl= (hsl 32.1 43.2 0.3 0.4) c))
    (test c (set! (hsl-l c) 54.3))
    (test-assert (hsl= (hsl 32.1 43.2 54.3 0.4) c))
    (test c (set! (hsl-a c) 65.4))
    (test-assert (hsl= (hsl 32.1 43.2 54.3 65.4) c))))


(test-group "hsl?"
  (test-assert (hsl? (hsl 1 2 3 4)))
  (test-assert (not (hsl? '(1 2 3 4))))
  (test-assert (not (hsl? #(1 2 3 4))))
  (test-assert (not (hsl? #f32(1 2 3 4))))
  (test-assert (not (hsl? (rgb 1 2 3 4))))
  (test-assert (not (hsl? (rgb8 1 2 3 4)))))


(test-group "hsl="
  (test-assert (hsl= (hsl 0.1 0.2 0.3 0.4) (hsl 0.1 0.2 0.3 0.4)))
  (test-assert (hsl= (hsl 1 2 3 4) (hsl 1 2 3 4)))
  (test-assert (hsl= (hsl 1 2 3 4) (hsl 1.0 2.0 3.0 4.0)))
  (test-assert (hsl= (hsl 1.0 2.0 3.0 4.0) (hsl 1 2 3 4)))

  (test-assert (not (hsl= (hsl 0 2 3 4) (hsl 1 2 3 4))))
  (test-assert (not (hsl= (hsl 1 0 3 4) (hsl 1 2 3 4))))
  (test-assert (not (hsl= (hsl 1 2 0 4) (hsl 1 2 3 4))))
  (test-assert (not (hsl= (hsl 1 2 3 0) (hsl 1 2 3 4))))

  (test-error (hsl= (hsl 1 2 3 4) '(1 2 3 4)))
  (test-error (hsl= '(1 2 3 4) (hsl 1 2 3 4)))
  (test-error (hsl= (hsl 1 2 3 4) (rgb 1 2 3 4)))
  (test-error (hsl= (rgb 1 2 3 4) (hsl 1 2 3 4)))
  (test-error (hsl= (hsl 1 2 3 4) (rgb8 1 2 3 4)))
  (test-error (hsl= (rgb8 1 2 3 4) (hsl 1 2 3 4))))


(test-group "hsl-near?"
  (define (do-test x y #!optional (e 1e-5))
    (test-assert (sprintf "~A ≅ ~A (± ~A)" x y e)
      (and (hsl-near? (hsl x 0 0 0) (hsl y 0 0 0) e)
           (hsl-near? (hsl 0 x 0 0) (hsl 0 y 0 0) e)
           (hsl-near? (hsl 0 0 x 0) (hsl 0 0 y 0) e)
           (hsl-near? (hsl 0 0 0 x) (hsl 0 0 0 y) e))))

  (define (do-test-not x y #!optional (e 1e-5))
    (test-assert (sprintf "~A !≅ ~A (± ~A)" x y e)
      (and (not (hsl-near? (hsl x 0 0 0) (hsl y 0 0 0) e))
           (not (hsl-near? (hsl 0 x 0 0) (hsl 0 y 0 0) e))
           (not (hsl-near? (hsl 0 0 x 0) (hsl 0 0 y 0) e))
           (not (hsl-near? (hsl 0 0 0 x) (hsl 0 0 0 y) e)))))

  (do-test 1.00 1.00)
  (do-test-not 1.00 1.01)
  (do-test-not 1.01 1.00)
  (do-test 1.00 1.01 11e-3)
  (do-test 1.01 1.00 11e-3)
  (do-test 100 150 50.001)
  (do-test -100 -150 50.001)

  (test-error (hsl-near? (hsl 1 2 3 4) #f32(1 2 3 4)))
  (test-error (hsl-near? #f32(1 2 3 4) (hsl 1 2 3 4)))
  (test-error (hsl-near? (hsl 1 2 3 4) (rgb 1 2 3 4)))
  (test-error (hsl-near? (rgb 1 2 3 4) (hsl 1 2 3 4)))
  (test-error (hsl-near? (hsl 1 2 3 4) (rgb8 1 2 3 4)))
  (test-error (hsl-near? (rgb8 1 2 3 4) (hsl 1 2 3 4))))


(test-group "hsl-copy"
  (let* ((orig (hsl 0.1 0.2 0.3 0.4))
         (copy (hsl-copy orig)))
    ;; copy has same values as orig
    (test-assert (hsl= copy (hsl 0.1 0.2 0.3 0.4)))

    ;; copy and orig do not share memory
    (hsl-h-set! copy 0.5)
    (hsl-s-set! copy 0.6)
    (hsl-l-set! copy 0.7)
    (hsl-a-set! copy 0.8)
    (test-assert (hsl= copy (hsl 0.5 0.6 0.7 0.8)))
    (test-assert (hsl= orig (hsl 0.1 0.2 0.3 0.4)))))


(test-group "hsl-copy!"
  (let ((src (hsl 0.1 0.2 0.3 0.4))
        (dst (hsl 0.5 0.6 0.7 0.8)))
    (test-assert (hsl= dst (hsl 0.5 0.6 0.7 0.8)))
    (let ((result (hsl-copy! src dst)))
      ;; dst has been overwritten with src values
      (test-assert (hsl= dst (hsl 0.1 0.2 0.3 0.4)))

      ;; dst and result are the same object
      (test-assert (eq? dst result))
      (hsl-h-set! result 0.9)
      (hsl-s-set! result 0.8)
      (hsl-l-set! result 0.7)
      (hsl-a-set! result 0.6)
      (test-assert (hsl= dst (hsl 0.9 0.8 0.7 0.6)))

      ;; src does not share memory with dst
      (test-assert (hsl= src (hsl 0.1 0.2 0.3 0.4))))))


(test-group "hsl->list"
  (define (do-test r g b a)
    (test (sprintf "(hsl->list (hsl ~A ~A ~A ~A))" r g b a)
          (f32vector->list (f32vector r g b a))
          (hsl->list (hsl r g b a))))
  (do-test 0 0 0 0)
  (do-test 0.1 0.2 0.3 0.4)
  (do-test 1 1 1 1)
  (do-test 1 2 3 4)
  (do-test 1234.5 2345.6 3456.7 4567.8)
  (do-test -1.0 -2.0 -3.0 -4.0))


(test-group "hsl-at / hsl-pointer / hsl-parent"
  (let ((blob (f32vector->blob #f32(0.1 0.2 0.3 0.4 0.5 0.6))))
    (test-assert (hsl= (hsl 0.1 0.2 0.3 0.4)
                       (hsl-at (make-locative blob))))
    (test-assert (hsl= (hsl 0.2 0.3 0.4 0.5)
                       (hsl-at (make-locative blob 4))))
    (test-assert (hsl= (hsl 0.3 0.4 0.5 0.6)
                       (hsl-at (make-locative blob 8)))))

  (let* ((ptr (allocate (* 6 4)))
         (c (hsl-at ptr)))
    (pointer-f32-set! ptr 0.1)
    (pointer-f32-set! (pointer+ ptr 4) 0.2)
    (pointer-f32-set! (pointer+ ptr 8) 0.3)
    (pointer-f32-set! (pointer+ ptr 12) 0.4)
    (pointer-f32-set! (pointer+ ptr 16) 0.5)
    (pointer-f32-set! (pointer+ ptr 20) 0.6)

    (test-assert (pointer=? ptr (hsl-pointer c)))
    (test-assert (hsl= c (hsl 0.1 0.2 0.3 0.4)))
    (set! (hsl-pointer c) (pointer+ ptr 4))
    (test-assert (hsl= c (hsl 0.2 0.3 0.4 0.5)))
    (set! (hsl-pointer c) (pointer+ ptr 8))
    (test-assert (hsl= c (hsl 0.3 0.4 0.5 0.6)))

    (free ptr))

  (test #f (hsl-parent (hsl-at (make-locative #f32(1 2 3 4)))))

  (let ((c (hsl-at (make-locative #f32(1 2 3 4)) 'foo)))
    (test 'foo (hsl-parent c))
    (set! (hsl-parent c) 'bar)
    (test 'bar (hsl-parent c))))


(test-group "hsl-normalize"
  (define (do-test input expected)
    (test-assert (apply sprintf "(hsl ~A ~A ~A ~A)" input)
      (hsl= (apply hsl expected)
            (hsl-normalize (apply hsl input)))))

  (test-assert "does not modify color"
    (let* ((c (hsl 372.0 0.1 0.9 -0.1))
           (result (hsl-normalize c)))
      (hsl= c (hsl 372.0 0.1 0.9 -0.1))))

  (do-test '(-0.1 0.2 0.3 0.4) '(359.9 0.2 0.3 0.4))
  (do-test '(0.1 -0.2 0.3 0.4) '(0.1 0.0 0.3 0.4))
  (do-test '(0.1 0.2 -0.3 0.4) '(0.1 0.2 0.0 0.4))
  (do-test '(0.1 0.2 0.3 -0.4) '(0.1 0.2 0.3 0.0))
  (do-test '(367.0 0.2 0.3 0.4) '(7.0 0.2 0.3 0.4))
  (do-test '(0.1 1.2 0.3 0.4) '(0.1 1.0 0.3 0.4))
  (do-test '(0.1 0.2 1.3 0.4) '(0.1 0.2 1.0 0.4))
  (do-test '(0.1 0.2 0.3 1.4) '(0.1 0.2 0.3 1.0))

  (near? 12.345 (hsl-h (hsl-normalize (hsl 362.345 0 0))))
  (near? 12.345 (hsl-h (hsl-normalize (hsl -347.655 0 0)))))


(test-group "hsl-normalize!"
  (define (do-test input expected)
    (test-assert (apply sprintf "(hsl ~A ~A ~A ~A)" input)
      (hsl= (apply hsl expected)
            (hsl-normalize! (apply hsl input)))))

  (test-assert "modifies and returns color"
    (let* ((c (hsl 372.0 0.1 0.9 -0.1))
           (result (hsl-normalize! c)))
      (and (eq? c result)
           (hsl= c (hsl 12.0 0.1 0.9 0.0)))))

  (do-test '(-0.1 0.2 0.3 0.4) '(359.9 0.2 0.3 0.4))
  (do-test '(0.1 -0.2 0.3 0.4) '(0.1 0.0 0.3 0.4))
  (do-test '(0.1 0.2 -0.3 0.4) '(0.1 0.2 0.0 0.4))
  (do-test '(0.1 0.2 0.3 -0.4) '(0.1 0.2 0.3 0.0))
  (do-test '(367.0 0.2 0.3 0.4) '(7.0 0.2 0.3 0.4))
  (do-test '(0.1 1.2 0.3 0.4) '(0.1 1.0 0.3 0.4))
  (do-test '(0.1 0.2 1.3 0.4) '(0.1 0.2 1.0 0.4))
  (do-test '(0.1 0.2 0.3 1.4) '(0.1 0.2 0.3 1.0))

  (near? 12.345 (hsl-h (hsl-normalize! (hsl 362.345 0 0))))
  (near? 12.345 (hsl-h (hsl-normalize! (hsl -347.655 0 0)))))


(test-group "hsl-set!"
  (test-assert "sets every field"
    (let ((c (hsl 0.1 0.2 0.3 0.4)))
      (hsl-set! c 0.5 0.6 0.7 0.8)
      (hsl= c (hsl 0.5 0.6 0.7 0.8))))
  (test-assert "returns the modified color"
    (let* ((c1 (hsl 0.1 0.2 0.3 0.4))
           (c2 (hsl-set! c1 0.5 0.6 0.7 0.8)))
      (eq? c1 c2))))


(test-group "hsl->values"
  (let-values (((h s l a)
                (hsl->values (hsl 125 0.25 0.5 0.75))))
    (test (list 125.0 0.25 0.5 0.75)
          (list h s l a))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; HSL-ARRAY

(test-group "make-hsl-array"
  (test-assert (hsl-array? (make-hsl-array 1 1 16)))

  (test-assert "default pitch"
    (let ((a (make-hsl-array 3 5)))
      (and
       (= 3 (hsl-array-width a))
       (= 5 (hsl-array-height a))
       (= (* 3 16) (hsl-array-pitch a))
       (= (* 3 16 5)
          (blob-size (locative->object (hsl-array-pointer a)))))))

  (test-assert "specified pitch"
    (let ((a (make-hsl-array 3 5 63)))
      (and
       (= 3 (hsl-array-width a))
       (= 5 (hsl-array-height a))
       (= 63 (hsl-array-pitch a))
       (= (* 63 5)
          (blob-size (locative->object (hsl-array-pointer a)))))))

  (test-error "zero width" (make-hsl-array 0 1))
  (test-error "negative width" (make-hsl-array -1 1))
  (test-error "noninteger width" (make-hsl-array 1.1 1))

  (test-error "zero height" (make-hsl-array 1 0))
  (test-error "negative height" (make-hsl-array 1 -1))
  (test-error "noninteger height" (make-hsl-array 1 1.1))

  (test-error "too small pitch" (make-hsl-array 3 5 11))
  (test-error "noninteger pitch" (make-hsl-array 1 1 4.1)))


(test-group "hsl-array-at"
  (test-assert
      (hsl-array?
       (hsl-array-at (make-locative (make-blob 16))
                     1 1)))

  (test-error "with non-pointerlike"
    (hsl-array-at (make-blob 16) 1 1))

  (define (do-test ptr)
    (test-assert "default pitch"
      (let ((a (hsl-array-at ptr 3 5)))
        (and
         (= 3 (hsl-array-width a))
         (= 5 (hsl-array-height a))
         (= (* 3 16) (hsl-array-pitch a))
         (eq? ptr (hsl-array-pointer a)))))

    (test-assert "specified pitch"
      (let ((a (hsl-array-at ptr 3 5 64)))
        (and
         (= 3 (hsl-array-width a))
         (= 5 (hsl-array-height a))
         (= 64 (hsl-array-pitch a))
         (eq? ptr (hsl-array-pointer a)))))

    (test-error "zero width" (hsl-array-at ptr 0 1))
    (test-error "negative width" (hsl-array-at ptr -1 1))
    (test-error "noninteger width" (hsl-array-at ptr 1.1 1))

    (test-error "zero height" (hsl-array-at ptr 1 0))
    (test-error "negative height" (hsl-array-at ptr 1 -1))
    (test-error "noninteger height" (hsl-array-at ptr 1 1.1))

    (test-error "too small pitch" (hsl-array-at ptr 3 5 11))
    (test-error "noninteger pitch" (hsl-array-at ptr 1 1 4.1)))

  (test-group "with locative"
    (do-test (make-locative (make-blob (* 12 5)))))

  (test-group "with pointer"
    (let ((mem (allocate (* 12 5))))
      (do-test mem)
      (free mem))))


(test-group "hsl-array-parent"
  (let ((a (make-hsl-array 1 1)))
    (test #f (hsl-array-parent a))
    (set! (hsl-array-parent a) 'parent)
    (test 'parent (hsl-array-parent a)))

  (let ((a (hsl-array-at (make-locative (make-blob 16)) 1 1)))
    (test #f (hsl-array-parent a))
    (set! (hsl-array-parent a) 'parent)
    (test 'parent (hsl-array-parent a))))


(test-group "hsl-array-ref"
  (test-group "with locative"
    (define data (f32vector 01 02 03 04 05 06 07 08 09 10
                            11 12 13 14 15 16 17 18 19 20))
    (define a (hsl-array-at (make-locative data) 2 2 40))

    (test-assert (hsl= (hsl 01 02 03 04) (hsl-array-ref a 0 0)))
    (test-assert (hsl= (hsl 05 06 07 08) (hsl-array-ref a 1 0)))
    (test-assert (hsl= (hsl 11 12 13 14) (hsl-array-ref a 0 1)))
    (test-assert (hsl= (hsl 15 16 17 18) (hsl-array-ref a 1 1)))

    (test a (hsl-parent (hsl-array-ref a 0 0)))

    (hsl-set! (hsl-array-ref a 1 0) 71 72 73 74)
    (hsl-set! (hsl-array-ref a 0 1) 91 92 93 94)
    (test "modifying color affects underlying memory"
          data
          (f32vector 01 02 03 04 71 72 73 74 09 10
                     91 92 93 94 15 16 17 18 19 20)))

  (test-group "with pointer"
    (define data
      (let ((data (allocate 80)))
        (for-each (lambda (i)
                    (pointer-f32-set! (pointer+ data (* i 4)) (+ i 1.0)))
                  (iota 20))
        data))
    (define a (hsl-array-at data 2 2 40))

    (test-assert (hsl= (hsl 01 02 03 04) (hsl-array-ref a 0 0)))
    (test-assert (hsl= (hsl 05 06 07 08) (hsl-array-ref a 1 0)))
    (test-assert (hsl= (hsl 11 12 13 14) (hsl-array-ref a 0 1)))
    (test-assert (hsl= (hsl 15 16 17 18) (hsl-array-ref a 1 1)))

    (test a (hsl-parent (hsl-array-ref a 0 0)))

    (hsl-set! (hsl-array-ref a 1 0) 71 72 73 74)
    (hsl-set! (hsl-array-ref a 0 1) 91 92 93 94)
    (test "modifying color affects underlying memory"
          (map exact->inexact
               (list 01 02 03 04 71 72 73 74 09 10
                     91 92 93 94 15 16 17 18 19 20))
          (map (lambda (i) (pointer-f32-ref (pointer+ data (* i 4))))
               (iota 20)))

    (free data)))


(test-group "hsl-array-ref-pointer"
  (test-group "with locative"
    (define data (f32vector 01 02 03 04 05 06 07 08 09 10
                            11 12 13 14 15 16 17 18 19 20))
    (define a (hsl-array-at (make-locative data) 2 2 40))

    (test (locative->object (make-locative data (+ 40 16)))
          (locative->object (hsl-array-ref-pointer a 1 1)))

    (test-assert (hsl= (hsl 01 02 03 04)
                       (hsl-at (hsl-array-ref-pointer a 0 0))))
    (test-assert (hsl= (hsl 05 06 07 08)
                       (hsl-at (hsl-array-ref-pointer a 1 0))))
    (test-assert (hsl= (hsl 11 12 13 14)
                       (hsl-at (hsl-array-ref-pointer a 0 1))))
    (test-assert (hsl= (hsl 15 16 17 18)
                       (hsl-at (hsl-array-ref-pointer a 1 1))))

    (hsl-set! (hsl-at (hsl-array-ref-pointer a 1 0)) 71 72 73 74)
    (hsl-set! (hsl-at (hsl-array-ref-pointer a 0 1)) 91 92 93 94)
    (test "modifying color affects underlying memory"
          data
          (f32vector 01 02 03 04 71 72 73 74 09 10
                     91 92 93 94 15 16 17 18 19 20)))

  (test-group "with pointer"
    (define data
      (let ((data (allocate 80)))
        (for-each (lambda (i)
                    (pointer-f32-set! (pointer+ data (* i 4)) (+ i 1.0)))
                  (iota 20))
        data))
    (define a (hsl-array-at data 2 2 40))

    (test (pointer+ data (+ 40 16))
          (hsl-array-ref-pointer a 1 1))

    (test-assert (hsl= (hsl 01 02 03 04)
                       (hsl-at (hsl-array-ref-pointer a 0 0))))
    (test-assert (hsl= (hsl 05 06 07 08)
                       (hsl-at (hsl-array-ref-pointer a 1 0))))
    (test-assert (hsl= (hsl 11 12 13 14)
                       (hsl-at (hsl-array-ref-pointer a 0 1))))
    (test-assert (hsl= (hsl 15 16 17 18)
                       (hsl-at (hsl-array-ref-pointer a 1 1))))

    (hsl-set! (hsl-at (hsl-array-ref-pointer a 1 0)) 71 72 73 74)
    (hsl-set! (hsl-at (hsl-array-ref-pointer a 0 1)) 91 92 93 94)
    (test "modifying color affects underlying memory"
          (map exact->inexact
               (list 01 02 03 04 71 72 73 74 09 10
                     91 92 93 94 15 16 17 18 19 20))
          (map (lambda (i) (pointer-f32-ref (pointer+ data (* i 4))))
               (iota 20)))

    (free data)))


(test-group "hsl-array-for-each"
  (define data1 (make-f32vector (* 2 40)))
  (define data2 (make-f32vector (* 3 40)))
  (define a1 (hsl-array-at (make-locative data1) 2 2 40))
  (define a2 (hsl-array-at (make-locative data2) 2 3 40))

  (let ((result '()))
    (hsl-array-for-each
     (lambda args (set! result (cons args result)))
     a1 a2)

    (test "calls function with correct arguments in correct order"
          `((0 0 ,(hsl-array-ref a1 0 0) ,(hsl-array-ref a2 0 0))
            (1 0 ,(hsl-array-ref a1 1 0) ,(hsl-array-ref a2 1 0))
            (0 1 ,(hsl-array-ref a1 0 1) ,(hsl-array-ref a2 0 1))
            (1 1 ,(hsl-array-ref a1 1 1) ,(hsl-array-ref a2 1 1)))
          (reverse result))))


(test-group "hsl-array-for-each-pointer"
  (define data1 (make-f32vector (* 2 40)))
  (define data2 (make-f32vector (* 3 40)))
  (define a1 (hsl-array-at (make-locative data1) 2 2 40))
  (define a2 (hsl-array-at (make-locative data2) 2 3 40))

  (let ((result '()))
    (hsl-array-for-each-pointer
     (lambda args (set! result (cons args result)))
     a1 a2)

    (test "calls function with correct arguments in correct order"
          `((0 0
               ,(hsl-array-ref-pointer a1 0 0)
               ,(hsl-array-ref-pointer a2 0 0))
            (1 0
               ,(hsl-array-ref-pointer a1 1 0)
               ,(hsl-array-ref-pointer a2 1 0))
            (0 1
               ,(hsl-array-ref-pointer a1 0 1)
               ,(hsl-array-ref-pointer a2 0 1))
            (1 1
               ,(hsl-array-ref-pointer a1 1 1)
               ,(hsl-array-ref-pointer a2 1 1)))
          (reverse result))))