(.module:
  [lux #*
   [abstract
    [equivalence (#+ Equivalence)]
    [monoid (#+ Monoid)]]
   [data
    [number
     ["n" nat]
     ["." int]
     ["." rev ("#@." interval)]
     ["f" frac]]
    [collection
     ["." list ("#@." functor)]]]
   ["." math]
   [type
    abstract]])

(def: rgb 256)
(def: top (dec rgb))

(def: rgb-factor (|> top .int int.frac))

(def: scale-down
  (-> Nat Frac)
  (|>> .int int.frac (f./ rgb-factor)))

(def: scale-up
  (-> Frac Nat)
  (|>> (f.* rgb-factor) f.int .nat))

(type: #export RGB
  {#red Nat
   #green Nat
   #blue Nat})

(type: #export HSL
  [Frac Frac Frac])

(type: #export CMYK
  {#cyan Frac
   #magenta Frac
   #yellow Frac
   #key Frac})

(type: #export HSB
  [Frac Frac Frac])

(abstract: #export Color
  RGB

  (def: #export (from-rgb [red green blue])
    (-> RGB Color)
    (:abstraction {#red (n.% ..rgb red)
                   #green (n.% ..rgb green)
                   #blue (n.% ..rgb blue)}))

  (def: #export to-rgb
    (-> Color RGB)
    (|>> :representation))

  (structure: #export equivalence
    (Equivalence Color)
    
    (def: (= reference sample)
      (let [[rr rg rb] (:representation reference)
            [sr sg sb] (:representation sample)]
        (and (n.= rr sr)
             (n.= rg sg)
             (n.= rb sb)))))

  (def: #export black
    (..from-rgb {#red 0
                 #green 0
                 #blue 0}))

  (def: #export white
    (..from-rgb {#red ..top
                 #green ..top
                 #blue ..top}))

  (structure: #export addition
    (Monoid Color)

    (def: identity ..black)

    (def: (compose left right)
      (let [[lR lG lB] (:representation left)
            [rR rG rB] (:representation right)]
        (:abstraction {#red (n.max lR rR)
                       #green (n.max lG rG)
                       #blue (n.max lB rB)}))))

  (def: (complement' value)
    (-> Nat Nat)
    (|> ..top (n.- value)))

  (def: #export (complement color)
    (-> Color Color)
    (let [[red green blue] (:representation color)]
      (:abstraction {#red (complement' red)
                     #green (complement' green)
                     #blue (complement' blue)})))

  (structure: #export subtraction
    (Monoid Color)

    (def: identity ..white)

    (def: (compose left right)
      (let [[lR lG lB] (:representation (..complement left))
            [rR rG rB] (:representation right)]
        (:abstraction {#red (n.min lR rR)
                       #green (n.min lG rG)
                       #blue (n.min lB rB)}))))
  )

(def: #export (to-hsl color)
  (-> Color HSL)
  (let [[red green blue] (to-rgb color)
        red (scale-down red)
        green (scale-down green)
        blue (scale-down blue)
        max ($_ f.max red green blue)
        min ($_ f.min red green blue)
        luminance (|> (f.+ max min) (f./ +2.0))]
    (if (f.= max min)
      ## Achromatic
      [+0.0
       +0.0
       luminance]
      ## Chromatic
      (let [diff (|> max (f.- min))
            saturation (|> diff
                           (f./ (if (f.> +0.5 luminance)
                                  (|> +2.0 (f.- max) (f.- min))
                                  (|> max (f.+ min)))))
            hue' (cond (f.= red max)
                       (|> green (f.- blue) (f./ diff)
                           (f.+ (if (f.< blue green) +6.0 +0.0)))
                       
                       (f.= green max)
                       (|> blue (f.- red) (f./ diff)
                           (f.+ +2.0))
                       
                       ## (f.= blue max)
                       (|> red (f.- green) (f./ diff)
                           (f.+ +4.0)))]
        [(|> hue' (f./ +6.0))
         saturation
         luminance]))))

(def: (hue-to-rgb p q t)
  (-> Frac Frac Frac Frac)
  (let [t (cond (f.< +0.0 t) (f.+ +1.0 t)
                (f.> +1.0 t) (f.- +1.0 t)
                ## else
                t)
        f2/3 (f./ +3.0 +2.0)]
    (cond (f.< (f./ +6.0 +1.0) t)
          (|> q (f.- p) (f.* +6.0) (f.* t) (f.+ p))
          
          (f.< (f./ +2.0 +1.0) t)
          q
          
          (f.< f2/3 t)
          (|> q (f.- p) (f.* (|> f2/3 (f.- t))) (f.* +6.0) (f.+ p))
          
          ## else
          p)))

(def: #export (from-hsl [hue saturation luminance])
  (-> HSL Color)
  (if (f.= +0.0 saturation)
    ## Achromatic
    (let [intensity (scale-up luminance)]
      (from-rgb {#red intensity
                 #green intensity
                 #blue intensity}))
    ## Chromatic
    (let [q (if (f.< +0.5 luminance)
              (|> saturation (f.+ +1.0) (f.* luminance))
              (|> luminance (f.+ saturation) (f.- (f.* saturation luminance))))
          p (|> luminance (f.* +2.0) (f.- q))
          third (|> +1.0 (f./ +3.0))]
      (from-rgb {#red (scale-up (|> hue (f.+ third) (hue-to-rgb p q)))
                 #green (scale-up (|> hue (hue-to-rgb p q)))
                 #blue (scale-up (|> hue (f.- third) (hue-to-rgb p q)))}))))

(def: #export (to-hsb color)
  (-> Color HSB)
  (let [[red green blue] (to-rgb color)
        red (scale-down red)
        green (scale-down green)
        blue (scale-down blue)
        max ($_ f.max red green blue)
        min ($_ f.min red green blue)
        brightness max
        diff (|> max (f.- min))
        saturation (if (f.= +0.0 max)
                     +0.0
                     (|> diff (f./ max)))]
    (if (f.= max min)
      ## Achromatic
      [+0.0 saturation brightness]
      ## Chromatic
      (let [hue (cond (f.= red max)
                      (|> green (f.- blue) (f./ diff)
                          (f.+ (if (f.< blue green) +6.0 +0.0)))

                      (f.= green max)
                      (|> blue (f.- red) (f./ diff)
                          (f.+ +2.0))

                      ## (f.= blue max)
                      (|> red (f.- green) (f./ diff)
                          (f.+ +4.0)))]
        [(|> hue (f./ +6.0))
         saturation
         brightness]))))

(def: #export (from-hsb [hue saturation brightness])
  (-> HSB Color)
  (let [hue (|> hue (f.* +6.0))
        i (math.floor hue)
        f (|> hue (f.- i))
        p (|> +1.0 (f.- saturation) (f.* brightness))
        q (|> +1.0 (f.- (f.* f saturation)) (f.* brightness))
        t (|> +1.0 (f.- (|> +1.0 (f.- f) (f.* saturation))) (f.* brightness))
        v brightness
        mod (|> i (f.% +6.0) f.int .nat)
        red (case mod 0 v 1 q 2 p 3 p 4 t 5 v _ (undefined))
        green (case mod 0 t 1 v 2 v 3 q 4 p 5 p _ (undefined))
        blue (case mod 0 p 1 p 2 t 3 v 4 v 5 q _ (undefined))]
    (from-rgb {#red (scale-up red)
               #green (scale-up green)
               #blue (scale-up blue)})))

(def: #export (to-cmyk color)
  (-> Color CMYK)
  (let [[red green blue] (to-rgb color)
        red (scale-down red)
        green (scale-down green)
        blue (scale-down blue)
        key (|> +1.0 (f.- ($_ f.max red green blue)))
        f (if (f.< +1.0 key)
            (|> +1.0 (f./ (|> +1.0 (f.- key))))
            +0.0)
        cyan (|> +1.0 (f.- red) (f.- key) (f.* f))
        magenta (|> +1.0 (f.- green) (f.- key) (f.* f))
        yellow (|> +1.0 (f.- blue) (f.- key) (f.* f))]
    {#cyan cyan
     #magenta magenta
     #yellow yellow
     #key key}))

(def: #export (from-cmyk [cyan magenta yellow key])
  (-> CMYK Color)
  (if (f.= +1.0 key)
    (from-rgb {#red 0
               #green 0
               #blue 0})
    (let [red (|> (|> +1.0 (f.- cyan))
                  (f.* (|> +1.0 (f.- key))))
          green (|> (|> +1.0 (f.- magenta))
                    (f.* (|> +1.0 (f.- key))))
          blue (|> (|> +1.0 (f.- yellow))
                   (f.* (|> +1.0 (f.- key))))]
      (from-rgb {#red (scale-up red)
                 #green (scale-up green)
                 #blue (scale-up blue)}))))

(def: (normalize ratio)
  (-> Frac Frac)
  (cond (f.> +1.0 ratio)
        (f.% +1.0 ratio)

        (f.< +0.0 ratio)
        (|> ratio (f.% +1.0) (f.+ +1.0))

        ## else
        ratio))

(def: #export (interpolate ratio end start)
  (-> Frac Color Color Color)
  (let [dS (..normalize ratio)
        dE (|> +1.0 (f.- dS))
        interpolate' (: (-> Nat Nat Nat)
                        (function (_ end start)
                          (|> (|> start .int int.frac (f.* dS))
                              (f.+ (|> end .int int.frac (f.* dE)))
                              f.int
                              .nat)))
        [redS greenS blueS] (to-rgb start)
        [redE greenE blueE] (to-rgb end)]
    (from-rgb {#red (interpolate' redE redS)
               #green (interpolate' greenE greenS)
               #blue (interpolate' blueE blueS)})))

(template [<name> <target>]
  [(def: #export (<name> ratio color)
     (-> Frac Color Color)
     (..interpolate ratio <target> color))]

  [darker   black]
  [brighter white]
  )

(template [<name> <op>]
  [(def: #export (<name> ratio color)
     (-> Frac Color Color)
     (let [[hue saturation luminance] (to-hsl color)]
       (from-hsl [hue
                  (|> saturation
                      (f.* (|> +1.0 (<op> (..normalize ratio))))
                      (f.min +1.0))
                  luminance])))]

  [saturate    f.+]
  [de-saturate f.-]
  )

(def: #export (gray-scale color)
  (-> Color Color)
  (let [[_ _ luminance] (to-hsl color)]
    (from-hsl [+0.0
               +0.0
               luminance])))

(template [<name> <1> <2>]
  [(def: #export (<name> color)
     (-> Color [Color Color Color])
     (let [[hue saturation luminance] (to-hsl color)]
       [color
        (from-hsl [(|> hue (f.+ <1>) ..normalize)
                   saturation
                   luminance])
        (from-hsl [(|> hue (f.+ <2>) ..normalize)
                   saturation
                   luminance])]))]

  [triad            (|> +1.0 (f./ +3.0)) (|> +2.0 (f./ +3.0))]
  [clash            (|> +1.0 (f./ +4.0)) (|> +3.0 (f./ +4.0))]
  [split-complement (|> +1.0 (f./ +5.0)) (|> +3.0 (f./ +5.0))]
  )

(template [<name> <1> <2> <3>]
  [(def: #export (<name> color)
     (-> Color [Color Color Color Color])
     (let [[hue saturation luminance] (to-hsb color)]
       [color
        (from-hsb [(|> hue (f.+ <1>) ..normalize)
                   saturation
                   luminance])
        (from-hsb [(|> hue (f.+ <2>) ..normalize)
                   saturation
                   luminance])
        (from-hsb [(|> hue (f.+ <3>) ..normalize)
                   saturation
                   luminance])]))]

  [square   (|> +1.0 (f./ +4.0))  (|> +2.0 (f./ +4.0))  (|> +3.0 (f./ +4.0))]
  [tetradic (|> +2.0 (f./ +12.0)) (|> +6.0 (f./ +12.0)) (|> +8.0 (f./ +12.0))]
  )

(type: #export Spread
  Frac)

(type: #export Palette
  (-> Spread Nat Color (List Color)))

(def: #export (analogous spread variations color)
  (-> Spread Nat Color (List Color))
  (let [[hue saturation brightness] (to-hsb color)
        spread (..normalize spread)]
    (list@map (function (_ idx)
                (from-hsb [(|> idx inc .int int.frac (f.* spread) (f.+ hue) ..normalize)
                           saturation
                           brightness]))
              (list.indices variations))))

(def: #export (monochromatic spread variations color)
  (-> Spread Nat Color (List Color))
  (let [[hue saturation brightness] (to-hsb color)
        spread (..normalize spread)]
    (|> (list.indices variations)
        (list@map (|>> inc .int int.frac
                       (f.* spread)
                       (f.+ brightness)
                       ..normalize
                       [hue saturation]
                       from-hsb)))))

(type: #export Alpha
  Rev)

(def: #export transparent
  Alpha
  rev@bottom)

(def: #export translucent
  Alpha
  .5)

(def: #export opaque
  Alpha
  rev@top)

(type: #export Pigment
  {#color Color
   #alpha Alpha})