extra/io/streams/256color/256color.factor

   1 ! Copyright (C) 2012 John Benediktsson
   2 ! See https://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors arrays assocs combinators destructors
   5 environment formatting io io.streams.escape-codes
   6 io.streams.string io.styles kernel math math.functions
   7 math.order namespaces ranges sequences sorting strings
   8 strings.tables ;
   9
  10 IN: io.streams.256color
  11
  12 <PRIVATE
  13
  14 CONSTANT: intensities { 0x00 0x5F 0x87 0xAF 0xD7 0xFF }
  15
  16 CONSTANT: 256colors H{ }
  17
  18 ! Add the RGB colors
  19 intensities [| r i |
  20     intensities [| g j |
  21         intensities [| b k |
  22             i 36 * j 6 * + k + 16 +
  23             r g b 3array
  24             256colors set-at
  25         ] each-index
  26     ] each-index
  27 ] each-index
  28
  29 ! Add the Grayscale colors
  30 0x08 0xee 10 <range> [
  31     [ dup dup 3array ] dip 232 + swap
  32     256colors set-at
  33 ] each-index
  34
  35 : 256colors. ( -- )
  36     256colors sort-values [
  37         dup dup "\e[1;38;5;%sm%3s:\e[0m " printf
  38         dup rot first3 "\e[38;5;%sm#%02x%02x%02x\e[0m " printf
  39         6 mod 3 = [ nl ] when
  40     ] assoc-each ;
  41
  42 : color>rgb ( color -- r g b )
  43     [ red>> ] [ green>> ] [ blue>> ] tri
  44     [ 255 * round >integer ] tri@ ;
  45
  46 : gray? ( r g b -- ? )
  47     [ max max ] [ min min ] 3bi - 8 < ;
  48
  49 :: rgb>gray ( r g b -- color )
  50     {
  51         { [ r 0 4 between? ] [ 16 ] }
  52         { [ r 5 8 between? ] [ 232 ] }
  53         { [ r 238 246 between? ] [ 255 ] }
  54         { [ r 247 255 between? ] [ 231 ] }
  55         [ r 8 - 10 /i 232 + ]
  56     } cond ;
  57
  58 : rgb>256color ( r g b -- color )
  59     [ 55 - 40 /f 0 max round ] tri@
  60     [ 36 * ] [ 6 * + ] [ + ] tri* 16 + >integer ;
  61
  62 : color>256color ( color -- 256color )
  63     color>rgb 3dup gray? [ rgb>gray ] [ rgb>256color ] if ;
  64
  65 : color>foreground ( color -- string )
  66     color>256color "\e[38;5;%sm" sprintf ;
  67
  68 : color>background ( color -- string )
  69     color>256color "\e[48;5;%sm" sprintf ;
  70
  71 TUPLE: 256color < filter-writer ;
  72
  73 C: <256color> 256color
  74
  75 M:: 256color stream-format ( str style stream -- )
  76     stream stream>> :> out
  77     style foreground of [ color>foreground out stream-write t ] [ f ] if*
  78     style background of [ color>background out stream-write drop t ] when*
  79     style font-style of [ font-styles out stream-write drop t ] when*
  80     str out stream-write
  81     [ "\e[0m" out stream-write ] when ;
  82
  83 M: 256color make-span-stream
  84     swap <style-stream> <ignore-close-stream> ;
  85
  86 M: 256color make-block-stream
  87     swap <style-stream> <ignore-close-stream> ;
  88
  89 ! FIXME: color codes take up formatting space
  90
  91 M: 256color stream-write-table
  92     [
  93         drop
  94         [ [ stream>> >string ] map ] map format-table
  95         [ nl ] [ write ] interleave
  96     ] with-output-stream* ;
  97
  98 M: 256color make-cell-stream
  99     2drop <string-writer> <256color> ;
 100
 101 M: 256color dispose drop ;
 102
 103 PRIVATE>
 104
 105 : 256color-terminal? ( -- ? )
 106     "TERM" os-env "-256color" tail? ;
 107
 108 : with-256color ( quot -- )
 109     output-stream get <256color> swap with-output-stream* ; inline