;;;
;;; 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-add hsl-add! low-hsl-add!
        rgb-add rgb-add! low-rgb-add!
        rgb8-add rgb8-add! low-rgb8-add!
        hsl-sub hsl-sub! low-hsl-sub!
        rgb-sub rgb-sub! low-rgb-sub!
        rgb8-sub rgb8-sub! low-rgb8-sub!
        hsl-mul hsl-mul! low-hsl-mul!
        rgb-mul rgb-mul! low-rgb-mul!
        rgb8-mul rgb8-mul! low-rgb8-mul!
        hsl-scale hsl-scale! low-hsl-scale!
        rgb-scale rgb-scale! low-rgb-scale!
        rgb8-scale rgb8-scale! low-rgb8-scale!
        hsl-lerp hsl-lerp! low-hsl-lerp!
        rgb-lerp rgb-lerp! low-rgb-lerp!
        rgb8-lerp rgb8-lerp! low-rgb8-lerp!
        hsl-mix hsl-mix! low-hsl-mix!
        rgb-mix rgb-mix! low-rgb-mix!
        rgb8-mix rgb8-mix! low-rgb8-mix!
        hsl-over hsl-over! low-hsl-over!
        rgb-over rgb-over! low-rgb-over!
        rgb8-over rgb8-over! low-rgb8-over!
        hsl-under hsl-under! low-hsl-under!
        rgb-under rgb-under! low-rgb-under!
        rgb8-under rgb8-under! low-rgb8-under!
        )


(define-syntax define-variadic-ops
  (syntax-rules (using:)
    ((define-variadic-ops OP OP!
       using: (LOW-OP! TYPE COLOR->TYPE COLOR->TYPE/NEW TYPE-POINTER))
     (begin
       (: OP (color #!rest color --> TYPE))
       (define (OP c1 . cs)
         (apply OP! (COLOR->TYPE/NEW c1) cs))

       (: OP! (TYPE #!rest color -> TYPE))
       (define (OP! c1 . cs)
         (let ((c1-ptr (TYPE-POINTER c1)))
           (let loop ((colors cs))
             (if (null? colors)
                 c1
                 (let ((c (COLOR->TYPE (car colors))))
                   (LOW-OP! c1-ptr (TYPE-POINTER c) c1-ptr)
                   (loop (cdr colors)))))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ADDITION

(define low-rgb-add!
  (foreign-lambda
   void "macaw_add_f32color"
   (c-pointer float)
   (c-pointer float)
   (c-pointer float)))

(define low-rgb8-add!
  (foreign-lambda
   void "macaw_add_u8color"
   (c-pointer unsigned-byte)
   (c-pointer unsigned-byte)
   (c-pointer unsigned-byte)))

(define low-hsl-add! low-rgb-add!)


(define-variadic-ops hsl-add hsl-add!
  using: (low-hsl-add! hsl color->hsl color->hsl/new hsl-pointer))

(define-variadic-ops rgb-add rgb-add!
  using: (low-rgb-add! rgb color->rgb color->rgb/new rgb-pointer))

(define-variadic-ops rgb8-add rgb8-add!
  using: (low-rgb8-add! rgb8 color->rgb8 color->rgb8/new rgb8-pointer))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SUBTRACTION

(define low-rgb-sub!
  (foreign-lambda
   void "macaw_sub_f32color"
   (c-pointer float)
   (c-pointer float)
   (c-pointer float)))

(define low-rgb8-sub!
  (foreign-lambda
   void "macaw_sub_u8color"
   (c-pointer unsigned-byte)
   (c-pointer unsigned-byte)
   (c-pointer unsigned-byte)))

(define low-hsl-sub! low-rgb-sub!)

(define-variadic-ops hsl-sub hsl-sub!
  using: (low-hsl-sub! hsl color->hsl color->hsl/new hsl-pointer))

(define-variadic-ops rgb-sub rgb-sub!
  using: (low-rgb-sub! rgb color->rgb color->rgb/new rgb-pointer))

(define-variadic-ops rgb8-sub rgb8-sub!
  using: (low-rgb8-sub! rgb8 color->rgb8 color->rgb8/new rgb8-pointer))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MULTIPLICATION

(define low-rgb-mul!
  (foreign-lambda
   void "macaw_mul_f32color"
   (c-pointer float)
   (c-pointer float)
   (c-pointer float)))

(define low-rgb8-mul!
  (foreign-lambda
   void "macaw_mul_u8color"
   (c-pointer unsigned-byte)
   (c-pointer unsigned-byte)
   (c-pointer unsigned-byte)))

(define low-hsl-mul! low-rgb-mul!)

(define-variadic-ops hsl-mul hsl-mul!
  using: (low-hsl-mul! hsl color->hsl color->hsl/new hsl-pointer))

(define-variadic-ops rgb-mul rgb-mul!
  using: (low-rgb-mul! rgb color->rgb color->rgb/new rgb-pointer))

(define-variadic-ops rgb8-mul rgb8-mul!
  using: (low-rgb8-mul! rgb8 color->rgb8 color->rgb8/new rgb8-pointer))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SCALE

(define low-rgb-scale!
  (foreign-lambda
   void "macaw_scale_f32color"
   (c-pointer float)
   float
   (c-pointer float)))

(define low-rgb8-scale!
  (foreign-lambda
   void "macaw_scale_u8color"
   (c-pointer unsigned-byte)
   float
   (c-pointer unsigned-byte)))

(define low-hsl-scale! low-rgb-scale!)


(: hsl-scale (hsl number -> hsl))
(define (hsl-scale c n)
  (hsl-scale! (hsl-copy c) n))

(: hsl-scale! (hsl number -> hsl))
(define (hsl-scale! c n)
  (low-rgb-scale! (hsl-pointer c) n (hsl-pointer c))
  c)


(: rgb-scale (rgb float -> rgb))
(define (rgb-scale c n)
  (rgb-scale! (rgb-copy c) n))

(: rgb-scale! (rgb float -> rgb))
(define (rgb-scale! c n)
  (low-rgb-scale! (rgb-pointer c) n (rgb-pointer c))
  c)


(: rgb8-scale (rgb8 float -> rgb8))
(define (rgb8-scale c n)
  (rgb8-scale! (rgb8-copy c) n))

(: rgb8-scale! (rgb8 float -> rgb8))
(define (rgb8-scale! c n)
  (low-rgb8-scale! (rgb8-pointer c) n (rgb8-pointer c))
  c)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; LINEAR INTERPOLATION

(define low-rgb-lerp!
  (foreign-lambda
   void "macaw_lerp_f32color"
   (c-pointer float)
   (c-pointer float)
   float
   (c-pointer float)))

(define low-rgb8-lerp!
  (foreign-lambda
   void "macaw_lerp_u8color"
   (c-pointer unsigned-byte)
   (c-pointer unsigned-byte)
   float
   (c-pointer unsigned-byte)))

(define low-hsl-lerp! low-rgb-lerp!)


(: hsl-lerp (hsl hsl number --> hsl))
(define (hsl-lerp c1 c2 t)
  (hsl-lerp! (hsl-copy c1) c2 t))

(: hsl-lerp! (hsl hsl number -> hsl))
(define (hsl-lerp! c1 c2 t)
  (low-rgb-lerp! (hsl-pointer c1) (hsl-pointer c2) t (hsl-pointer c1))
  c1)


(: rgb-lerp (rgb rgb number --> rgb))
(define (rgb-lerp c1 c2 t)
  (rgb-lerp! (rgb-copy c1) c2 t))

(: rgb-lerp! (rgb rgb number -> rgb))
(define (rgb-lerp! c1 c2 t)
  (low-rgb-lerp! (rgb-pointer c1) (rgb-pointer c2) t (rgb-pointer c1))
  c1)


(: rgb8-lerp (rgb8 rgb8 number --> rgb8))
(define (rgb8-lerp c1 c2 t)
  (rgb8-lerp! (rgb8-copy c1) c2 t))

(: rgb8-lerp! (rgb8 rgb8 number -> rgb8))
(define (rgb8-lerp! c1 c2 t)
  (low-rgb8-lerp! (rgb8-pointer c1) (rgb8-pointer c2) t (rgb8-pointer c1))
  c1)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; MIX

(define low-rgb-mix!
  (foreign-lambda
   void "macaw_mix_f32color"
   (c-pointer float)                    ; accum
   (c-pointer float)                    ; color
   float                                ; weight
   (c-pointer float)))                  ; out

(define low-rgb8-mix!
  (foreign-lambda
   void "macaw_mix_u8color"
   (c-pointer unsigned-byte)            ; accum
   (c-pointer unsigned-byte)            ; color
   float                                ; weight
   (c-pointer unsigned-byte)))          ; out

(define low-hsl-mix! low-rgb-mix!)


(: hsl-mix ((list-of color) #!optional (list-of number) --> hsl))
(define (hsl-mix colors #!optional weights)
  (assert (not (null? colors))
          "empty color list")
  (if weights
      (assert (= (length colors) (length weights))
              "different length of color list than weight list"
              colors weights))
  (let* ((out (hsl 0 0 0 0))
         (out-ptr (hsl-pointer out))
         (weights (or weights
                      (let ((n (/ 1.0 (length colors))))
                        (map (lambda (_) n) colors)))))
    (let loop ((colors colors)
               (weights weights))
      (if (or (null? colors) (null? weights))
          out
          (let ((c (color->hsl (car colors)))
                (w (exact->inexact (car weights))))
            (low-hsl-mix! out-ptr (hsl-pointer c) w out-ptr)
            (loop (cdr colors) (cdr weights)))))))

(: hsl-mix! ((pair hsl (list-of color)) #!optional (list-of number) -> hsl))
(define (hsl-mix! colors #!optional weights)
  (assert (hsl? (car colors)) "first color is not hsl" colors)
  (hsl-copy! (hsl-mix colors weights) (car colors)))


(: rgb-mix ((list-of color) #!optional (list-of number) --> rgb))
(define (rgb-mix colors #!optional weights)
  (assert (not (null? colors))
          "empty color list")
  (if weights
      (assert (= (length colors) (length weights))
              "different length of color list than weight list"
              colors weights))
  (let* ((out (rgb 0 0 0 0))
         (out-ptr (rgb-pointer out))
         (weights (or weights
                      (let ((n (/ 1.0 (length colors))))
                        (map (lambda (_) n) colors)))))
    (let loop ((colors colors)
               (weights weights))
      (if (or (null? colors) (null? weights))
          out
          (let ((c (color->rgb (car colors)))
                (w (exact->inexact (car weights))))
            (low-rgb-mix! out-ptr (rgb-pointer c) w out-ptr)
            (loop (cdr colors) (cdr weights)))))))

(: rgb-mix! ((pair rgb (list-of color)) #!optional (list-of number) -> rgb))
(define (rgb-mix! colors #!optional weights)
  (assert (rgb? (car colors)) "first color is not rgb" colors)
  (rgb-copy! (rgb-mix colors weights) (car colors)))


(: rgb8-mix ((list-of color) #!optional (list-of number) --> rgb8))
(define (rgb8-mix colors #!optional weights)
  (assert (not (null? colors))
          "empty color list")
  (if weights
      (assert (= (length colors) (length weights))
              "different length of color list than weight list"
              colors weights))
  (let* ((out (rgb8 0 0 0 0))
         (out-ptr (rgb8-pointer out))
         (weights (or weights
                      (let ((n (/ 1.0 (length colors))))
                        (map (lambda (_) n) colors)))))
    (let loop ((colors colors)
               (weights weights))
      (if (or (null? colors) (null? weights))
          out
          (let ((c (color->rgb8 (car colors)))
                (w (exact->inexact (car weights))))
            (low-rgb8-mix! out-ptr (rgb8-pointer c) w out-ptr)
            (loop (cdr colors) (cdr weights)))))))

(: rgb8-mix! ((pair rgb8 (list-of color)) #!optional (list-of number) -> rgb8))
(define (rgb8-mix! colors #!optional weights)
  (assert (rgb8? (car colors)) "first color is not rgb8" colors)
  (rgb8-copy! (rgb8-mix colors weights) (car colors)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; OVER / UNDER

(define low-rgb-over!
  (foreign-lambda
   void "macaw_over_f32color"
   (c-pointer float)
   (c-pointer float)
   (c-pointer float)))

(define low-rgb8-over!
  (foreign-lambda
   void "macaw_over_u8color"
   (c-pointer unsigned-byte)
   (c-pointer unsigned-byte)
   (c-pointer unsigned-byte)))

(define low-hsl-over! low-rgb-over!)

(define (low-rgb-under! in1 in2 out)
  (low-rgb-over! in2 in1 out))

(define (low-rgb8-under! in1 in2 out)
  (low-rgb8-over! in2 in1 out))

(define (low-hsl-under! in1 in2 out)
  (low-hsl-over! in2 in1 out))


(define-variadic-ops hsl-over hsl-over!
  using: (low-hsl-over! hsl color->hsl color->hsl/new hsl-pointer))

(define-variadic-ops rgb-over rgb-over!
  using: (low-rgb-over! rgb color->rgb color->rgb/new rgb-pointer))

(define-variadic-ops rgb8-over rgb8-over!
  using: (low-rgb8-over! rgb8 color->rgb8 color->rgb8/new rgb8-pointer))


(define-variadic-ops hsl-under hsl-under!
  using: (low-hsl-under! hsl color->hsl color->hsl/new hsl-pointer))

(define-variadic-ops rgb-under rgb-under!
  using: (low-rgb-under! rgb color->rgb color->rgb/new rgb-pointer))

(define-variadic-ops rgb8-under rgb8-under!
  using: (low-rgb8-under! rgb8 color->rgb8 color->rgb8/new rgb8-pointer))