basis/colors/colors.factor

   1 ! Copyright (C) 2003, 2009 Slava Pestov.
   2 ! Copyright (C) 2008 Eduardo Cavazos.
   3 ! See http://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 ;
   7 IN: colors
   8
   9 MIXIN: color
  10
  11 TUPLE: rgba
  12 { red read-only }
  13 { green read-only }
  14 { blue read-only }
  15 { alpha read-only } ;
  16
  17 C: <rgba> rgba
  18
  19 INSTANCE: rgba color
  20
  21 GENERIC: >rgba ( color -- rgba )
  22
  23 M: rgba >rgba ; inline
  24
  25 M: color red>> >rgba red>> ;
  26 M: color green>> >rgba green>> ;
  27 M: color blue>> >rgba blue>> ;
  28 M: color alpha>> >rgba alpha>> ;
  29
  30 : >rgba-components ( object -- r g b a )
  31     >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
  32
  33 : opaque? ( color -- ? ) alpha>> 1 number= ;
  34
  35 CONSTANT: transparent T{ rgba f 0.0 0.0 0.0 0.0 }
  36
  37 : inverse-color ( color -- color' )
  38     >rgba-components [ [ 1.0 swap - ] tri@ ] dip <rgba> ;
  39
  40 : color= ( color1 color2 -- ? )
  41     [ >rgba-components 4array ] bi@ [ 0.00000001 ~ ] 2all? ;
  42
  43 <PRIVATE
  44
  45 : parse-color ( line -- name color )
  46     first4 [ [ string>number 255 /f ] tri@ 1.0 <rgba> ] dip swap ;
  47
  48 : parse-colors ( lines -- assoc )
  49     [ "!" head? ] reject [
  50         [ blank? ] split-when harvest 3 cut "-" join suffix parse-color
  51     ] H{ } map>assoc ;
  52
  53 MEMO: colors ( -- assoc )
  54     {
  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"
  59     } [
  60         utf8 file-lines parse-colors
  61     ] [ assoc-union ] map-reduce ;
  62
  63 ERROR: invalid-hex-color hex ;
  64
  65 : hex>rgba ( hex -- rgba )
  66     dup length {
  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 ]
  72     } case <rgba> ;
  73
  74 : component>hex ( f -- s )
  75     255 * round >integer >hex
  76     2 CHAR: 0 pad-head ;
  77
  78 : (color>hex) ( seq -- hex )
  79     [ component>hex ] map concat
  80     "#" prepend ;
  81
  82 PRIVATE>
  83
  84 : color>hex ( color -- hex )
  85     [ >rgba-components 4array ] [ opaque? ] bi
  86     [ but-last ] when
  87     (color>hex) ;
  88
  89 : named-colors ( -- keys ) colors keys ;
  90
  91 ERROR: no-such-color name ;
  92
  93 : named-color ( name -- color )
  94     dup colors at [ ] [ no-such-color ] ?if ;
  95
  96 : parse-color ( str -- color )
  97     "#" ?head [ hex>rgba ] [ named-color ] if ;
  98
  99 TUPLE: parsed-color string value ;
 100
 101 INSTANCE: parsed-color color
 102
 103 M: parsed-color >rgba value>> >rgba ;
 104
 105 SYNTAX: COLOR: scan-token dup parse-color parsed-color boa suffix! ;
 106
 107 { "colors" "prettyprint" } "colors.prettyprint" require-when