(test-group "rgb constructor"
  (define (do-test r g b a)
    (let ((c (rgb r g b a))
          (v (f32vector r g b a)))
      (test-assert (sprintf "(rgb ~A ~A ~A ~A)" r g b a)
        (and (rgb? c)
             (= (rgb-r c) (f32vector-ref v 0))
             (= (rgb-g c) (f32vector-ref v 1))
             (= (rgb-b c) (f32vector-ref v 2))
             (= (rgb-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.0 1.0 1.0 1.0)
  (do-test 1 2 3 4)
  (do-test 1.0 2.0 3.0 4.0)
  (do-test 1234.5 2345.6 3456.7 4567.8)
  (do-test -1 -2 -3 -4)
  (do-test -1.0 -2.0 -3.0 -4.0)

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

  (test-error (rgb))
  (test-error (rgb 0.1))
  (test-error (rgb 0.1 0.2))
  (test 1.0 (rgb-a (rgb 0.1 0.2 0.3))))


(test-group "rgb setters"
  ;; Setters
  (let ((c (rgb 0.1 0.2 0.3 0.4)))
    (test c (rgb-r-set! c 0.5))
    (test-assert (rgb= (rgb 0.5 0.2 0.3 0.4) c))
    (test c (rgb-g-set! c 0.6))
    (test-assert (rgb= (rgb 0.5 0.6 0.3 0.4) c))
    (test c (rgb-b-set! c 0.7))
    (test-assert (rgb= (rgb 0.5 0.6 0.7 0.4) c))
    (test c (rgb-a-set! c 0.8))
    (test-assert (rgb= (rgb 0.5 0.6 0.7 0.8) c)))

  ;; set! with getters
  (let ((c (rgb 0.1 0.2 0.3 0.4)))
    (test c (set! (rgb-r c) 0.5))
    (test-assert (rgb= (rgb 0.5 0.2 0.3 0.4) c))
    (test c (set! (rgb-g c) 0.6))
    (test-assert (rgb= (rgb 0.5 0.6 0.3 0.4) c))
    (test c (set! (rgb-b c) 0.7))
    (test-assert (rgb= (rgb 0.5 0.6 0.7 0.4) c))
    (test c (set! (rgb-a c) 0.8))
    (test-assert (rgb= (rgb 0.5 0.6 0.7 0.8) c))))


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


(test-group "rgb="
  (test-assert (rgb= (rgb 1 2 3 4) (rgb 1 2 3 4)))
  (test-assert (not (rgb= (rgb 0 2 3 4) (rgb 1 2 3 4))))
  (test-assert (not (rgb= (rgb 1 0 3 4) (rgb 1 2 3 4))))
  (test-assert (not (rgb= (rgb 1 2 0 4) (rgb 1 2 3 4))))
  (test-assert (not (rgb= (rgb 1 2 3 0) (rgb 1 2 3 4))))

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

(test-group "rgb-near?"
  (define (do-test x y #!optional (e 1e-5))
    (test-assert (sprintf "~A ≅ ~A (± ~A)" x y e)
      (and (rgb-near? (rgb x 0 0 0) (rgb y 0 0 0) e)
           (rgb-near? (rgb 0 x 0 0) (rgb 0 y 0 0) e)
           (rgb-near? (rgb 0 0 x 0) (rgb 0 0 y 0) e)
           (rgb-near? (rgb 0 0 0 x) (rgb 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 (rgb-near? (rgb x 0 0 0) (rgb y 0 0 0) e))
           (not (rgb-near? (rgb 0 x 0 0) (rgb 0 y 0 0) e))
           (not (rgb-near? (rgb 0 0 x 0) (rgb 0 0 y 0) e))
           (not (rgb-near? (rgb 0 0 0 x) (rgb 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 (rgb-near? (rgb 1 2 3 4) #f32(1 2 3 4)))
  (test-error (rgb-near? #f32(1 2 3 4) (rgb 1 2 3 4)))
  (test-error (rgb-near? (rgb 1 2 3 4) (hsl 1 2 3 4)))
  (test-error (rgb-near? (hsl 1 2 3 4) (rgb 1 2 3 4)))
  (test-error (rgb-near? (rgb 1 2 3 4) (rgb8 1 2 3 4)))
  (test-error (rgb-near? (rgb8 1 2 3 4) (rgb 1 2 3 4))))


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

    ;; copy and orig do not share memory
    (rgb-r-set! copy 0.5)
    (rgb-g-set! copy 0.6)
    (rgb-b-set! copy 0.7)
    (rgb-a-set! copy 0.8)
    (test-assert (rgb= copy (rgb 0.5 0.6 0.7 0.8)))
    (test-assert (rgb= orig (rgb 0.1 0.2 0.3 0.4)))))


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

      ;; dst and result are the same object
      (test-assert (eq? dst result))
      (rgb-r-set! result 0.9)
      (rgb-g-set! result 0.8)
      (rgb-b-set! result 0.7)
      (rgb-a-set! result 0.6)
      (test-assert (rgb= dst (rgb 0.9 0.8 0.7 0.6)))

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


(test-group "rgb->list"
  (define (do-test r g b a)
    (test (sprintf "(rgb->list (rgb ~A ~A ~A ~A))" r g b a)
          (f32vector->list (f32vector r g b a))
          (rgb->list (rgb 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 "rgb-at / rgb-pointer / rgb-parent"
  (let ((blob (f32vector->blob #f32(0.1 0.2 0.3 0.4 0.5 0.6))))
    (test-assert (rgb= (rgb 0.1 0.2 0.3 0.4)
                       (rgb-at (make-locative blob))))
    (test-assert (rgb= (rgb 0.2 0.3 0.4 0.5)
                       (rgb-at (make-locative blob 4))))
    (test-assert (rgb= (rgb 0.3 0.4 0.5 0.6)
                       (rgb-at (make-locative blob 8)))))

  (let* ((ptr (allocate (* 6 4)))
         (c (rgb-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 (rgb-pointer c)))
    (test-assert (rgb= c (rgb 0.1 0.2 0.3 0.4)))
    (set! (rgb-pointer c) (pointer+ ptr 4))
    (test-assert (rgb= c (rgb 0.2 0.3 0.4 0.5)))
    (set! (rgb-pointer c) (pointer+ ptr 8))
    (test-assert (rgb= c (rgb 0.3 0.4 0.5 0.6)))

    (free ptr))

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

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


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

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

  (do-test '(-0.1 0.2 0.3 0.4) '(0.0 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 '(1.1 0.2 0.3 0.4) '(1.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)))


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

  (test-assert "modifies and returns color"
    (let* ((c (rgb -0.1 0.1 0.9 1.1))
           (result (rgb-normalize! c)))
      (and (eq? c result)
           (rgb= c (rgb 0.0 0.1 0.9 1.0)))))

  (do-test '(-0.1 0.2 0.3 0.4) '(0.0 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 '(1.1 0.2 0.3 0.4) '(1.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)))


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


(test-group "rgb->values"
  (let-values (((r g b a)
                (rgb->values (rgb 0.25 0.5 0.75 1.25))))
    (test (list 0.25 0.5 0.75 1.25)
          (list r g b a))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; RGB-ARRAY

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

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

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

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

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

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


(test-group "rgb-array-at / rgb-array-pointer"
  (test-assert
      (rgb-array?
       (rgb-array-at (make-locative (make-blob 16)) 1 1)))

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

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

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

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

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

    (test-error "too small pitch" (rgb-array-at ptr 3 5 11))
    (test-error "noninteger pitch" (rgb-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 "rgb-array-parent"
  (let ((a (make-rgb-array 1 1)))
    (test #f (rgb-array-parent a))
    (set! (rgb-array-parent a) 'parent)
    (test 'parent (rgb-array-parent a)))

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


(test-group "rgb-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 (rgb-array-at (make-locative data) 2 2 40))

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

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

    (rgb-set! (rgb-array-ref a 1 0) 71 72 73 74)
    (rgb-set! (rgb-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 (rgb-array-at data 2 2 40))

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

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

    (rgb-set! (rgb-array-ref a 1 0) 71 72 73 74)
    (rgb-set! (rgb-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 "rgb-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 (rgb-array-at (make-locative data) 2 2 40))

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

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

    (rgb-set! (rgb-at (rgb-array-ref-pointer a 1 0)) 71 72 73 74)
    (rgb-set! (rgb-at (rgb-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 (rgb-array-at data 2 2 40))

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

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

    (rgb-set! (rgb-at (rgb-array-ref-pointer a 1 0)) 71 72 73 74)
    (rgb-set! (rgb-at (rgb-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 "rgb-array-for-each"
  (define data1 (make-f32vector (* 2 40)))
  (define data2 (make-f32vector (* 3 40)))
  (define a1 (rgb-array-at (make-locative data1) 2 2 40))
  (define a2 (rgb-array-at (make-locative data2) 2 3 40))

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

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


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

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

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