--- /dev/null
+John Benediktsson
--- /dev/null
+USING: help.markup help.syntax ;
+IN: colors.cmyk
+
+HELP: cmyka
+{ $class-description "The class of CMYK (Cyan, Magenta, Yellow, Black) colors with an alpha channel. All slots store values in the interval " { $snippet "[0,1]" } "." } ;
+
+ARTICLE: "colors.cmyk" "CMYK colors"
+"The " { $vocab-link "colors.cmyk" } " vocabulary implements colors specified by their cyan, magenta, yellow, and black components, together with an alpha channel."
+{ $subsections
+ cmyka
+ <cmyka>
+ >cmyka
+}
+{ $see-also "colors" } ;
+
+ABOUT: "colors.cmyk"
--- /dev/null
+! Copyright (C) 2013 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays colors colors.cmyk kernel locals math.functions
+math.ranges sequences tools.test ;
+
+{ t } [
+ 0.0 1.0 0.1 <range> [| r |
+ 0.0 1.0 0.1 <range> [| g |
+ 0.0 1.0 0.1 <range> [| b |
+ r g b 1.0 <rgba> dup >cmyka >rgba
+ [ >rgba-components 4array ] bi@
+ [ 0.00000001 ~ ] 2all?
+ ] all?
+ ] all?
+ ] all?
+] unit-test
--- /dev/null
+! Copyright (C) 2012 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors combinators colors colors.gray kernel math
+math.order ;
+
+IN: colors.cmyk
+
+TUPLE: cmyka < color
+{ cyan read-only }
+{ magenta read-only }
+{ yellow read-only }
+{ black read-only }
+{ alpha read-only } ;
+
+C: <cmyka> cmyka
+
+M: cmyka >rgba
+ [ [ cyan>> ] [ black>> ] bi + ]
+ [ [ magenta>> ] [ black>> ] bi + ]
+ [ [ yellow>> ] [ black>> ] bi + ] tri
+ [ 1.0 min 1.0 swap - ] tri@ 1.0 <rgba> ; inline
+
+GENERIC: >cmyka ( color -- cmyka )
+
+M: object >cmyka >rgba >cmyka ;
+
+M: rgba >cmyka
+ >rgba-components [
+ [ 1 swap - ] tri@ 3dup min min
+ [ [ - 0.0 1.0 clamp ] curry tri@ ] keep
+ ] dip <cmyka> ;
+
+M: cmyka >gray
+ [
+ {
+ [ cyan>> 0.3 * ]
+ [ magenta>> 0.59 * ]
+ [ yellow>> 0.11 * ]
+ [ black>> ]
+ } cleave + + + 1.0 min 1.0 swap -
+ ] [ alpha>> ] bi <gray> ;
--- /dev/null
+CMYK colors
--- /dev/null
+John Benediktsson
--- /dev/null
+USING: help.markup help.syntax ;
+IN: colors.hsl
+
+HELP: hsla
+{ $class-description "The class of HSL (Hue, Saturation, Lightness) colors with an alpha channel. All slots store values in the interval " { $snippet "[0,1]" } "." } ;
+
+ARTICLE: "colors.hsl" "HSL colors"
+"The " { $vocab-link "colors.hsl" } " vocabulary implements colors specified by their hue, saturation, and lightness components, together with an alpha channel."
+{ $subsections
+ hsla
+ <hsla>
+ >hsla
+}
+{ $see-also "colors" } ;
+
+ABOUT: "colors.hsl"
--- /dev/null
+! Copyright (C) 2013 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays colors colors.hsl kernel locals math.functions
+math.ranges sequences tools.test ;
+
+{ t } [
+ 0.0 1.0 0.1 <range> [| r |
+ 0.0 1.0 0.1 <range> [| g |
+ 0.0 1.0 0.1 <range> [| b |
+ r g b 1.0 <rgba> dup >hsla >rgba
+ [ >rgba-components 4array ] bi@
+ [ 0.00000001 ~ ] 2all?
+ ] all?
+ ] all?
+ ] all?
+] unit-test
--- /dev/null
+! Copyright (C) 2012 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors combinators kernel locals math
+math.order ;
+
+IN: colors.hsl
+
+TUPLE: hsla < color
+{ hue read-only }
+{ saturation read-only }
+{ lightness read-only }
+{ alpha read-only } ;
+
+C: <hsla> hsla
+
+<PRIVATE
+
+: value ( p q t -- value )
+ dup 0 < [ 1.0 + ] when
+ dup 1 > [ 1.0 - ] when
+ {
+ { [ dup 1/6 < ] [ [ over - ] dip * 6 * + ] }
+ { [ dup 1/2 < ] [ drop nip ] }
+ { [ dup 2/3 < ] [ [ over - ] dip 2/3 swap - * 6 * + ] }
+ [ 2drop ]
+ } cond ;
+
+PRIVATE>
+
+M: hsla >rgba
+ {
+ [ hue>> ] [ saturation>> ] [ lightness>> ] [ alpha>> ]
+ } cleave [| h s l |
+ s zero? [
+ l l l
+ ] [
+ l 0.5 < [ l s 1 + * ] [ l s + l s * - ] if :> q
+ l 2 * q - :> p
+ p q h 1/3 + value
+ p q h value
+ p q h 1/3 - value
+ ] if
+ ] dip <rgba> ; inline
+
+GENERIC: >hsla ( color -- hsla )
+
+M: object >hsla >rgba >hsla ;
+
+M: hsla >hsla ; inline
+
+M: rgba >hsla
+ >rgba-components [| r g b |
+ r g b min min :> min-c
+ r g b max max :> max-c
+ min-c max-c + 2 / :> l
+ max-c min-c - :> d
+ d zero? [ 0.0 0.0 ] [
+ max-c {
+ { r [ g b - d / g b < 6.0 0.0 ? + ] }
+ { g [ b r - d / 2.0 + ] }
+ { b [ r g - d / 4.0 + ] }
+ } case 6.0 /
+ l 0.5 > [
+ d 2 max-c - min-c - /
+ ] [
+ d max-c min-c + /
+ ] if
+ ] if l
+ ] dip <hsla> ;
--- /dev/null
+HSL colors
--- /dev/null
+John Benediktsson
--- /dev/null
+USING: help.markup help.syntax ;
+IN: colors.lab
+
+HELP: laba
+{ $class-description "The class of CIE 1976 LAB (commonly called CIELAB) colors with an alpha channel." } ;
+
+ARTICLE: "colors.lab" "CIE 1976 LAB colors"
+"The " { $vocab-link "colors.lab" } " vocabulary implements CIE 1976 LAB colors, specifying luminance (in approximately " { $snippet "[0,100]" } "), red/green, and blue/yellow components, together with an alpha channel."
+{ $subsections
+ laba
+ <laba>
+ >laba
+}
+"For more information, see " { $url "https://en.wikipedia.org/wiki/Lab_color_space" }
+{ $see-also "colors" } ;
+
+ABOUT: "colors.lab"
--- /dev/null
+! Copyright (C) 2014 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays colors colors.lab kernel locals math.functions
+math.ranges sequences tools.test ;
+
+{ t } [
+ 0.0 1.0 0.1 <range> [| r |
+ 0.0 1.0 0.1 <range> [| g |
+ 0.0 1.0 0.1 <range> [| b |
+ r g b 1.0 <rgba> dup >laba >rgba
+ [ >rgba-components 4array ] bi@
+ [ 0.00001 ~ ] 2all?
+ ] all?
+ ] all?
+ ] all?
+] unit-test
--- /dev/null
+! Copyright (C) 2014 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors colors.xyz colors.xyz.private kernel
+locals math math.functions ;
+
+IN: colors.lab
+
+TUPLE: laba l a b alpha ;
+
+C: <laba> laba
+
+M: laba >rgba >xyza >rgba ;
+
+M: laba >xyza
+ [
+ [let
+ [ l>> ] [ a>> ] [ b>> ] tri :> ( l a b )
+ l 16 + 116 / :> fy
+ a 500 / fy + :> fx
+ fy b 200 / - :> fz
+
+ fx 3 ^ :> fx3
+ fz 3 ^ :> fz3
+
+ fx3 xyz_epsilon > [
+ fx3
+ ] [
+ 116 fx * 16 - xyz_kappa /
+ ] if :> x
+
+ l xyz_kappa xyz_epsilon * > [
+ l 16 + 116 / 3 ^
+ ] [
+ l xyz_kappa /
+ ] if :> y
+
+ fz3 xyz_epsilon > [
+ fz3
+ ] [
+ 116 fz * 16 - xyz_kappa /
+ ] if :> z
+
+ x wp_x * y wp_y * z wp_z *
+ ]
+ ] [ alpha>> ] bi <xyza> ;
+
+GENERIC: >laba ( color -- laba )
+
+M: object >laba >rgba >laba ;
+
+M: rgba >laba >xyza >laba ;
+
+M: xyza >laba
+ [
+ [let
+ [ x>> wp_x / ] [ y>> wp_y / ] [ z>> wp_z / ] tri
+ [
+ dup xyz_epsilon >
+ [ 1/3 ^ ] [ xyz_kappa * 16 + 116 / ] if
+ ] tri@ :> ( fx fy fz )
+ 116 fy * 16 -
+ 500 fx fy - *
+ 200 fy fz - *
+ ]
+ ] [ alpha>> ] bi <laba> ;
--- /dev/null
+CIE 1976 LAB colors
--- /dev/null
+John Benediktsson
--- /dev/null
+! Copyright (C) 2014 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays colors colors.lch kernel locals math.functions
+math.ranges sequences tools.test ;
+
+{ t } [
+ 0.0 1.0 0.1 <range> [| r |
+ 0.0 1.0 0.1 <range> [| g |
+ 0.0 1.0 0.1 <range> [| b |
+ r g b 1.0 <rgba> dup >LCHuv >rgba
+ [ >rgba-components 4array ] bi@
+ [ 0.00001 ~ ] 2all?
+ ] all?
+ ] all?
+ ] all?
+] unit-test
+
+{ t } [
+ 0.0 1.0 0.1 <range> [| r |
+ 0.0 1.0 0.1 <range> [| g |
+ 0.0 1.0 0.1 <range> [| b |
+ r g b 1.0 <rgba> dup >LCHab >rgba
+ [ >rgba-components 4array ] bi@
+ [ 0.00001 ~ ] 2all?
+ ] all?
+ ] all?
+ ] all?
+] unit-test
--- /dev/null
+! Copyright (C) 2014 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors colors.lab colors.luv colors.xyz kernel
+locals math math.functions math.libm math.trig ;
+
+IN: colors.lch
+
+TUPLE: LCHuv l c h alpha ;
+
+C: <LCHuv> LCHuv
+
+M: LCHuv >rgba >luva >rgba ;
+
+M: LCHuv >xyza >luva >xyza ;
+
+M: LCHuv >luva
+ [
+ [let
+ [ l>> ] [ c>> ] [ h>> ] tri :> ( l c h )
+ h deg>rad :> hr
+
+ l
+ c hr cos *
+ c hr sin *
+ ]
+ ] [ alpha>> ] bi <luva> ;
+
+GENERIC: >LCHuv ( color -- LCHuv )
+
+M: object >LCHuv >luva >LCHuv ;
+
+M: LCHuv >LCHuv ; inline
+
+M: luva >LCHuv
+ [
+ [let
+ [ l>> ] [ u>> ] [ v>> ] tri :> ( l u v )
+ v u fatan2 rad>deg
+ [ dup 360 > ] [ 360 - ] while
+ [ dup 0 < ] [ 360 + ] while :> h
+
+ l
+ u sq v sq + sqrt
+ h
+ ]
+ ] [ alpha>> ] bi <LCHuv> ;
+
+TUPLE: LCHab l c h alpha ;
+
+C: <LCHab> LCHab
+
+M: LCHab >rgba >laba >rgba ;
+
+M: LCHab >laba
+ [
+ [let
+ [ l>> ] [ c>> ] [ h>> ] tri :> ( l c h )
+ h deg>rad :> hr
+
+ l
+ c hr cos *
+ c hr sin *
+ ]
+ ] [ alpha>> ] bi <laba> ;
+
+GENERIC: >LCHab ( color -- LCHab )
+
+M: object >LCHab >laba >LCHab ;
+
+M: LCHab >LCHab ; inline
+
+M: laba >LCHab
+ [
+ [let
+ [ l>> ] [ a>> ] [ b>> ] tri :> ( l a b )
+ b a fatan2 rad>deg
+ [ dup 360 > ] [ 360 - ] while
+ [ dup 0 < ] [ 360 + ] while :> h
+
+ l
+ a sq b sq + sqrt
+ h
+ ]
+ ] [ alpha>> ] bi <LCHab> ;
--- /dev/null
+CIELCH colors
--- /dev/null
+John Benediktsson
--- /dev/null
+USING: help.markup help.syntax ;
+IN: colors.luv
+
+HELP: luva
+{ $class-description "The class of CIE 1976 LUV (commonly called CIELUV) colors with an alpha channel." } ;
+
+ARTICLE: "colors.luv" "CIE 1976 LUV colors"
+"The " { $vocab-link "colors.luv" } " vocabulary implements CIE 1976 LUV colors, together with an alpha channel."
+{ $subsections
+ luva
+ <luva>
+ >luva
+}
+"For more information, see " { $url "https://en.wikipedia.org/wiki/CIELUV_color_space" }
+{ $see-also "colors" } ;
+
+ABOUT: "colors.luv"
--- /dev/null
+! Copyright (C) 2014 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays colors colors.luv kernel locals math.functions
+math.ranges sequences tools.test ;
+
+{ t } [
+ 0.0 1.0 0.1 <range> [| r |
+ 0.0 1.0 0.1 <range> [| g |
+ 0.0 1.0 0.1 <range> [| b |
+ r g b 1.0 <rgba> dup >luva >rgba
+ [ >rgba-components 4array ] bi@
+ [ 0.00001 ~ ] 2all?
+ ] all?
+ ] all?
+ ] all?
+] unit-test
--- /dev/null
+! Copyright (C) 2014 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors colors.xyz colors.xyz.private kernel
+locals math math.functions ;
+
+IN: colors.luv
+
+TUPLE: luva l u v alpha ;
+
+C: <luva> luva
+
+<PRIVATE
+
+:: xyz-to-uv ( x y z -- u v )
+ x y 15 * z 3 * + + :> d
+ 4 x * d /
+ 9 y * d / ; foldable
+
+PRIVATE>
+
+M: luva >rgba >xyza >rgba ;
+
+M: luva >xyza
+ [
+ [let
+ wp_x wp_y wp_z xyz-to-uv :> ( u_wp v_wp )
+ [ l>> ] [ u>> ] [ v>> ] tri :> ( l u v )
+
+ 52 l * 13 l * u_wp * u + / 1 - 3 / :> a
+ l xyz_kappa xyz_epsilon * > [
+ l 16 + 116 / 3 ^ wp_y *
+ ] [
+ l xyz_kappa / wp_y *
+ ] if :> y
+ y -5 * :> b
+ 39 l * 13 l * v_wp * v + / 5 - y * :> d
+ d b - a 1/3 + / :> x
+ a x * b + :> z
+
+ x y z
+ ]
+ ] [ alpha>> ] bi <xyza> ;
+
+GENERIC: >luva ( color -- luva )
+
+M: object >luva >rgba >luva ;
+
+M: rgba >luva >xyza >luva ;
+
+M: luva >luva ; inline
+
+M: xyza >luva
+ [
+ [let
+ wp_x wp_y wp_z xyz-to-uv :> ( u_wp v_wp )
+ [ x>> ] [ y>> ] [ z>> ] tri :> ( x_ y_ z_ )
+ x_ y_ z_ xyz-to-uv :> ( u_ v_ )
+
+ y_ wp_y / :> y
+
+ y xyz_epsilon > [
+ y 1/3 ^ 116 * 16 -
+ ] [
+ xyz_kappa y *
+ ] if :> l
+ 13 l * u_ u_wp - * :> u
+ 13 l * v_ v_wp - * :> v
+
+ l u v
+ ]
+ ] [ alpha>> ] bi <luva> ;
--- /dev/null
+CIE 1976 LUV colors
--- /dev/null
+John Benediktsson
--- /dev/null
+USING: help.markup help.syntax ;
+IN: colors.ryb
+
+HELP: ryba
+{ $class-description "The class of RYB (Red, Yellow, Blue) colors with an alpha channel. All slots store values in the interval " { $snippet "[0,1]" } "." } ;
+
+ARTICLE: "colors.ryb" "RYB colors"
+"The " { $vocab-link "colors.ryb" } " vocabulary implements colors specified by their red, yellow, and blue components, together with an alpha channel."
+{ $subsections
+ ryba
+ <ryba>
+ >ryba
+}
+{ $see-also "colors" } ;
+
+ABOUT: "colors.ryb"
--- /dev/null
+! Copyright (C) 2013 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays colors colors.ryb kernel locals math.functions
+math.ranges sequences tools.test ;
+
+{ t } [
+ 0.0 1.0 0.1 <range> [| r |
+ 0.0 1.0 0.1 <range> [| g |
+ 0.0 1.0 0.1 <range> [| b |
+ r g b 1.0 <rgba> dup >ryba >rgba
+ [ >rgba-components 4array ] bi@
+ [ 0.00000001 ~ ] 2all?
+ ] all?
+ ] all?
+ ] all?
+] unit-test
--- /dev/null
+! Copyright (C) 2013 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors kernel locals math math.order ;
+
+IN: colors.ryb
+
+TUPLE: ryba < color
+ { red read-only }
+ { yellow read-only }
+ { blue read-only }
+ { alpha read-only } ;
+
+C: <ryba> ryba
+
+<PRIVATE
+
+: normalized ( a b c quot: ( a b c -- a' b' c' ) -- a' b' c' )
+ [ 3dup min min ] dip over
+ [ [ - ] curry tri@ ]
+ [ call ]
+ [ [ + ] curry tri@ ] tri* ; inline
+
+:: ryb>rgb ( r! y! b! -- r g b )
+ r y b max max :> my
+
+ y b min :> g!
+ y g - y!
+ b g - b!
+
+ b g [ 0 > ] both? [
+ b 2 * b!
+ g 2 * g!
+ ] when
+
+ r y + r!
+ g y + g!
+
+ r g b 3dup max max [
+ my swap / [ * ] curry tri@
+ ] unless-zero ;
+
+:: rgb>ryb ( r! g! b! -- r y b )
+ r g b max max :> mg
+
+ r g min :> y!
+ r y - r!
+ g y - g!
+
+ b g [ 0 > ] both? [
+ b 2 /f b!
+ g 2 /f g!
+ ] when
+
+ y g + y!
+ b g + b!
+
+ r y b 3dup max max [
+ mg swap / [ * ] curry tri@
+ ] unless-zero ;
+
+PRIVATE>
+
+M: ryba >rgba ( ryba -- rgba )
+ [
+ [ red>> ] [ yellow>> ] [ blue>> ] tri
+ [ ryb>rgb ] normalized
+ ] [ alpha>> ] bi <rgba> ;
+
+GENERIC: >ryba ( color -- ryba )
+
+M: object >ryba >rgba >ryba ;
+
+M: ryba >ryba ; inline
+
+M: rgba >ryba
+ >rgba-components [ [ rgb>ryb ] normalized ] [ <ryba> ] bi* ;
--- /dev/null
+RYB colors
--- /dev/null
+John Benediktsson
--- /dev/null
+CIE 1931 xyY colors
--- /dev/null
+USING: help.markup help.syntax ;
+IN: colors.xyy
+
+HELP: xyYa
+{ $class-description "The class of CIE 1931 xyY colors with an alpha channel." } ;
+
+ARTICLE: "colors.xyy" "CIE 1931 xyY colors"
+"The " { $vocab-link "colors.xyy" } " vocabulary implements CIE 1931 xyY colors, together with an alpha channel."
+{ $subsections
+ xyYa
+ <xyYa>
+ >xyYa
+}
+"For more information, see " { $url "https://en.wikipedia.org/wiki/CIE_1931_color_space" }
+{ $see-also "colors" } ;
+
+ABOUT: "colors.xyy"
--- /dev/null
+! Copyright (C) 2014 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays colors colors.xyy kernel locals math.functions
+math.ranges sequences tools.test ;
+
+{ t } [
+ 0.0 1.0 0.1 <range> [| r |
+ 0.0 1.0 0.1 <range> [| g |
+ 0.0 1.0 0.1 <range> [| b |
+ r g b 1.0 <rgba> dup >xyYa >rgba
+ [ >rgba-components 4array ] bi@
+ [ 0.00001 ~ ] 2all?
+ ] all?
+ ] all?
+ ] all?
+] unit-test
--- /dev/null
+! Copyright (C) 2014 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors colors.xyz kernel locals math ;
+
+IN: colors.xyy
+
+TUPLE: xyYa x y Y alpha ;
+
+C: <xyYa> xyYa
+
+M: xyYa >rgba
+ >xyza >rgba ;
+
+M: xyYa >xyza
+ [
+ [let
+ [ x>> ] [ y>> ] [ Y>> ] tri :> ( x y Y )
+ x y / Y *
+ Y
+ 1 x - y - y / Y *
+ ]
+ ] [ alpha>> ] bi <xyza> ;
+
+GENERIC: >xyYa ( color -- xyYa )
+
+M: object >xyYa >xyza >xyYa ;
+
+M: xyYa >xyYa ; inline
+
+M: xyza >xyYa
+ [
+ [let
+ [ x>> ] [ y>> ] [ z>> ] tri :> ( x y z )
+ x y z + +
+ [ x swap / ]
+ [ y swap / ] bi
+ y
+ ]
+ ] [ alpha>> ] bi <xyYa> ;
--- /dev/null
+John Benediktsson
--- /dev/null
+CIE 1931 XYZ colors
--- /dev/null
+USING: help.markup help.syntax ;
+IN: colors.xyz
+
+HELP: xyza
+{ $class-description "The class of CIE 1931 XYZ colors with an alpha channel." } ;
+
+ARTICLE: "colors.xyz" "CIE 1931 XYZ colors"
+"The " { $vocab-link "colors.xyz" } " vocabulary implements CIE 1931 XYZ colors, together with an alpha channel."
+{ $subsections
+ xyza
+ <xyza>
+ >xyza
+}
+"For more information, see " { $url "https://en.wikipedia.org/wiki/CIE_1931_color_space" }
+{ $see-also "colors" } ;
+
+ABOUT: "colors.xyz"
--- /dev/null
+! Copyright (C) 2014 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays colors colors.xyz kernel locals math.functions
+math.ranges sequences tools.test ;
+
+{ t } [
+ 0.0 1.0 0.1 <range> [| r |
+ 0.0 1.0 0.1 <range> [| g |
+ 0.0 1.0 0.1 <range> [| b |
+ r g b 1.0 <rgba> dup >xyza >rgba
+ [ >rgba-components 4array ] bi@
+ [ 0.00001 ~ ] 2all?
+ ] all?
+ ] all?
+ ] all?
+] unit-test
--- /dev/null
+! Copyright (C) 2014 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors kernel locals math math.functions
+math.order ;
+
+IN: colors.xyz
+
+TUPLE: xyza x y z alpha ;
+
+C: <xyza> xyza
+
+<PRIVATE
+
+CONSTANT: xyz_epsilon 216/24389
+CONSTANT: xyz_kappa 24389/27
+
+CONSTANT: wp_x 0.95047
+CONSTANT: wp_y 1.00000
+CONSTANT: wp_z 1.08883
+
+: srgb-compand ( v -- v' )
+ dup 0.0031308 <= [ 12.92 * ] [ 2.4 recip ^ 1.055 * 0.055 - ] if ;
+
+PRIVATE>
+
+M: xyza >rgba
+ [
+ [let
+ [ x>> ] [ y>> ] [ z>> ] tri :> ( x y z )
+ x 3.2404542 * y -1.5371385 * z -0.4985314 * + +
+ x -0.9692660 * y 1.8760108 * z 0.0415560 * + +
+ x 0.0556434 * y -0.2040259 * z 1.0572252 * + +
+ [ srgb-compand 0.0 1.0 clamp ] tri@
+ ]
+ ] [ alpha>> ] bi <rgba> ;
+
+GENERIC: >xyza ( color -- xyza )
+
+M: object >xyza >rgba >xyza ;
+
+M: xyza >xyza ; inline
+
+<PRIVATE
+
+: invert-rgb-compand ( v -- v' )
+ dup 0.04045 <= [ 12.92 / ] [ 0.055 + 1.055 / 2.4 ^ ] if ;
+
+PRIVATE>
+
+M: rgba >xyza
+ [
+ [let
+ [ red>> ] [ green>> ] [ blue>> ] tri
+ [ invert-rgb-compand ] tri@ :> ( r g b )
+ r 0.4124564 * g 0.3575761 * b 0.1804375 * + +
+ r 0.2126729 * g 0.7151522 * b 0.0721750 * + +
+ r 0.0193339 * g 0.1191920 * b 0.9503041 * + +
+ ]
+ ] [ alpha>> ] bi <xyza> ;
--- /dev/null
+John Benediktsson
--- /dev/null
+YIQ colors
--- /dev/null
+USING: help.markup help.syntax ;
+IN: colors.yiq
+
+HELP: yiqa
+{ $class-description "The class of YIQ (Y, In-Place, Quadrature) colors with an alpha channel. All slots store values in the interval " { $snippet "[0,1]" } "." } ;
+
+ARTICLE: "colors.yiq" "YIQ colors"
+"The " { $vocab-link "colors.yiq" } " vocabulary implements colors specified by their Y, in-place, and quadrature components, together with an alpha channel."
+{ $subsections
+ yiqa
+ <yiqa>
+ >yiqa
+}
+{ $see-also "colors" } ;
+
+ABOUT: "colors.yiq"
--- /dev/null
+! Copyright (C) 2013 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays colors colors.yiq kernel locals math.functions
+math.ranges sequences tools.test ;
+
+{ t } [
+ 0.0 1.0 0.1 <range> [| r |
+ 0.0 1.0 0.1 <range> [| g |
+ 0.0 1.0 0.1 <range> [| b |
+ r g b 1.0 <rgba> dup >yiqa >rgba
+ [ >rgba-components 4array ] bi@
+ [ 0.00000001 ~ ] 2all?
+ ] all?
+ ] all?
+ ] all?
+] unit-test
--- /dev/null
+! Copyright (C) 2012 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors combinators kernel locals math
+math.order ;
+
+IN: colors.yiq
+
+TUPLE: yiqa < color
+{ y read-only }
+{ in-phase read-only }
+{ quadrature read-only }
+{ alpha read-only } ;
+
+C: <yiqa> yiqa
+
+M: yiqa >rgba
+ {
+ [ y>> ] [ in-phase>> ] [ quadrature>> ] [ alpha>> ]
+ } cleave [
+ [ [ 0.9468822170900693 * ] [ 0.6235565819861433 * ] bi* + + ]
+ [ [ 0.27478764629897834 * ] [ 0.6356910791873801 * ] bi* + - ]
+ [ [ 1.1085450346420322 * ] [ 1.7090069284064666 * ] bi* - - ]
+ 3tri [ 0.0 1.0 clamp ] tri@
+ ] dip <rgba> ; inline
+
+GENERIC: >yiqa ( color -- yiqa )
+
+M: object >yiqa >rgba >yiqa ;
+
+M: yiqa >yiqa ; inline
+
+M:: rgba >yiqa ( rgba -- yiqa )
+ rgba >rgba-components :> ( r g b a )
+ 0.30 r * 0.59 g * 0.11 b * + + :> y
+ r y - :> r-y
+ b y - :> b-y
+ 0.74 r-y * 0.27 b-y * - :> i
+ 0.48 r-y * 0.41 b-y * + :> q
+ y i q a <yiqa> ;
--- /dev/null
+John Benediktsson
--- /dev/null
+YUV colors
--- /dev/null
+USING: help.markup help.syntax ;
+IN: colors.yuv
+
+HELP: yuva
+{ $class-description "The class of YUV colors with an alpha channel." } ;
+
+ARTICLE: "colors.yuv" "YUV colors"
+"The " { $vocab-link "colors.yuv" } " vocabulary implements colors specified by their Y', U, and V components, together with an alpha channel."
+{ $subsections
+ yuva
+ <yuva>
+ >yuva
+}
+{ $see-also "colors" } ;
+
+ABOUT: "colors.yuv"
--- /dev/null
+! Copyright (C) 2013 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays colors colors.yuv kernel locals math.functions
+math.ranges sequences tools.test ;
+
+{ t } [
+ 0.0 1.0 0.1 <range> [| r |
+ 0.0 1.0 0.1 <range> [| g |
+ 0.0 1.0 0.1 <range> [| b |
+ r g b 1.0 <rgba> dup >yuva >rgba
+ [ >rgba-components 4array ] bi@
+ [ 0.00000001 ~ ] 2all?
+ ] all?
+ ] all?
+ ] all?
+] unit-test
--- /dev/null
+! Copyright (C) 2013 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors combinators kernel locals math
+math.order ;
+
+IN: colors.yuv
+
+TUPLE: yuva < color
+{ y read-only }
+{ u read-only }
+{ v read-only }
+{ alpha read-only } ;
+
+C: <yuva> yuva
+
+<PRIVATE
+
+CONSTANT: Wr 0.299
+CONSTANT: Wb 0.114
+CONSTANT: Wg 0.587
+CONSTANT: Umax 0.436
+CONSTANT: Vmax 0.615
+
+PRIVATE>
+
+M: yuva >rgba
+ { [ y>> ] [ u>> ] [ v>> ] [ alpha>> ] } cleave
+ [| y u v |
+ y 1 Wr - Vmax / v * +
+
+ y
+ Wb 1 Wb - * Umax Wg * / neg u *
+ Wr 1 Wr - * Vmax Wg * / neg v * + +
+
+ y 1 Wb - Umax / u * +
+
+ [ 0.0 1.0 clamp ] tri@
+ ] dip <rgba> ; inline
+
+GENERIC: >yuva ( color -- yuva )
+
+M: object >yuva >rgba >yuva ;
+
+M: yuva >yuva ; inline
+
+M:: rgba >yuva ( rgba -- yuva )
+ rgba >rgba-components :> ( r g b a )
+ Wr r * Wg g * Wb b * + + :> y
+ Umax 1 Wb - / b y - * :> u
+ Vmax 1 Wr - / r y - * :> v
+ y u v a <yuva> ;
+++ /dev/null
-John Benediktsson
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: colors.cmyk
-
-HELP: cmyka
-{ $class-description "The class of CMYK (Cyan, Magenta, Yellow, Black) colors with an alpha channel. All slots store values in the interval " { $snippet "[0,1]" } "." } ;
-
-ARTICLE: "colors.cmyk" "CMYK colors"
-"The " { $vocab-link "colors.cmyk" } " vocabulary implements colors specified by their cyan, magenta, yellow, and black components, together with an alpha channel."
-{ $subsections
- cmyka
- <cmyka>
- >cmyka
-}
-{ $see-also "colors" } ;
-
-ABOUT: "colors.cmyk"
+++ /dev/null
-! Copyright (C) 2013 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: arrays colors colors.cmyk kernel locals math.functions
-math.ranges sequences tools.test ;
-
-{ t } [
- 0.0 1.0 0.1 <range> [| r |
- 0.0 1.0 0.1 <range> [| g |
- 0.0 1.0 0.1 <range> [| b |
- r g b 1.0 <rgba> dup >cmyka >rgba
- [ >rgba-components 4array ] bi@
- [ 0.00000001 ~ ] 2all?
- ] all?
- ] all?
- ] all?
-] unit-test
+++ /dev/null
-! Copyright (C) 2012 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: accessors combinators colors colors.gray kernel math
-math.order ;
-
-IN: colors.cmyk
-
-TUPLE: cmyka < color
-{ cyan read-only }
-{ magenta read-only }
-{ yellow read-only }
-{ black read-only }
-{ alpha read-only } ;
-
-C: <cmyka> cmyka
-
-M: cmyka >rgba
- [ [ cyan>> ] [ black>> ] bi + ]
- [ [ magenta>> ] [ black>> ] bi + ]
- [ [ yellow>> ] [ black>> ] bi + ] tri
- [ 1.0 min 1.0 swap - ] tri@ 1.0 <rgba> ; inline
-
-GENERIC: >cmyka ( color -- cmyka )
-
-M: object >cmyka >rgba >cmyka ;
-
-M: rgba >cmyka
- >rgba-components [
- [ 1 swap - ] tri@ 3dup min min
- [ [ - 0.0 1.0 clamp ] curry tri@ ] keep
- ] dip <cmyka> ;
-
-M: cmyka >gray
- [
- {
- [ cyan>> 0.3 * ]
- [ magenta>> 0.59 * ]
- [ yellow>> 0.11 * ]
- [ black>> ]
- } cleave + + + 1.0 min 1.0 swap -
- ] [ alpha>> ] bi <gray> ;
+++ /dev/null
-CMYK colors
+++ /dev/null
-John Benediktsson
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: colors.hsl
-
-HELP: hsla
-{ $class-description "The class of HSL (Hue, Saturation, Lightness) colors with an alpha channel. All slots store values in the interval " { $snippet "[0,1]" } "." } ;
-
-ARTICLE: "colors.hsl" "HSL colors"
-"The " { $vocab-link "colors.hsl" } " vocabulary implements colors specified by their hue, saturation, and lightness components, together with an alpha channel."
-{ $subsections
- hsla
- <hsla>
- >hsla
-}
-{ $see-also "colors" } ;
-
-ABOUT: "colors.hsl"
+++ /dev/null
-! Copyright (C) 2013 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: arrays colors colors.hsl kernel locals math.functions
-math.ranges sequences tools.test ;
-
-{ t } [
- 0.0 1.0 0.1 <range> [| r |
- 0.0 1.0 0.1 <range> [| g |
- 0.0 1.0 0.1 <range> [| b |
- r g b 1.0 <rgba> dup >hsla >rgba
- [ >rgba-components 4array ] bi@
- [ 0.00000001 ~ ] 2all?
- ] all?
- ] all?
- ] all?
-] unit-test
+++ /dev/null
-! Copyright (C) 2012 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: accessors colors combinators kernel locals math
-math.order ;
-
-IN: colors.hsl
-
-TUPLE: hsla < color
-{ hue read-only }
-{ saturation read-only }
-{ lightness read-only }
-{ alpha read-only } ;
-
-C: <hsla> hsla
-
-<PRIVATE
-
-: value ( p q t -- value )
- dup 0 < [ 1.0 + ] when
- dup 1 > [ 1.0 - ] when
- {
- { [ dup 1/6 < ] [ [ over - ] dip * 6 * + ] }
- { [ dup 1/2 < ] [ drop nip ] }
- { [ dup 2/3 < ] [ [ over - ] dip 2/3 swap - * 6 * + ] }
- [ 2drop ]
- } cond ;
-
-PRIVATE>
-
-M: hsla >rgba
- {
- [ hue>> ] [ saturation>> ] [ lightness>> ] [ alpha>> ]
- } cleave [| h s l |
- s zero? [
- l l l
- ] [
- l 0.5 < [ l s 1 + * ] [ l s + l s * - ] if :> q
- l 2 * q - :> p
- p q h 1/3 + value
- p q h value
- p q h 1/3 - value
- ] if
- ] dip <rgba> ; inline
-
-GENERIC: >hsla ( color -- hsla )
-
-M: object >hsla >rgba >hsla ;
-
-M: hsla >hsla ; inline
-
-M: rgba >hsla
- >rgba-components [| r g b |
- r g b min min :> min-c
- r g b max max :> max-c
- min-c max-c + 2 / :> l
- max-c min-c - :> d
- d zero? [ 0.0 0.0 ] [
- max-c {
- { r [ g b - d / g b < 6.0 0.0 ? + ] }
- { g [ b r - d / 2.0 + ] }
- { b [ r g - d / 4.0 + ] }
- } case 6.0 /
- l 0.5 > [
- d 2 max-c - min-c - /
- ] [
- d max-c min-c + /
- ] if
- ] if l
- ] dip <hsla> ;
+++ /dev/null
-HSL colors
+++ /dev/null
-John Benediktsson
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: colors.lab
-
-HELP: laba
-{ $class-description "The class of CIE 1976 LAB (commonly called CIELAB) colors with an alpha channel." } ;
-
-ARTICLE: "colors.lab" "CIE 1976 LAB colors"
-"The " { $vocab-link "colors.lab" } " vocabulary implements CIE 1976 LAB colors, specifying luminance (in approximately " { $snippet "[0,100]" } "), red/green, and blue/yellow components, together with an alpha channel."
-{ $subsections
- laba
- <laba>
- >laba
-}
-"For more information, see " { $url "https://en.wikipedia.org/wiki/Lab_color_space" }
-{ $see-also "colors" } ;
-
-ABOUT: "colors.lab"
+++ /dev/null
-! Copyright (C) 2014 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: arrays colors colors.lab kernel locals math.functions
-math.ranges sequences tools.test ;
-
-{ t } [
- 0.0 1.0 0.1 <range> [| r |
- 0.0 1.0 0.1 <range> [| g |
- 0.0 1.0 0.1 <range> [| b |
- r g b 1.0 <rgba> dup >laba >rgba
- [ >rgba-components 4array ] bi@
- [ 0.00001 ~ ] 2all?
- ] all?
- ] all?
- ] all?
-] unit-test
+++ /dev/null
-! Copyright (C) 2014 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: accessors colors colors.xyz colors.xyz.private kernel
-locals math math.functions ;
-
-IN: colors.lab
-
-TUPLE: laba l a b alpha ;
-
-C: <laba> laba
-
-M: laba >rgba >xyza >rgba ;
-
-M: laba >xyza
- [
- [let
- [ l>> ] [ a>> ] [ b>> ] tri :> ( l a b )
- l 16 + 116 / :> fy
- a 500 / fy + :> fx
- fy b 200 / - :> fz
-
- fx 3 ^ :> fx3
- fz 3 ^ :> fz3
-
- fx3 xyz_epsilon > [
- fx3
- ] [
- 116 fx * 16 - xyz_kappa /
- ] if :> x
-
- l xyz_kappa xyz_epsilon * > [
- l 16 + 116 / 3 ^
- ] [
- l xyz_kappa /
- ] if :> y
-
- fz3 xyz_epsilon > [
- fz3
- ] [
- 116 fz * 16 - xyz_kappa /
- ] if :> z
-
- x wp_x * y wp_y * z wp_z *
- ]
- ] [ alpha>> ] bi <xyza> ;
-
-GENERIC: >laba ( color -- laba )
-
-M: object >laba >rgba >laba ;
-
-M: rgba >laba >xyza >laba ;
-
-M: xyza >laba
- [
- [let
- [ x>> wp_x / ] [ y>> wp_y / ] [ z>> wp_z / ] tri
- [
- dup xyz_epsilon >
- [ 1/3 ^ ] [ xyz_kappa * 16 + 116 / ] if
- ] tri@ :> ( fx fy fz )
- 116 fy * 16 -
- 500 fx fy - *
- 200 fy fz - *
- ]
- ] [ alpha>> ] bi <laba> ;
+++ /dev/null
-CIE 1976 LAB colors
+++ /dev/null
-John Benediktsson
+++ /dev/null
-! Copyright (C) 2014 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: arrays colors colors.lch kernel locals math.functions
-math.ranges sequences tools.test ;
-
-{ t } [
- 0.0 1.0 0.1 <range> [| r |
- 0.0 1.0 0.1 <range> [| g |
- 0.0 1.0 0.1 <range> [| b |
- r g b 1.0 <rgba> dup >LCHuv >rgba
- [ >rgba-components 4array ] bi@
- [ 0.00001 ~ ] 2all?
- ] all?
- ] all?
- ] all?
-] unit-test
-
-{ t } [
- 0.0 1.0 0.1 <range> [| r |
- 0.0 1.0 0.1 <range> [| g |
- 0.0 1.0 0.1 <range> [| b |
- r g b 1.0 <rgba> dup >LCHab >rgba
- [ >rgba-components 4array ] bi@
- [ 0.00001 ~ ] 2all?
- ] all?
- ] all?
- ] all?
-] unit-test
+++ /dev/null
-! Copyright (C) 2014 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: accessors colors colors.lab colors.luv colors.xyz kernel
-locals math math.functions math.libm math.trig ;
-
-IN: colors.lch
-
-TUPLE: LCHuv l c h alpha ;
-
-C: <LCHuv> LCHuv
-
-M: LCHuv >rgba >luva >rgba ;
-
-M: LCHuv >xyza >luva >xyza ;
-
-M: LCHuv >luva
- [
- [let
- [ l>> ] [ c>> ] [ h>> ] tri :> ( l c h )
- h deg>rad :> hr
-
- l
- c hr cos *
- c hr sin *
- ]
- ] [ alpha>> ] bi <luva> ;
-
-GENERIC: >LCHuv ( color -- LCHuv )
-
-M: object >LCHuv >luva >LCHuv ;
-
-M: LCHuv >LCHuv ; inline
-
-M: luva >LCHuv
- [
- [let
- [ l>> ] [ u>> ] [ v>> ] tri :> ( l u v )
- v u fatan2 rad>deg
- [ dup 360 > ] [ 360 - ] while
- [ dup 0 < ] [ 360 + ] while :> h
-
- l
- u sq v sq + sqrt
- h
- ]
- ] [ alpha>> ] bi <LCHuv> ;
-
-TUPLE: LCHab l c h alpha ;
-
-C: <LCHab> LCHab
-
-M: LCHab >rgba >laba >rgba ;
-
-M: LCHab >laba
- [
- [let
- [ l>> ] [ c>> ] [ h>> ] tri :> ( l c h )
- h deg>rad :> hr
-
- l
- c hr cos *
- c hr sin *
- ]
- ] [ alpha>> ] bi <laba> ;
-
-GENERIC: >LCHab ( color -- LCHab )
-
-M: object >LCHab >laba >LCHab ;
-
-M: LCHab >LCHab ; inline
-
-M: laba >LCHab
- [
- [let
- [ l>> ] [ a>> ] [ b>> ] tri :> ( l a b )
- b a fatan2 rad>deg
- [ dup 360 > ] [ 360 - ] while
- [ dup 0 < ] [ 360 + ] while :> h
-
- l
- a sq b sq + sqrt
- h
- ]
- ] [ alpha>> ] bi <LCHab> ;
+++ /dev/null
-CIELCH colors
+++ /dev/null
-John Benediktsson
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: colors.luv
-
-HELP: luva
-{ $class-description "The class of CIE 1976 LUV (commonly called CIELUV) colors with an alpha channel." } ;
-
-ARTICLE: "colors.luv" "CIE 1976 LUV colors"
-"The " { $vocab-link "colors.luv" } " vocabulary implements CIE 1976 LUV colors, together with an alpha channel."
-{ $subsections
- luva
- <luva>
- >luva
-}
-"For more information, see " { $url "https://en.wikipedia.org/wiki/CIELUV_color_space" }
-{ $see-also "colors" } ;
-
-ABOUT: "colors.luv"
+++ /dev/null
-! Copyright (C) 2014 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: arrays colors colors.luv kernel locals math.functions
-math.ranges sequences tools.test ;
-
-{ t } [
- 0.0 1.0 0.1 <range> [| r |
- 0.0 1.0 0.1 <range> [| g |
- 0.0 1.0 0.1 <range> [| b |
- r g b 1.0 <rgba> dup >luva >rgba
- [ >rgba-components 4array ] bi@
- [ 0.00001 ~ ] 2all?
- ] all?
- ] all?
- ] all?
-] unit-test
+++ /dev/null
-! Copyright (C) 2014 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: accessors colors colors.xyz colors.xyz.private kernel
-locals math math.functions ;
-
-IN: colors.luv
-
-TUPLE: luva l u v alpha ;
-
-C: <luva> luva
-
-<PRIVATE
-
-:: xyz-to-uv ( x y z -- u v )
- x y 15 * z 3 * + + :> d
- 4 x * d /
- 9 y * d / ; foldable
-
-PRIVATE>
-
-M: luva >rgba >xyza >rgba ;
-
-M: luva >xyza
- [
- [let
- wp_x wp_y wp_z xyz-to-uv :> ( u_wp v_wp )
- [ l>> ] [ u>> ] [ v>> ] tri :> ( l u v )
-
- 52 l * 13 l * u_wp * u + / 1 - 3 / :> a
- l xyz_kappa xyz_epsilon * > [
- l 16 + 116 / 3 ^ wp_y *
- ] [
- l xyz_kappa / wp_y *
- ] if :> y
- y -5 * :> b
- 39 l * 13 l * v_wp * v + / 5 - y * :> d
- d b - a 1/3 + / :> x
- a x * b + :> z
-
- x y z
- ]
- ] [ alpha>> ] bi <xyza> ;
-
-GENERIC: >luva ( color -- luva )
-
-M: object >luva >rgba >luva ;
-
-M: rgba >luva >xyza >luva ;
-
-M: luva >luva ; inline
-
-M: xyza >luva
- [
- [let
- wp_x wp_y wp_z xyz-to-uv :> ( u_wp v_wp )
- [ x>> ] [ y>> ] [ z>> ] tri :> ( x_ y_ z_ )
- x_ y_ z_ xyz-to-uv :> ( u_ v_ )
-
- y_ wp_y / :> y
-
- y xyz_epsilon > [
- y 1/3 ^ 116 * 16 -
- ] [
- xyz_kappa y *
- ] if :> l
- 13 l * u_ u_wp - * :> u
- 13 l * v_ v_wp - * :> v
-
- l u v
- ]
- ] [ alpha>> ] bi <luva> ;
+++ /dev/null
-CIE 1976 LUV colors
+++ /dev/null
-John Benediktsson
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: colors.ryb
-
-HELP: ryba
-{ $class-description "The class of RYB (Red, Yellow, Blue) colors with an alpha channel. All slots store values in the interval " { $snippet "[0,1]" } "." } ;
-
-ARTICLE: "colors.ryb" "RYB colors"
-"The " { $vocab-link "colors.ryb" } " vocabulary implements colors specified by their red, yellow, and blue components, together with an alpha channel."
-{ $subsections
- ryba
- <ryba>
- >ryba
-}
-{ $see-also "colors" } ;
-
-ABOUT: "colors.ryb"
+++ /dev/null
-! Copyright (C) 2013 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: arrays colors colors.ryb kernel locals math.functions
-math.ranges sequences tools.test ;
-
-{ t } [
- 0.0 1.0 0.1 <range> [| r |
- 0.0 1.0 0.1 <range> [| g |
- 0.0 1.0 0.1 <range> [| b |
- r g b 1.0 <rgba> dup >ryba >rgba
- [ >rgba-components 4array ] bi@
- [ 0.00000001 ~ ] 2all?
- ] all?
- ] all?
- ] all?
-] unit-test
+++ /dev/null
-! Copyright (C) 2013 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: accessors colors kernel locals math math.order ;
-
-IN: colors.ryb
-
-TUPLE: ryba < color
- { red read-only }
- { yellow read-only }
- { blue read-only }
- { alpha read-only } ;
-
-C: <ryba> ryba
-
-<PRIVATE
-
-: normalized ( a b c quot: ( a b c -- a' b' c' ) -- a' b' c' )
- [ 3dup min min ] dip over
- [ [ - ] curry tri@ ]
- [ call ]
- [ [ + ] curry tri@ ] tri* ; inline
-
-:: ryb>rgb ( r! y! b! -- r g b )
- r y b max max :> my
-
- y b min :> g!
- y g - y!
- b g - b!
-
- b g [ 0 > ] both? [
- b 2 * b!
- g 2 * g!
- ] when
-
- r y + r!
- g y + g!
-
- r g b 3dup max max [
- my swap / [ * ] curry tri@
- ] unless-zero ;
-
-:: rgb>ryb ( r! g! b! -- r y b )
- r g b max max :> mg
-
- r g min :> y!
- r y - r!
- g y - g!
-
- b g [ 0 > ] both? [
- b 2 /f b!
- g 2 /f g!
- ] when
-
- y g + y!
- b g + b!
-
- r y b 3dup max max [
- mg swap / [ * ] curry tri@
- ] unless-zero ;
-
-PRIVATE>
-
-M: ryba >rgba ( ryba -- rgba )
- [
- [ red>> ] [ yellow>> ] [ blue>> ] tri
- [ ryb>rgb ] normalized
- ] [ alpha>> ] bi <rgba> ;
-
-GENERIC: >ryba ( color -- ryba )
-
-M: object >ryba >rgba >ryba ;
-
-M: ryba >ryba ; inline
-
-M: rgba >ryba
- >rgba-components [ [ rgb>ryb ] normalized ] [ <ryba> ] bi* ;
+++ /dev/null
-RYB colors
+++ /dev/null
-John Benediktsson
+++ /dev/null
-CIE 1931 xyY colors
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: colors.xyy
-
-HELP: xyYa
-{ $class-description "The class of CIE 1931 xyY colors with an alpha channel." } ;
-
-ARTICLE: "colors.xyy" "CIE 1931 xyY colors"
-"The " { $vocab-link "colors.xyy" } " vocabulary implements CIE 1931 xyY colors, together with an alpha channel."
-{ $subsections
- xyYa
- <xyYa>
- >xyYa
-}
-"For more information, see " { $url "https://en.wikipedia.org/wiki/CIE_1931_color_space" }
-{ $see-also "colors" } ;
-
-ABOUT: "colors.xyy"
+++ /dev/null
-! Copyright (C) 2014 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: arrays colors colors.xyy kernel locals math.functions
-math.ranges sequences tools.test ;
-
-{ t } [
- 0.0 1.0 0.1 <range> [| r |
- 0.0 1.0 0.1 <range> [| g |
- 0.0 1.0 0.1 <range> [| b |
- r g b 1.0 <rgba> dup >xyYa >rgba
- [ >rgba-components 4array ] bi@
- [ 0.00001 ~ ] 2all?
- ] all?
- ] all?
- ] all?
-] unit-test
+++ /dev/null
-! Copyright (C) 2014 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: accessors colors colors.xyz kernel locals math ;
-
-IN: colors.xyy
-
-TUPLE: xyYa x y Y alpha ;
-
-C: <xyYa> xyYa
-
-M: xyYa >rgba
- >xyza >rgba ;
-
-M: xyYa >xyza
- [
- [let
- [ x>> ] [ y>> ] [ Y>> ] tri :> ( x y Y )
- x y / Y *
- Y
- 1 x - y - y / Y *
- ]
- ] [ alpha>> ] bi <xyza> ;
-
-GENERIC: >xyYa ( color -- xyYa )
-
-M: object >xyYa >xyza >xyYa ;
-
-M: xyYa >xyYa ; inline
-
-M: xyza >xyYa
- [
- [let
- [ x>> ] [ y>> ] [ z>> ] tri :> ( x y z )
- x y z + +
- [ x swap / ]
- [ y swap / ] bi
- y
- ]
- ] [ alpha>> ] bi <xyYa> ;
+++ /dev/null
-John Benediktsson
+++ /dev/null
-CIE 1931 XYZ colors
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: colors.xyz
-
-HELP: xyza
-{ $class-description "The class of CIE 1931 XYZ colors with an alpha channel." } ;
-
-ARTICLE: "colors.xyz" "CIE 1931 XYZ colors"
-"The " { $vocab-link "colors.xyz" } " vocabulary implements CIE 1931 XYZ colors, together with an alpha channel."
-{ $subsections
- xyza
- <xyza>
- >xyza
-}
-"For more information, see " { $url "https://en.wikipedia.org/wiki/CIE_1931_color_space" }
-{ $see-also "colors" } ;
-
-ABOUT: "colors.xyz"
+++ /dev/null
-! Copyright (C) 2014 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: arrays colors colors.xyz kernel locals math.functions
-math.ranges sequences tools.test ;
-
-{ t } [
- 0.0 1.0 0.1 <range> [| r |
- 0.0 1.0 0.1 <range> [| g |
- 0.0 1.0 0.1 <range> [| b |
- r g b 1.0 <rgba> dup >xyza >rgba
- [ >rgba-components 4array ] bi@
- [ 0.00001 ~ ] 2all?
- ] all?
- ] all?
- ] all?
-] unit-test
+++ /dev/null
-! Copyright (C) 2014 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: accessors colors kernel locals math math.functions
-math.order ;
-
-IN: colors.xyz
-
-TUPLE: xyza x y z alpha ;
-
-C: <xyza> xyza
-
-<PRIVATE
-
-CONSTANT: xyz_epsilon 216/24389
-CONSTANT: xyz_kappa 24389/27
-
-CONSTANT: wp_x 0.95047
-CONSTANT: wp_y 1.00000
-CONSTANT: wp_z 1.08883
-
-: srgb-compand ( v -- v' )
- dup 0.0031308 <= [ 12.92 * ] [ 2.4 recip ^ 1.055 * 0.055 - ] if ;
-
-PRIVATE>
-
-M: xyza >rgba
- [
- [let
- [ x>> ] [ y>> ] [ z>> ] tri :> ( x y z )
- x 3.2404542 * y -1.5371385 * z -0.4985314 * + +
- x -0.9692660 * y 1.8760108 * z 0.0415560 * + +
- x 0.0556434 * y -0.2040259 * z 1.0572252 * + +
- [ srgb-compand 0.0 1.0 clamp ] tri@
- ]
- ] [ alpha>> ] bi <rgba> ;
-
-GENERIC: >xyza ( color -- xyza )
-
-M: object >xyza >rgba >xyza ;
-
-M: xyza >xyza ; inline
-
-<PRIVATE
-
-: invert-rgb-compand ( v -- v' )
- dup 0.04045 <= [ 12.92 / ] [ 0.055 + 1.055 / 2.4 ^ ] if ;
-
-PRIVATE>
-
-M: rgba >xyza
- [
- [let
- [ red>> ] [ green>> ] [ blue>> ] tri
- [ invert-rgb-compand ] tri@ :> ( r g b )
- r 0.4124564 * g 0.3575761 * b 0.1804375 * + +
- r 0.2126729 * g 0.7151522 * b 0.0721750 * + +
- r 0.0193339 * g 0.1191920 * b 0.9503041 * + +
- ]
- ] [ alpha>> ] bi <xyza> ;
+++ /dev/null
-John Benediktsson
+++ /dev/null
-YIQ colors
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: colors.yiq
-
-HELP: yiqa
-{ $class-description "The class of YIQ (Y, In-Place, Quadrature) colors with an alpha channel. All slots store values in the interval " { $snippet "[0,1]" } "." } ;
-
-ARTICLE: "colors.yiq" "YIQ colors"
-"The " { $vocab-link "colors.yiq" } " vocabulary implements colors specified by their Y, in-place, and quadrature components, together with an alpha channel."
-{ $subsections
- yiqa
- <yiqa>
- >yiqa
-}
-{ $see-also "colors" } ;
-
-ABOUT: "colors.yiq"
+++ /dev/null
-! Copyright (C) 2013 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: arrays colors colors.yiq kernel locals math.functions
-math.ranges sequences tools.test ;
-
-{ t } [
- 0.0 1.0 0.1 <range> [| r |
- 0.0 1.0 0.1 <range> [| g |
- 0.0 1.0 0.1 <range> [| b |
- r g b 1.0 <rgba> dup >yiqa >rgba
- [ >rgba-components 4array ] bi@
- [ 0.00000001 ~ ] 2all?
- ] all?
- ] all?
- ] all?
-] unit-test
+++ /dev/null
-! Copyright (C) 2012 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: accessors colors combinators kernel locals math
-math.order ;
-
-IN: colors.yiq
-
-TUPLE: yiqa < color
-{ y read-only }
-{ in-phase read-only }
-{ quadrature read-only }
-{ alpha read-only } ;
-
-C: <yiqa> yiqa
-
-M: yiqa >rgba
- {
- [ y>> ] [ in-phase>> ] [ quadrature>> ] [ alpha>> ]
- } cleave [
- [ [ 0.9468822170900693 * ] [ 0.6235565819861433 * ] bi* + + ]
- [ [ 0.27478764629897834 * ] [ 0.6356910791873801 * ] bi* + - ]
- [ [ 1.1085450346420322 * ] [ 1.7090069284064666 * ] bi* - - ]
- 3tri [ 0.0 1.0 clamp ] tri@
- ] dip <rgba> ; inline
-
-GENERIC: >yiqa ( color -- yiqa )
-
-M: object >yiqa >rgba >yiqa ;
-
-M: yiqa >yiqa ; inline
-
-M:: rgba >yiqa ( rgba -- yiqa )
- rgba >rgba-components :> ( r g b a )
- 0.30 r * 0.59 g * 0.11 b * + + :> y
- r y - :> r-y
- b y - :> b-y
- 0.74 r-y * 0.27 b-y * - :> i
- 0.48 r-y * 0.41 b-y * + :> q
- y i q a <yiqa> ;
+++ /dev/null
-John Benediktsson
+++ /dev/null
-YUV colors
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: colors.yuv
-
-HELP: yuva
-{ $class-description "The class of YUV colors with an alpha channel." } ;
-
-ARTICLE: "colors.yuv" "YUV colors"
-"The " { $vocab-link "colors.yuv" } " vocabulary implements colors specified by their Y', U, and V components, together with an alpha channel."
-{ $subsections
- yuva
- <yuva>
- >yuva
-}
-{ $see-also "colors" } ;
-
-ABOUT: "colors.yuv"
+++ /dev/null
-! Copyright (C) 2013 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: arrays colors colors.yuv kernel locals math.functions
-math.ranges sequences tools.test ;
-
-{ t } [
- 0.0 1.0 0.1 <range> [| r |
- 0.0 1.0 0.1 <range> [| g |
- 0.0 1.0 0.1 <range> [| b |
- r g b 1.0 <rgba> dup >yuva >rgba
- [ >rgba-components 4array ] bi@
- [ 0.00000001 ~ ] 2all?
- ] all?
- ] all?
- ] all?
-] unit-test
+++ /dev/null
-! Copyright (C) 2013 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: accessors colors combinators kernel locals math
-math.order ;
-
-IN: colors.yuv
-
-TUPLE: yuva < color
-{ y read-only }
-{ u read-only }
-{ v read-only }
-{ alpha read-only } ;
-
-C: <yuva> yuva
-
-<PRIVATE
-
-CONSTANT: Wr 0.299
-CONSTANT: Wb 0.114
-CONSTANT: Wg 0.587
-CONSTANT: Umax 0.436
-CONSTANT: Vmax 0.615
-
-PRIVATE>
-
-M: yuva >rgba
- { [ y>> ] [ u>> ] [ v>> ] [ alpha>> ] } cleave
- [| y u v |
- y 1 Wr - Vmax / v * +
-
- y
- Wb 1 Wb - * Umax Wg * / neg u *
- Wr 1 Wr - * Vmax Wg * / neg v * + +
-
- y 1 Wb - Umax / u * +
-
- [ 0.0 1.0 clamp ] tri@
- ] dip <rgba> ; inline
-
-GENERIC: >yuva ( color -- yuva )
-
-M: object >yuva >rgba >yuva ;
-
-M: yuva >yuva ; inline
-
-M:: rgba >yuva ( rgba -- yuva )
- rgba >rgba-components :> ( r g b a )
- Wr r * Wg g * Wb b * + + :> y
- Umax 1 Wb - / b y - * :> u
- Vmax 1 Wr - / r y - * :> v
- y u v a <yuva> ;
projects / factor.git / commitdiff