(.module:
  [lux #*
   [control
    [equivalence (#+ Equivalence)]]
   [data
    [number
     [rev ("rev/." interval)]]
    [collection
     ["." list ("list/." functor)]]]
   ["." math]
   [type
    abstract]])

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

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

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

(def: scale-up
  (-> Frac Nat)
  (|>> (f/* rgb-factor) frac-to-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 (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) frac-to-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)
        (|> +1.0 (f/+ (f/% +1.0 ratio)))

        ## 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-to-frac (f/* dS))
                              (f/+ (|> end .int int-to-frac (f/* dE)))
                              frac-to-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)})))

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

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

  [darker   black]
  [brighter white]
  )

(def: #export (complement color)
  (-> Color Color)
  (let [[red green blue] (to-rgb color)
        adjust (function (_ value) (|> top (n/- value)))]
    (from-rgb {#red (adjust red)
               #green (adjust green)
               #blue (adjust blue)})))

(do-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])))

(do-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))]
  )

(do-template [<name> <1> <2> <3>]
  [(def: #export (<name> color)
     (-> 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])
        (from-hsl [(|> 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))]
  )

(def: #export (analogous results slice color)
  (-> Nat Frac Color (List Color))
  (if (n/= 0 results)
    (list)
    (let [[hue saturation luminance] (to-hsl color)
          slice (normalize slice)]
      (list/map (function (_ idx)
                  (from-hsl [(|> idx .int int-to-frac (f/* slice) (f/+ hue) normalize)
                             saturation
                             luminance]))
                (list.indices results)))))

(def: #export (monochromatic results color)
  (-> Nat Color (List Color))
  (if (n/= 0 results)
    (list)
    (let [[hue saturation brightness] (to-hsb color)
          slice (|> +1.0 (f// (|> results .int int-to-frac)))]
      (|> (list.indices results)
          (list/map (|>> .int int-to-frac
                         (f/* slice)
                         (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})