432 lines
8.2 KiB
Scheme
432 lines
8.2 KiB
Scheme
(define-module (termenv color)
|
|
;; cross-platform is a pipe dream!
|
|
#:use-module (termenv unix)
|
|
#:use-module (ice-9 format)
|
|
#:use-module (ice-9 i18n)
|
|
#:use-module (ice-9 peg)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-9 gnu)
|
|
#:export (make-foreground
|
|
make-background
|
|
color-r
|
|
color-g
|
|
color-b
|
|
color?
|
|
|
|
current-color-profile
|
|
color->sequence
|
|
color->ansi
|
|
color->ansi-index
|
|
color->ansi256
|
|
color->ansi256-index
|
|
hex->color))
|
|
|
|
(define %ANSI-COLOR-NAMES
|
|
'(black
|
|
red
|
|
green
|
|
yellow
|
|
blue
|
|
magenta
|
|
cyan
|
|
white
|
|
bright-black
|
|
bright-red
|
|
bright-green
|
|
bright-yellow
|
|
bright-blue
|
|
bright-magenta
|
|
bright-cyan
|
|
bright-white))
|
|
|
|
(define %ANSI256-HEX
|
|
'("#000000"
|
|
"#800000"
|
|
"#008000"
|
|
"#808000"
|
|
"#000080"
|
|
"#800080"
|
|
"#008080"
|
|
"#c0c0c0"
|
|
"#808080"
|
|
"#ff0000"
|
|
"#00ff00"
|
|
"#ffff00"
|
|
"#0000ff"
|
|
"#ff00ff"
|
|
"#00ffff"
|
|
"#ffffff"
|
|
"#000000"
|
|
"#00005f"
|
|
"#000087"
|
|
"#0000af"
|
|
"#0000d7"
|
|
"#0000ff"
|
|
"#005f00"
|
|
"#005f5f"
|
|
"#005f87"
|
|
"#005faf"
|
|
"#005fd7"
|
|
"#005fff"
|
|
"#008700"
|
|
"#00875f"
|
|
"#008787"
|
|
"#0087af"
|
|
"#0087d7"
|
|
"#0087ff"
|
|
"#00af00"
|
|
"#00af5f"
|
|
"#00af87"
|
|
"#00afaf"
|
|
"#00afd7"
|
|
"#00afff"
|
|
"#00d700"
|
|
"#00d75f"
|
|
"#00d787"
|
|
"#00d7af"
|
|
"#00d7d7"
|
|
"#00d7ff"
|
|
"#00ff00"
|
|
"#00ff5f"
|
|
"#00ff87"
|
|
"#00ffaf"
|
|
"#00ffd7"
|
|
"#00ffff"
|
|
"#5f0000"
|
|
"#5f005f"
|
|
"#5f0087"
|
|
"#5f00af"
|
|
"#5f00d7"
|
|
"#5f00ff"
|
|
"#5f5f00"
|
|
"#5f5f5f"
|
|
"#5f5f87"
|
|
"#5f5faf"
|
|
"#5f5fd7"
|
|
"#5f5fff"
|
|
"#5f8700"
|
|
"#5f875f"
|
|
"#5f8787"
|
|
"#5f87af"
|
|
"#5f87d7"
|
|
"#5f87ff"
|
|
"#5faf00"
|
|
"#5faf5f"
|
|
"#5faf87"
|
|
"#5fafaf"
|
|
"#5fafd7"
|
|
"#5fafff"
|
|
"#5fd700"
|
|
"#5fd75f"
|
|
"#5fd787"
|
|
"#5fd7af"
|
|
"#5fd7d7"
|
|
"#5fd7ff"
|
|
"#5fff00"
|
|
"#5fff5f"
|
|
"#5fff87"
|
|
"#5fffaf"
|
|
"#5fffd7"
|
|
"#5fffff"
|
|
"#870000"
|
|
"#87005f"
|
|
"#870087"
|
|
"#8700af"
|
|
"#8700d7"
|
|
"#8700ff"
|
|
"#875f00"
|
|
"#875f5f"
|
|
"#875f87"
|
|
"#875faf"
|
|
"#875fd7"
|
|
"#875fff"
|
|
"#878700"
|
|
"#87875f"
|
|
"#878787"
|
|
"#8787af"
|
|
"#8787d7"
|
|
"#8787ff"
|
|
"#87af00"
|
|
"#87af5f"
|
|
"#87af87"
|
|
"#87afaf"
|
|
"#87afd7"
|
|
"#87afff"
|
|
"#87d700"
|
|
"#87d75f"
|
|
"#87d787"
|
|
"#87d7af"
|
|
"#87d7d7"
|
|
"#87d7ff"
|
|
"#87ff00"
|
|
"#87ff5f"
|
|
"#87ff87"
|
|
"#87ffaf"
|
|
"#87ffd7"
|
|
"#87ffff"
|
|
"#af0000"
|
|
"#af005f"
|
|
"#af0087"
|
|
"#af00af"
|
|
"#af00d7"
|
|
"#af00ff"
|
|
"#af5f00"
|
|
"#af5f5f"
|
|
"#af5f87"
|
|
"#af5faf"
|
|
"#af5fd7"
|
|
"#af5fff"
|
|
"#af8700"
|
|
"#af875f"
|
|
"#af8787"
|
|
"#af87af"
|
|
"#af87d7"
|
|
"#af87ff"
|
|
"#afaf00"
|
|
"#afaf5f"
|
|
"#afaf87"
|
|
"#afafaf"
|
|
"#afafd7"
|
|
"#afafff"
|
|
"#afd700"
|
|
"#afd75f"
|
|
"#afd787"
|
|
"#afd7af"
|
|
"#afd7d7"
|
|
"#afd7ff"
|
|
"#afff00"
|
|
"#afff5f"
|
|
"#afff87"
|
|
"#afffaf"
|
|
"#afffd7"
|
|
"#afffff"
|
|
"#d70000"
|
|
"#d7005f"
|
|
"#d70087"
|
|
"#d700af"
|
|
"#d700d7"
|
|
"#d700ff"
|
|
"#d75f00"
|
|
"#d75f5f"
|
|
"#d75f87"
|
|
"#d75faf"
|
|
"#d75fd7"
|
|
"#d75fff"
|
|
"#d78700"
|
|
"#d7875f"
|
|
"#d78787"
|
|
"#d787af"
|
|
"#d787d7"
|
|
"#d787ff"
|
|
"#d7af00"
|
|
"#d7af5f"
|
|
"#d7af87"
|
|
"#d7afaf"
|
|
"#d7afd7"
|
|
"#d7afff"
|
|
"#d7d700"
|
|
"#d7d75f"
|
|
"#d7d787"
|
|
"#d7d7af"
|
|
"#d7d7d7"
|
|
"#d7d7ff"
|
|
"#d7ff00"
|
|
"#d7ff5f"
|
|
"#d7ff87"
|
|
"#d7ffaf"
|
|
"#d7ffd7"
|
|
"#d7ffff"
|
|
"#ff0000"
|
|
"#ff005f"
|
|
"#ff0087"
|
|
"#ff00af"
|
|
"#ff00d7"
|
|
"#ff00ff"
|
|
"#ff5f00"
|
|
"#ff5f5f"
|
|
"#ff5f87"
|
|
"#ff5faf"
|
|
"#ff5fd7"
|
|
"#ff5fff"
|
|
"#ff8700"
|
|
"#ff875f"
|
|
"#ff8787"
|
|
"#ff87af"
|
|
"#ff87d7"
|
|
"#ff87ff"
|
|
"#ffaf00"
|
|
"#ffaf5f"
|
|
"#ffaf87"
|
|
"#ffafaf"
|
|
"#ffafd7"
|
|
"#ffafff"
|
|
"#ffd700"
|
|
"#ffd75f"
|
|
"#ffd787"
|
|
"#ffd7af"
|
|
"#ffd7d7"
|
|
"#ffd7ff"
|
|
"#ffff00"
|
|
"#ffff5f"
|
|
"#ffff87"
|
|
"#ffffaf"
|
|
"#ffffd7"
|
|
"#ffffff"
|
|
"#080808"
|
|
"#121212"
|
|
"#1c1c1c"
|
|
"#262626"
|
|
"#303030"
|
|
"#3a3a3a"
|
|
"#444444"
|
|
"#4e4e4e"
|
|
"#585858"
|
|
"#626262"
|
|
"#6c6c6c"
|
|
"#767676"
|
|
"#808080"
|
|
"#8a8a8a"
|
|
"#949494"
|
|
"#9e9e9e"
|
|
"#a8a8a8"
|
|
"#b2b2b2"
|
|
"#bcbcbc"
|
|
"#c6c6c6"
|
|
"#d0d0d0"
|
|
"#dadada"
|
|
"#e4e4e4"
|
|
"#eeeeee"))
|
|
|
|
(define-immutable-record-type <color>
|
|
(make-color r g b type)
|
|
color?
|
|
(r color-r)
|
|
(g color-g)
|
|
(b color-b)
|
|
(type color-type))
|
|
|
|
(define* (hex->color hex #:optional (type 'foreground))
|
|
(define-peg-pattern hex-char body (peg "[a-fA-F0-9]"))
|
|
(define-peg-pattern wide all (and hex-char hex-char))
|
|
(define-peg-pattern narrow all hex-char)
|
|
|
|
(define-peg-pattern hex-chars body
|
|
(or (and wide wide wide)
|
|
(and narrow narrow narrow)))
|
|
|
|
(define-peg-pattern hex-string body
|
|
(and (ignore (and (? "#") (? (or "x" "0x"))))
|
|
hex-chars))
|
|
|
|
(define (terminal->channel term)
|
|
(let* ((str (second term))
|
|
(val (locale-string->integer str 16)))
|
|
;; If one character we act as if it was doubled
|
|
(if (= 1 (string-length str))
|
|
(+ val (* val 16))
|
|
val)))
|
|
|
|
(let* ((tree (peg:tree (match-pattern hex-string hex)))
|
|
(chs (and tree (map terminal->channel tree))))
|
|
(and chs
|
|
(make-color (first chs) (second chs) (third chs) type))))
|
|
|
|
(define %ANSI256-COLORS
|
|
(map hex->color %ANSI256-HEX))
|
|
|
|
(define %ANSI-HEX (list-head %ANSI256-HEX 16))
|
|
|
|
(define %ANSI-COLORS
|
|
(map hex->color %ANSI-HEX))
|
|
|
|
|
|
(define %FOREGROUND "38")
|
|
(define %BACKGROUND "48")
|
|
|
|
;; Parameter determining the color profile to use. Can be one of: 'true-color 'ansi256 'ansi 'ascii
|
|
;; If #f, formatting will use the value returned by (color-profile (current-input-port))
|
|
(define current-color-profile (make-parameter #f))
|
|
|
|
(define (make-foreground hex)
|
|
"Create a foreground color from a hex code"
|
|
(hex->color hex 'foreground))
|
|
|
|
(define (make-background hex)
|
|
"Create a background color from a hex code"
|
|
(hex->color hex 'background))
|
|
|
|
(define (color->sequence color)
|
|
"Function to transform the color into the sequence representing the color. Uses `current-color-profile` or the profile that `current-output-port` supports to determine the sequence to print"
|
|
(define type-code
|
|
(if (eqv? 'foreground (color-type color))
|
|
%FOREGROUND
|
|
%BACKGROUND))
|
|
|
|
;; if user has parameterized a profile we use that but otherwise we use the profile of the active output port
|
|
(define profile
|
|
(or (current-color-profile)
|
|
(color-profile (current-output-port))))
|
|
|
|
(case profile
|
|
((true-color)
|
|
(format #f "~a;2;~a;~a;~a" type-code (color-r color) (color-g color) (color-b color)))
|
|
((ansi256) (format #f "~a;5;~d" type-code (color->ansi256-index color)))
|
|
((ansi) (format #f "~d" (color->ansi-index color)))
|
|
(else "")))
|
|
|
|
;; http://www.easyrgb.com/en/math.php
|
|
(define (color->cie-lab c)
|
|
(define (modulate x)
|
|
(if (> x 0.008856)
|
|
(expt x 1/3)
|
|
(+ (* 7.787 x) 16/116)))
|
|
|
|
(define x (modulate (/ (color-r c) 92.834)))
|
|
(define y (modulate (/ (color-g c) 100.0)))
|
|
(define z (modulate (/ (color-b c) 103.665)))
|
|
|
|
(values (- (* 116 y) 16)
|
|
(* 500 (- x y))
|
|
(* 200 (- y z))))
|
|
|
|
(define (delta-e-cie c1 c2)
|
|
"Given two colors, determine their E-CIE distance"
|
|
(define-values (cie-l1 cie-a1 cie-b1) (color->cie-lab c1))
|
|
(define-values (cie-l2 cie-a2 cie-b2) (color->cie-lab c2))
|
|
|
|
(sqrt (+ (expt (- cie-l1 cie-l2) 2)
|
|
(expt (- cie-a1 cie-a2) 2)
|
|
(expt (- cie-b1 cie-b2) 2))))
|
|
|
|
(define (color->ansi color)
|
|
"Given a full color, convert to the nearest ansi color equivalent"
|
|
(color->table color %ANSI-COLORS))
|
|
|
|
(define (color->ansi256 color)
|
|
"Given a full color, convert to the nearest ansi256 color equivalent"
|
|
(color->table color %ANSI256-COLORS))
|
|
|
|
(define (color->table color table)
|
|
(list-ref (color->table-index color table) table))
|
|
|
|
(define (color->ansi-index color)
|
|
"Given a full color, convert to the index of the nearest ansi color equivalent"
|
|
(color->table-index color %ANSI-COLORS))
|
|
|
|
(define (color->ansi256-index color)
|
|
"Given a full color, convert to the index of the nearest ansi color equivalent"
|
|
(color->table-index color %ANSI256-COLORS))
|
|
|
|
(define (color->table-index color table)
|
|
(define cur-min #f)
|
|
(define min-index #f)
|
|
|
|
(fold (λ (val acc)
|
|
(let ((min (delta-e-cie color val)))
|
|
(unless (and cur-min (> min cur-min))
|
|
(set! cur-min min)
|
|
(set! min-index acc)))
|
|
(+ 1 acc))
|
|
0 %ANSI-COLORS)
|
|
min-index)
|