;;;
;;; macaw:
;;; Efficient color types and math for CHICKEN Scheme.
;;;
;;; Copyright © 2020  John Croisant.
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;;  * Redistributions of source code must retain the above copyright
;;;    notice, this list of conditions and the following disclaimer.
;;;
;;;  * 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.
;;;
;;; 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.


(export rgb rgb? rgb= rgb-set!
        rgb->values rgb->list
        rgb-copy rgb-copy!
        rgb-at rgb-pointer rgb-parent
        rgb-r rgb-r-set!
        rgb-g rgb-g-set!
        rgb-b rgb-b-set!
        rgb-a rgb-a-set!
        rgb-near?
        rgb-normalize rgb-normalize!

        rgb-array? make-rgb-array
        rgb-array-at rgb-array-pointer rgb-array-parent
        rgb-array-width rgb-array-height rgb-array-pitch
        rgb-array-ref rgb-array-ref-pointer
        rgb-array-for-each rgb-array-for-each-pointer)


(define-color-type macaw:rgb
  rgb rgb? rgb= rgb-set!
  rgb->values rgb->list
  rgb-copy rgb-copy!
  ((r 0 rgb-r rgb-r-set! number min: #f max: #f)
   (g 1 rgb-g rgb-g-set! number min: #f max: #f)
   (b 2 rgb-b rgb-b-set! number min: #f max: #f)
   (a 3 rgb-a rgb-a-set! number min: #f max: #f default: 1.0))
  memory: (rgb-at %rgb-at rgb-pointer rgb-parent
                  f32vector float
                  f32color-set! f32color->values))

(define-array-type macaw:rgb-array
  rgb-array rgb-array? make-rgb-array
  rgb-array-width rgb-array-height rgb-array-pitch
  rgb-array-ref rgb-array-ref-pointer
  rgb-array-for-each rgb-array-for-each-pointer
  color: (rgb rgb? rgb-at)
  memory: (rgb-array-at %rgb-array-at
                        rgb-array-pointer rgb-array-parent
                        bpp: 16))


(: rgb-near? (rgb rgb #!optional number --> boolean))
(define (rgb-near? c1 c2 #!optional (e 1e-5))
  (and (> e (abs (- (rgb-r c1) (rgb-r c2))))
       (> e (abs (- (rgb-g c1) (rgb-g c2))))
       (> e (abs (- (rgb-b c1) (rgb-b c2))))
       (> e (abs (- (rgb-a c1) (rgb-a c2))))))


(: rgb-normalize (rgb --> rgb))
(define (rgb-normalize c)
  (rgb-normalize! (rgb-copy c)))

(: rgb-normalize! (rgb -> rgb))
(define (rgb-normalize! c)
  (rgb-r-set! c (clamp (rgb-r c) 0.0 1.0))
  (rgb-g-set! c (clamp (rgb-g c) 0.0 1.0))
  (rgb-b-set! c (clamp (rgb-b c) 0.0 1.0))
  (rgb-a-set! c (clamp (rgb-a c) 0.0 1.0))
  c)


(define f32color-set!
  (foreign-primitive
   (((nonnull-c-pointer float) color)
    (float x)
    (float y)
    (float z)
    (float a))
   "color[0] = x;"
   "color[1] = y;"
   "color[2] = z;"
   "color[3] = a;"))

(define f32color->values
  (foreign-primitive
   (((const (nonnull-c-pointer float)) color))
   "C_word* ab = C_alloc(C_SIZEOF_FLONUM * 4), *a = ab;"
   "C_word av[2 + 4] = {"
   "   C_SCHEME_UNDEFINED, C_k,"
   "   C_flonum(&a, color[0]),"
   "   C_flonum(&a, color[1]),"
   "   C_flonum(&a, color[2]),"
   "   C_flonum(&a, color[3])"
   "};"
   "C_values(2 + 4, av);"))