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

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