;;;
;;; 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 hsl hsl? hsl= hsl-set!
        hsl->values hsl->list
        hsl-copy hsl-copy!
        hsl-at hsl-pointer hsl-parent
        hsl-h hsl-h-set!
        hsl-s hsl-s-set!
        hsl-l hsl-l-set!
        hsl-a hsl-a-set!
        hsl-near?
        hsl-normalize hsl-normalize!

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


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

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


(: hsl-near? (hsl hsl #!optional number --> boolean))
(define (hsl-near? c1 c2 #!optional (e 1e-5))
  (and (> e (abs (- (hsl-h c1) (hsl-h c2))))
       (> e (abs (- (hsl-s c1) (hsl-s c2))))
       (> e (abs (- (hsl-l c1) (hsl-l c2))))
       (> e (abs (- (hsl-a c1) (hsl-a c2))))))


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

(: hsl-normalize! (hsl -> hsl))
(define (hsl-normalize! c)
  (hsl-h-set! c (wrap (hsl-h c) 360.0))
  (hsl-s-set! c (clamp (hsl-s c) 0.0 1.0))
  (hsl-l-set! c (clamp (hsl-l c) 0.0 1.0))
  (hsl-a-set! c (clamp (hsl-a c) 0.0 1.0))
  c)