basis/colors/hex/hex.factor

   1 ! Copyright (C) 2010 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors colors combinators formatting grouping kernel
   5 lexer math math.parser sequences vocabs.loader ;
   6
   7 IN: colors.hex
   8
   9 ERROR: invalid-hex-color hex ;
  10
  11 : hex>rgba ( hex -- rgba )
  12     dup length {
  13         { 6 [ 2 group [ hex> 255 /f ] map first3 1.0 ] }
  14         { 8 [ 2 group [ hex> 255 /f ] map first4 ] }
  15         { 3 [ [ digit> 15 /f ] { } map-as first3 1.0 ] }
  16         { 4 [ [ digit> 15 /f ] { } map-as first4 ] }
  17         [ drop invalid-hex-color ]
  18     } case <rgba> ;
  19
  20 : rgba>hex ( rgba -- hex )
  21     [ red>> ] [ green>> ] [ blue>> ] tri
  22     [ 255 * >integer ] tri@ "%02X%02X%02X" sprintf ;
  23
  24 TUPLE: hex-color < color hex value ;
  25
  26 M: hex-color >rgba value>> >rgba ;
  27
  28 SYNTAX: HEXCOLOR: scan-token dup hex>rgba hex-color boa suffix! ;
  29
  30 { "colors.hex" "prettyprint" } "colors.hex.prettyprint" require-when