;;;
;;; 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 gamma-compress gamma-expand
        rgb->rgb8 low-rgb->rgb8!
        rgb8->rgb low-rgb8->rgb!
        rgb->hsl low-rgb->hsl!
        hsl->rgb low-hsl->rgb!
        rgb8->hsl low-rgb8->hsl!
        hsl->rgb8 low-hsl->rgb8!
        color->rgb color->rgb/new
        color->rgb8 color->rgb8/new
        color->hsl color->hsl/new)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GAMMA COMPRESSION (sRGB TRANSFER FUNCTION)

(: gamma-compress (number --> float))
(define gamma-compress
  (foreign-lambda
   float "macaw_gamma_compress" float))

(: gamma-expand (number --> float))
(define gamma-expand
  (foreign-lambda
   float "macaw_gamma_expand" float))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; RGB <--> RGB8

(define low-rgb->rgb8!
  (foreign-lambda
   void "macaw_rgb_to_rgb8"
   (c-pointer float)
   (c-pointer unsigned-byte)))

(define low-rgb8->rgb!
  (foreign-lambda
   void "macaw_rgb8_to_rgb"
   (c-pointer unsigned-byte)
   (c-pointer float)))

(: rgb->rgb8 (rgb --> rgb8))
(define (rgb->rgb8 c)
  (let ((out (rgb8 0 0 0 0)))
    (low-rgb->rgb8! (rgb-pointer c) (rgb8-pointer out))
    out))

(: rgb8->rgb (rgb8 --> rgb))
(define (rgb8->rgb c)
  (let ((out (rgb 0.0 0.0 0.0 0.0)))
    (low-rgb8->rgb! (rgb8-pointer c) (rgb-pointer out))
    out))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; RGB <--> HSL

(define low-rgb->hsl!
  (foreign-lambda
   void "macaw_rgb_to_hsl"
   (c-pointer float)
   (c-pointer float)))

(define low-hsl->rgb!
  (foreign-lambda
   void "macaw_hsl_to_rgb"
   (c-pointer float)
   (c-pointer float)))

(: rgb->hsl (rgb --> hsl))
(define (rgb->hsl c)
  (let ((out (hsl 0.0 0.0 0.0 0.0)))
    (low-rgb->hsl! (rgb-pointer c) (hsl-pointer out))
    out))

(: hsl->rgb (hsl --> rgb))
(define (hsl->rgb c)
  (let ((out (rgb 0.0 0.0 0.0 0.0)))
    (low-hsl->rgb! (hsl-pointer c) (rgb-pointer out))
    out))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; RGB8 <--> HSL

(define low-rgb8->hsl!
  (foreign-lambda
   void "macaw_rgb8_to_hsl"
   (c-pointer unsigned-byte)
   (c-pointer float)))

(define low-hsl->rgb8!
  (foreign-lambda
   void "macaw_hsl_to_rgb8"
   (c-pointer float)
   (c-pointer unsigned-byte)))

(: rgb8->hsl (rgb8 --> hsl))
(define (rgb8->hsl c)
  (let ((out (hsl 0.0 0.0 0.0 0.0)))
    (low-rgb8->hsl! (rgb8-pointer c) (hsl-pointer out))
    out))

(: hsl->rgb8 (hsl --> rgb8))
(define (hsl->rgb8 c)
  (let ((out (rgb8 0 0 0 0)))
    (low-hsl->rgb8! (hsl-pointer c) (rgb8-pointer out))
    out))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GENERIC CONVERSION

(: color->rgb (color --> rgb))
(define-struct-dispatch (color->rgb c)
  ((macaw:rgb macaw#macaw:rgb) identity)
  ((macaw:rgb8 macaw#macaw:rgb8) rgb8->rgb)
  ((macaw:hsl macaw#macaw:hsl) hsl->rgb)
  (else (error "invalid color" c)))

(: color->rgb/new (color --> rgb))
(define (color->rgb/new c)
  (if (rgb? c) (rgb-copy c) (color->rgb c)))


(: color->rgb8 (color --> rgb8))
(define-struct-dispatch (color->rgb8 c)
  ((macaw:rgb8 macaw#macaw:rgb8) identity)
  ((macaw:rgb macaw#macaw:rgb) rgb->rgb8)
  ((macaw:hsl macaw#macaw:hsl) hsl->rgb8)
  (else (error "invalid color" c)))

(: color->rgb8/new (color --> rgb8))
(define (color->rgb8/new c)
  (if (rgb8? c) (rgb8-copy c) (color->rgb8 c)))


(: color->hsl (color --> hsl))
(define-struct-dispatch (color->hsl c)
  ((macaw:hsl macaw#macaw:hsl) identity)
  ((macaw:rgb macaw#macaw:rgb) rgb->hsl)
  ((macaw:rgb8 macaw#macaw:rgb8) rgb8->hsl)
  (else (error "invalid color" c)))

(: color->hsl/new (color --> hsl))
(define (color->hsl/new c)
  (if (hsl? c) (hsl-copy c) (color->hsl c)))