1 ! Copyright (C) 2003, 2009 Slava Pestov.
2 ! Copyright (C) 2008 Eduardo Cavazos.
3 ! See https://factorcode.org/license.txt for BSD license.
4 USING: accessors ascii arrays assocs combinators grouping
5 io.encodings.utf8 io.files kernel lexer math math.functions
6 math.parser sequences splitting vocabs.loader ;
21 GENERIC: >rgba ( color -- rgba )
23 M: rgba >rgba ; inline
25 M: color red>> >rgba red>> ;
26 M: color green>> >rgba green>> ;
27 M: color blue>> >rgba blue>> ;
28 M: color alpha>> >rgba alpha>> ;
30 : >rgba-components ( object -- r g b a )
31 >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
33 : opaque? ( color -- ? ) alpha>> 1 number= ;
35 CONSTANT: transparent T{ rgba f 0.0 0.0 0.0 0.0 }
37 : inverse-color ( color -- color' )
38 >rgba-components [ [ 1.0 swap - ] tri@ ] dip <rgba> ;
40 : color= ( color1 color2 -- ? )
41 [ >rgba-components 4array ] bi@ [ 0.00000001 ~ ] 2all? ;
45 : parse-line ( line -- name color )
46 first4 [ [ string>number 255 /f ] tri@ 1.0 <rgba> ] dip swap ;
48 : parse-colors ( lines -- assoc )
49 [ "!" head? ] reject [
50 [ blank? ] split-when harvest 3 cut "-" join suffix parse-line
53 MEMO: colors ( -- assoc )
55 "resource:basis/colors/rgb.txt"
56 "resource:basis/colors/css-colors.txt"
57 "resource:basis/colors/factor-colors.txt"
58 "resource:basis/colors/solarized-colors.txt"
60 utf8 file-lines parse-colors
61 ] [ assoc-union ] map-reduce ;
63 ERROR: invalid-hex-color hex ;
65 : hex>rgba ( hex -- rgba )
67 { 6 [ 2 group [ hex> 255 /f ] map first3 1.0 ] }
68 { 8 [ 2 group [ hex> 255 /f ] map first4 ] }
69 { 3 [ [ digit> 15 /f ] { } map-as first3 1.0 ] }
70 { 4 [ [ digit> 15 /f ] { } map-as first4 ] }
71 [ drop invalid-hex-color ]
74 : component>hex ( f -- s )
75 255 * round >integer >hex
78 : (color>hex) ( seq -- hex )
79 [ component>hex ] map concat
84 : color>hex ( color -- hex )
85 [ >rgba-components 4array ] [ opaque? ] bi
89 : named-colors ( -- keys ) colors keys ;
91 ERROR: no-such-color name ;
93 : named-color ( name -- color )
94 [ colors at ] [ no-such-color ] ?unless ;
96 : parse-color ( str -- color )
97 "#" ?head [ hex>rgba ] [ named-color ] if ;
99 TUPLE: parsed-color string value ;
101 INSTANCE: parsed-color color
103 M: parsed-color >rgba value>> >rgba ;
105 SYNTAX: COLOR: scan-token dup parse-color parsed-color boa suffix! ;
107 { "colors" "prettyprint" } "colors.prettyprint" require-when