path: root/stdlib/source/library/lux/data/color.lux

(.module:
  [library
   [lux "*"
    [abstract
     [equivalence {"+" Equivalence}]
     [monoid {"+" Monoid}]
     ["[0]" hash {"+" Hash}]]
    [control
     [parser
      ["<[0]>" code]]]
    [data
     [collection
      ["[0]" list ("[1]#[0]" functor)]]]
    ["[0]" math
     [number
      ["n" nat]
      ["f" frac]
      ["[0]" int]
      ["[0]" rev ("[1]#[0]" interval)]
      ["[0]" i64]]]
    [type
     abstract]]])

(def: rgb_limit 256)
(def: top (-- rgb_limit))

(def: rgb_factor
  (|> top .int int.frac))

(def: down
  (-> Nat Frac)
  (|>> .int int.frac (f./ rgb_factor)))

(def: up
  (-> Frac Nat)
  (|>> (f.* rgb_factor) f.int .nat))

(type: .public RGB
  (Record
   [#red Nat
    #green Nat
    #blue Nat]))

(type: .public HSL
  [Frac Frac Frac])

(type: .public CMYK
  (Record
   [#cyan Frac
    #magenta Frac
    #yellow Frac
    #key Frac]))

(type: .public HSB
  [Frac Frac Frac])

(abstract: .public Color
  RGB

  (def: .public (of_rgb [red green blue])
    (-> RGB Color)
    (:abstraction [#red (n.% ..rgb_limit red)
                   #green (n.% ..rgb_limit green)
                   #blue (n.% ..rgb_limit blue)]))

  (def: .public rgb
    (-> Color RGB)
    (|>> :representation))

  (implementation: .public equivalence
    (Equivalence Color)
    
    (def: (= reference sample)
      (let [[rR gR bR] (:representation reference)
            [rS gS bS] (:representation sample)]
        (and (n.= rR rS)
             (n.= gR gS)
             (n.= bR bS)))))

  (implementation: .public hash
    (Hash Color)

    (def: &equivalence ..equivalence)

    (def: (hash value)
      (let [[r g b] (:representation value)]
        ($_ i64.or
            (i64.left_shifted 16 r)
            (i64.left_shifted 8 g)
            b))))

  (def: .public black
    Color
    (..of_rgb [#red 0
               #green 0
               #blue 0]))

  (def: .public white
    Color
    (..of_rgb [#red ..top
               #green ..top
               #blue ..top]))

  (implementation: .public addition
    (Monoid Color)

    (def: identity ..black)

    (def: (composite 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: (opposite_intensity value)
    (-> Nat Nat)
    (|> ..top (n.- value)))

  (def: .public (complement color)
    (-> Color Color)
    (let [[red green blue] (:representation color)]
      (:abstraction [#red (opposite_intensity red)
                     #green (opposite_intensity green)
                     #blue (opposite_intensity blue)])))

  (implementation: .public subtraction
    (Monoid Color)

    (def: identity ..white)

    (def: (composite 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: .public (hsl color)
  (-> Color HSL)
  (let [[red green blue] (rgb color)
        red (..down red)
        green (..down green)
        blue (..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_rgb p q t)
  (-> Frac Frac Frac Nat)
  (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)]
    (..up (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: .public (of_hsl [hue saturation luminance])
  (-> HSL Color)
  (if (f.= +0.0 saturation)
    ... Achromatic
    (let [intensity (..up luminance)]
      (of_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))]
      (of_rgb [#red (|> hue (f.+ third) (hue_rgb p q))
               #green (|> hue (hue_rgb p q))
               #blue (|> hue (f.- third) (hue_rgb p q))]))))

(def: .public (hsb color)
  (-> Color HSB)
  (let [[red green blue] (rgb color)
        red (..down red)
        green (..down green)
        blue (..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: .public (of_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))]
    (of_rgb [#red (..up red)
             #green (..up green)
             #blue (..up blue)])))

(def: .public (cmyk color)
  (-> Color CMYK)
  (let [[red green blue] (rgb color)
        red (..down red)
        green (..down green)
        blue (..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: .public (of_cmyk [cyan magenta yellow key])
  (-> CMYK Color)
  (if (f.= +1.0 key)
    (of_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))))]
      (of_rgb [#red (..up red)
               #green (..up green)
               #blue (..up blue)]))))

(def: (normal 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: .public (interpolated ratio end start)
  (-> Frac Color Color Color)
  (let [dS (..normal ratio)
        dE (|> +1.0 (f.- dS))
        interpolated' (: (-> 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] (rgb start)
        [redE greenE blueE] (rgb end)]
    (of_rgb [#red (interpolated' redE redS)
             #green (interpolated' greenE greenS)
             #blue (interpolated' blueE blueS)])))

(template [<name> <target>]
  [(def: .public (<name> ratio color)
     (-> Frac Color Color)
     (..interpolated ratio <target> color))]

  [darker   ..black]
  [brighter ..white]
  )

(template [<op> <name>]
  [(def: .public (<name> ratio color)
     (-> Frac Color Color)
     (let [[hue saturation luminance] (hsl color)]
       (of_hsl [hue
                (|> saturation
                    (f.* (|> +1.0 (<op> (..normal ratio))))
                    (f.min +1.0))
                luminance])))]

  [f.+ saturated]
  [f.- un_saturated]
  )

(def: .public (gray_scale color)
  (-> Color Color)
  (let [[_ _ luminance] (hsl color)]
    (of_hsl [+0.0
             +0.0
             luminance])))

(template [<name> <1> <2>]
  [(`` (def: .public (<name> color)
         (-> Color [Color Color Color])
         (let [[hue saturation luminance] (hsl color)]
           [color
            (of_hsl [(|> hue (f.+ <1>) ..normal)
                     saturation
                     luminance])
            (of_hsl [(|> hue (f.+ <2>) ..normal)
                     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: .public (<name> color)
         (-> Color [Color Color Color Color])
         (let [[hue saturation luminance] (hsb color)]
           [color
            (of_hsb [(|> hue (f.+ <1>) ..normal)
                     saturation
                     luminance])
            (of_hsb [(|> hue (f.+ <2>) ..normal)
                     saturation
                     luminance])
            (of_hsb [(|> hue (f.+ <3>) ..normal)
                     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: .public Spread
  Frac)

(type: .public Palette
  (-> Spread Nat Color (List Color)))

(`` (def: .public (analogous spread variations color)
      Palette
      (let [[hue saturation brightness] (hsb color)
            spread (..normal spread)]
        (list#each (function (_ idx)
                     (of_hsb [(|> idx ++ .int int.frac (f.* spread) (f.+ hue) ..normal)
                              saturation
                              brightness]))
                   (list.indices variations)))))

(`` (def: .public (monochromatic spread variations color)
      Palette
      (let [[hue saturation brightness] (hsb color)
            spread (..normal spread)]
        (|> (list.indices variations)
            (list#each (|>> ++ .int int.frac
                            (f.* spread)
                            (f.+ brightness)
                            ..normal
                            [hue saturation]
                            of_hsb))))))

(type: .public Alpha
  Rev)

(def: .public transparent
  Alpha
  rev#bottom)

(def: .public translucent
  Alpha
  .5)

(def: .public opaque
  Alpha
  rev#top)

(type: .public Pigment
  (Record
   [#color Color
    #alpha Alpha]))