aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/data/color.lux
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/lux/data/color.lux')
-rw-r--r--stdlib/source/lux/data/color.lux424
1 files changed, 0 insertions, 424 deletions
diff --git a/stdlib/source/lux/data/color.lux b/stdlib/source/lux/data/color.lux
deleted file mode 100644
index 921137d9a..000000000
--- a/stdlib/source/lux/data/color.lux
+++ /dev/null
@@ -1,424 +0,0 @@
-(.module:
- [lux #*
- [abstract
- [equivalence (#+ Equivalence)]
- [monoid (#+ Monoid)]
- ["." hash (#+ Hash)]]
- [data
- [collection
- ["." list ("#\." functor)]]]
- ["." math
- [number
- ["n" nat]
- ["f" frac]
- ["." int]
- ["." rev ("#\." interval)]
- ["." i64]]]
- [type
- abstract]])
-
-(def: rgb 256)
-(def: top (dec rgb))
-
-(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: #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))
-
- (implementation: #export 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: #export hash
- (Hash Color)
-
- (def: &equivalence ..equivalence)
-
- (def: (hash value)
- (let [[r g b] (:representation value)]
- ($_ i64.or
- (i64.left_shift 16 r)
- (i64.left_shift 8 g)
- b))))
-
- (def: #export black
- (..from_rgb {#red 0
- #green 0
- #blue 0}))
-
- (def: #export white
- (..from_rgb {#red ..top
- #green ..top
- #blue ..top}))
-
- (implementation: #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)})))
-
- (implementation: #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 (..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_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 (..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 (..up (|> hue (f.+ third) (hue_to_rgb p q)))
- #green (..up (|> hue (hue_to_rgb p q)))
- #blue (..up (|> hue (f.- third) (hue_to_rgb p q)))}))))
-
-(def: #export (to_hsb color)
- (-> Color HSB)
- (let [[red green blue] (to_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: #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 (..up red)
- #green (..up green)
- #blue (..up blue)})))
-
-(def: #export (to_cmyk color)
- (-> Color CMYK)
- (let [[red green blue] (to_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: #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 (..up red)
- #green (..up green)
- #blue (..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})
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-04 22:45:22 +0000