#lang racket/base

(require racket/generic
         racket/math
         racket/list
         (prefix-in draw: racket/draw)
         racket/class)

; Color module
; For use in vector or bitmap graphics.
(provide
  ; Color is a generic
  color? css-value draw-value
  ;
  named-color no-color transparent-color
  rgb-color rgba-color
  hsl-color hsla-color
  ; computed colors
  hsv-color hsva-color
  xyz-color xyza-color
  lab-color laba-color
  luv-color luva-color
  lch-ab-color lcha-ab-color
  lch-uv-color lcha-uv-color
)

; Return val if it is inside the interval [mn:mx], or one of the borders of the interval
(define (clamp val mn mx)
  (min mx (max mn val)))

; Generic
; A color must defines
; - a css-value method: this method returns a string representing the color in css
; - a draw-value method: this method returns a racket/draw color
(define-generics color
  (css-value color)
  (draw-value color))

; Named color - the name given is the one that should be displayed in css value
(struct named-color (name)
  #:methods gen:color
  ( (define (css-value color)
      (named-color-name color))
    (define (draw-value color)
      (send draw:the-color-database find-color (named-color-name color)))
   ))

; None color - a special case of named color
(struct none-color (name)
  #:methods gen:color
  ( (define (css-value color)
      (none-color-name color))
    (define (draw-value color)
      (draw:make-color 0 0 0 0.0))
   ))

; The no-color is a case of none-color
(define (no-color)
  (none-color "none"))

; the transparent color is a case of none-color
(define (transparent-color)
  (none-color "transparent"))

; RGB color
(struct rgb-color (red green blue) ; red: 0-255, green: 0-255, blue: 0-255
  #:methods gen:color
  ( (define (css-value color)
      (string-append
        "rgb("
        (number->string (rgb-color-red color)) ","
        (number->string (rgb-color-green color)) ","
        (number->string (rgb-color-blue color)) ")"))
    (define (draw-value color)
      (draw:make-color
        (rgb-color-red color)
        (rgb-color-green color)
        (rgb-color-blue color)))
   ))

; RGBA color
(struct rgba-color rgb-color (alpha) ; alpha: 0.0-1.0
  #:methods gen:color
  ( (define (css-value color)
      (string-append
        "rgba("
        (number->string (rgb-color-red color)) ","
        (number->string (rgb-color-green color)) ","
        (number->string (rgb-color-blue color)) ","
        (number->string (rgba-color-alpha color)) ")"))
    (define (draw-value color)
      (draw:make-color
        (rgb-color-red color)
        (rgb-color-green color)
        (rgb-color-blue color)
        (rgba-color-alpha color)))
   ))

;; HSL
; Conversion to RGB is needed only for draw-value, as css can represent HSL directly
(define (hsl->rgb h s l)
  (define sr (/ s 100))
  (define lr (/ l 100))
  ; Modulo, but n can be any positive number
  (define (rmod n k)
    (define m (floor (/ n k)))
    (- n (* m k)))
  ; Computation function
  (define (col n)
    (define k (rmod (+ n (/ h 30)) 12))
    (define a (* sr (min lr (- 1 lr))))
    (- lr (* a (max -1 (min (- k 3) (- 9 k) 1)))))
  (list
    (clamp (inexact->exact (floor (* 255 (col 0)))) 0 255)
    (clamp (inexact->exact (floor (* 255 (col 8)))) 0 255)
    (clamp (inexact->exact (floor (* 255 (col 4)))) 0 255)))

; HSL color
(struct hsl-color (hue saturation luminosity) ; hue: 0-360, saturation: 0-100, luminosity: 0-100
  #:methods gen:color
  ( (define (css-value color)
      (string-append
        "hsl("
        (number->string (hsl-color-hue color)) ","
        (number->string (hsl-color-saturation color)) "%,"
        (number->string (hsl-color-luminosity color)) "%)"))
    (define (draw-value color)
      (define rgb (hsl->rgb
                    (hsl-color-hue color)
                    (hsl-color-saturation color)
                    (hsl-color-luminosity color)))
      (draw:make-color
        (first rgb)
        (second rgb)
        (third rgb)))
    ))

; HSLA color
(struct hsla-color hsl-color (alpha) ; alpha: 0.0-1.0
  #:methods gen:color
  ( (define (css-value color)
      (string-append
        "hsla("
        (number->string (hsl-color-hue color)) ","
        (number->string (hsl-color-saturation color)) "%,"
        (number->string (hsl-color-luminosity color)) "%,"
        (number->string (hsla-color-alpha color)) ")"))
    (define (draw-value color)
      (define rgb (hsl->rgb
                    (hsl-color-hue color)
                    (hsl-color-saturation color)
                    (hsl-color-luminosity color)))
      (draw:make-color
        (first rgb)
        (second rgb)
        (third rgb)
        (hsla-color-alpha color)))
    ))


;; HSV, XYZ, La*b*, Lu*v*, LCHa*b* & LCHu*v* color spaces
; The colors are RGB colors but defined from other color spaces

; HSV color
(define (hsv-color h s v)
  (let ((rgb
          (if (zero? s)
              (list (/ v 100) (/ v 100) (/ v 100))
              (let* ((hr (/ h 360))
                     (vr (/ v 100))
                     (sr (/ s 100))
                     (hr6 (* hr 6))
                     (vH (if (>= hr6 6) 0 hr6))
                     (vI (inexact->exact (floor vH)))
                     (v1 (* vr (- 1 sr)))
                     (v2 (* vr (- 1 (* sr (- vH vI)))))
                     (v3 (* vr (- 1 (* sr (- 1 (+ vH vI)))))))
                (cond
                  ((eq? vI 0)
                   (list vr v3 v1))
                  ((eq? vI 1)
                   (list v2 vr v1))
                  ((eq? vI 2)
                   (list v1 vr v3))
                  ((eq? vI 3)
                   (list v1 v2 vr))
                  ((eq? vI 4)
                   (list v3 v1 vr))
                  (#t
                   (list vr v1 v2)))))))
    (rgb-color
      (clamp (inexact->exact (floor (* 255 (first rgb)))) 0 255)
      (clamp (inexact->exact (floor (* 255 (second rgb)))) 0 255)
      (clamp (inexact->exact (floor (* 255 (third rgb)))) 0 255))))

; HSVA color
(define (hsva-color h s v a)
  (let ((rgb (hsv-color h s v)))
    (rgba-color
      (rgb-color-red rgb)
      (rgb-color-green rgb)
      (rgb-color-blue rgb)
      a)))

; XYZ color
; (Observer = 2°, Illuminant = D65)
; - x from 0 to 95.047
; - y from 0 to 100
; - z from 0 to 108.883
(define (xyz-color x y z)
  (let* ((vX (/ x 100))
         (vY (/ y 100))
         (vZ (/ z 100))
         (vR (+ (* vX 3.2406) (* vY -1.5372) (* vZ -0.4986)))
         (vG (+ (* vX -0.9689) (* vY 1.8758) (* vZ 0.0415)))
         (vB (+ (* vX 0.0557) (* vY -0.2040) (* vZ 1.0570)))
         (transform
           (lambda (v)
             (if (> v 0.0031308)
                 (- (* 1.055 (expt v (/ 1 2.4))) 0.055)
                 (* 12.92 v)))))
    (rgb-color
      (clamp (inexact->exact (floor (* 255 (transform vR)))) 0 255)
      (clamp (inexact->exact (floor (* 255 (transform vG)))) 0 255)
      (clamp (inexact->exact (floor (* 255 (transform vB)))) 0 255))))

; XYZA color
(define (xyza-color x y z a)
  (let ((rgb (xyz-color x y z)))
    (rgba-color
      (rgb-color-red rgb)
      (rgb-color-green rgb)
      (rgb-color-blue rgb)
      a)))

; La*b* color
(define (lab-color l a* b*)
  (let* ((vY (/ (+ l 16) 116))
         (vX (+ vY (/ a* 500)))
         (vZ (- vY (/ b* 200)))
         (transform
           (lambda (v)
             (let ((v3 (* v v v)))
               (if (> v3 0.008856)
                   v3
                   (/ (- v 16/116) 7.787))))))
    (xyz-color
      (* 95.047 (transform vX))
      (* 100 (transform vY))
      (* 108.883 (transform vZ)))))

; La*b*A color
(define (laba-color l a* b* a)
  (let ((rgb (lab-color l a* b*)))
    (rgba-color
      (rgb-color-red rgb)
      (rgb-color-green rgb)
      (rgb-color-blue rgb)
      a)))

; LCH (a*b*) color - cylindrical representation of La*b* color space
; l: 0..100
; c: 0..100
; h: 0..360
(define (lch-ab-color l c h)
  (lab-color
    l
    (* c (cos (/ (* h pi) 180)))
    (* c (sin (/ (* h pi) 180)))))

; LCHA (a*b*) color
(define (lcha-ab-color l c h a)
  (let ((rgb (lch-ab-color l c h)))
    (rgba-color
      (rgb-color-red rgb)
      (rgb-color-green rgb)
      (rgb-color-blue rgb)
      a)))

; Luv color
(define (luv-color l u v)
  (let* ((vY (if (> l 8)
                 (expt (/ (+ l 16) 116) 3)
                 (* l (expt 3/29 3))))
         (rX 95.047)
         (rY 100)
         (rZ 108.883)
         (rU (/ (* 4 rX) (+ rX (* 15 rY) (* 3 rZ))))
         (rV (/ (* 9 rY) (+ rX (* 15 rY) (* 3 rZ))))
         (vU (+ rU (/ u (* 13 l))))
         (vV (+ rV (/ v (* 13 l))))
         (y (* 100 vY))
         (x (* y (/ (* 9 vU) (* 4 vV))))
         (z (* y (/ (+ 12 (* -3 vU) (* -20 vV)) (* 4 vV)))))
    (xyz-color x y z)))

; LuvA color
(define (luva-color l u v a)
  (let ((rgb (luv-color l u v)))
    (rgba-color
      (rgb-color-red rgb)
      (rgb-color-green rgb)
      (rgb-color-blue rgb)
      a)))

; LCH (uv) color - cylindrical representation of Luv color space
(define (lch-uv-color l c h)
  (luv-color
    l
    (* c (cos (/ (* h pi) 180)))
    (* c (sin (/ (* h pi) 180)))))

; LCHA (uv) color
(define (lcha-uv-color l c h a)
  (let ((rgb (lch-uv-color l c h)))
    (rgba-color
      (rgb-color-red rgb)
      (rgb-color-green rgb)
      (rgb-color-blue rgb)
      a)))
