├── cl-ansi-text.test.asd ├── testscr.ros ├── cl-ansi-text.asd ├── src ├── define-colors.lisp └── cl-ansi-text.lisp ├── .github └── workflows │ └── ci.yml ├── README.md └── test └── cl-ansi-text-test.lisp /cl-ansi-text.test.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem #:cl-ansi-text.test 2 | :depends-on ( #:cl-colors2 #:alexandria #:cl-ansi-text #:fiveam) 3 | :components ((:module "test" 4 | :components 5 | ((:file "cl-ansi-text-test")))) 6 | :name "cl-ansi-text-test" 7 | :version "1.1" 8 | :maintainer "Paul Nathan" 9 | :author "Paul Nathan" 10 | :licence "LLGPL" 11 | :description "Test system for cl-ansi-text") 12 | -------------------------------------------------------------------------------- /testscr.ros: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #| 4 | exec ros -Q -- $0 "$@" 5 | |# 6 | 7 | (ql:quickload :fiveam) 8 | 9 | (defun main (&rest argv) 10 | (declare (ignorable argv)) 11 | (uiop:quit (if (handler-case 12 | (progn 13 | (ql:quickload :cl-ansi-text.test) 14 | (5am:run! :cl-ansi-text)) 15 | (serious-condition (c) 16 | (describe c) 17 | (uiop:quit 2))) 18 | 0 1))) 19 | -------------------------------------------------------------------------------- /cl-ansi-text.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem #:cl-ansi-text 2 | :depends-on ( #:cl-colors2 #:alexandria) 3 | :serial t 4 | :pathname "src/" 5 | :components ((:file "cl-ansi-text") 6 | (:file "define-colors")) 7 | :name "cl-ansi-text" 8 | :version "2.0.1" 9 | :maintainer "Paul Nathan" 10 | :author "Paul Nathan" 11 | :licence "LLGPL" 12 | :description "ANSI control string characters, focused on color" 13 | :long-description "ANSI control string management, specializing in 14 | colors. Sometimes it is nice to have text output in colors") 15 | -------------------------------------------------------------------------------- /src/define-colors.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :cl-ansi-text) 3 | 4 | (defmacro define-colors () 5 | `(progn 6 | ,@(map 'list 7 | (lambda (color) 8 | `(defun ,(intern (symbol-name color)) (string &key (effect :unset) (style :foreground)) 9 | ,(format nil "Returns a string decorated in ~(~a~)." color) 10 | (with-output-to-string (s) 11 | (with-color (,color :stream s :effect effect :style style) 12 | (write-string string s))))) 13 | +term-colors+))) 14 | 15 | (define-colors) 16 | 17 | 18 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: [ main ] 6 | pull_request: 7 | branches: [ main ] 8 | 9 | jobs: 10 | test: 11 | name: ${{ matrix.lisp }} on ${{ matrix.os }} 12 | strategy: 13 | matrix: 14 | lisp: 15 | # most lisps commented out for now. 16 | # - abcl-bin 17 | # - ccl-bin 18 | # Crashes out 19 | # - clasp 20 | # - clisp 21 | # - cmu-bin 22 | # - ecl 23 | - sbcl-bin 24 | os: [ ubuntu-24.04, ubuntu-22.04 ] 25 | 26 | runs-on: ${{ matrix.os }} 27 | 28 | steps: 29 | - uses: actions/checkout@v4 30 | 31 | - name: Cache Roswell 32 | uses: actions/cache@v4 33 | with: 34 | path: ~/.roswell 35 | key: ${{ runner.os }}-roswell-${{ matrix.lisp }}-${{ hashFiles('**/*.asd') }} 36 | restore-keys: | 37 | ${{ runner.os }}-roswell-${{ matrix.lisp }}- 38 | 39 | - name: Install Roswell 40 | env: 41 | LISP: ${{ matrix.lisp }} 42 | run: curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh 43 | 44 | - name: Make test script executable 45 | run: chmod +x ./testscr.ros 46 | 47 | - name: Run tests 48 | run: ./testscr.ros 49 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # cl-ansi-text 2 | 3 | Because color in your terminal is nice. 4 | ![CI](https://github.com/pnathan/cl-ansi-text/workflows/CI/badge.svg?branch=master) 5 | 6 | Installation: `(ql:quickload :cl-ansi-text)` 7 | 8 | ## Usage example - 9 | 10 | The main macro is `with-color`, which creates an enviroment where everything that is put on `stream` gets colored according to `color`. 11 | 12 | Color options comes in several forms. 13 | 14 | ### Keyword Symbol 15 | 16 | Basic 8 colors in the 3-bit color mode are supported, which are `:black`, `:red`, `:green`, `:yellow`, `:blue`, `:magenta`, `:cyan` and `:white`. 17 | 18 | ```lisp 19 | * (with-color (:red) 20 | (princ "Gets printed red...") 21 | (princ "and this too!")) 22 | ; Gets printed red...and this too! 23 | ; => "and this too!" 24 | ``` 25 | ### `CL-COLORS:RGB` and `CL-COLORS:HSV` object 26 | 27 | These are color structures from `CL-COLORS2` (a maintained fork of `CL-COLORS`). 28 | `CL-COLORS2` has several constants e.g. `cl-colors:+red+` that holds the corresponding color values. 29 | `CL-COLORS2` also supports useful blending operations on colors. 30 | Note that `CL-COLORS2` library provides a package `CL-COLORS`, not `CL-COLORS2`. 31 | 32 | ### Hex representation 33 | 34 | These are CSS-style color strings such as `"#FF0000"`. 35 | 36 | ### Integer as a 24-bit color 37 | 38 | It treats an integer as a hex string. 39 | The bottom 8 bit is used for the blue, the 8th to 16th bits are used for green, 40 | the 16th to 24th bits are used for red. 41 | Remaining bits are ignored. 42 | 43 | ### List of numbers as a 24-bit color 44 | 45 | It takes a list of three numbers (RGB) between 0 and 256. 46 | 47 | ## Function interface for printing in specific colors 48 | 49 | We provide shorthand functions for generating a colored strings: 50 | 51 | ```lisp 52 | * (yellow "Yellow string") 53 | ; => "Yellow string" 54 | * (princ (yellow "String with yellow background" :style :background)) 55 | ; "String with yellow background" 56 | ; => "String with yellow background" 57 | * (princ 58 | (concatenate 59 | 'string 60 | (yellow "Five") " test results went " (red "terribly wrong") "!")) 61 | ; Five test results went terribly wrong! 62 | ; => "Five test results went terribly wrong!" 63 | ``` 64 | 65 | You can bind the `*enabled*` special variable to `nil` to control the colorization: 66 | 67 | ```lisp 68 | * (let (cl-ansi-text:*enabled*) 69 | (princ (red "This string is printed normally"))) 70 | ``` 71 | 72 | # API 73 | 74 | ## *Type* color-specifier 75 | 76 | ``` lisp 77 | (or unsigned-byte 78 | (cons (real 0 256) 79 | (cons (real 0 256) 80 | (cons (real 0 256) 81 | null))) 82 | cl-colors:rgb 83 | cl-colors:hsv 84 | term-colors 85 | color-string) 86 | ``` 87 | 88 | ## *Type* term-colors 89 | 90 | ``` lisp 91 | (member :black :red :green :yellow :blue :magenta :cyan :white) 92 | ``` 93 | 94 | ## *Type* color-string 95 | 96 | A string of length 3, 4, 6, or 7, that optionally starts with a `#`, and 97 | the rest consists of 3 or 6 hexademical alphadigits (case-insensitive). 98 | 99 | ## *Macro* with-color 100 | 101 | ``` lisp 102 | with-color (color &key (stream t) (effect :unset) (style :foreground)) &body body 103 | ``` 104 | 105 | Writes out the ANSI escape code string 106 | denoting `effect`, `style`, and a switch to `color`, then executes `body`, 107 | then writes out the string that resets the decoration. 108 | 109 | ## *Function* make-color-string 110 | 111 | ``` lisp 112 | make-color-string color &key (effect :unset) (style :foreground) enabled 113 | ``` 114 | 115 | Takes an object of `color-specifier` and returns a string sufficient to change to the given color. 116 | 117 | Colorization is controlled by *enabled* unless manually specified otherwise by `:enabled` keyword. 118 | 119 | ## *Function* black, red, green, yellow, blue, magenta, cyan, white 120 | 121 | Shortcut functions that takes a single argument, `string`, and returns a string 122 | decorated by the corresponding color. 123 | 124 | ## *Special variable* `*enabled*` 125 | 126 | Turns on/off the colorization. 127 | 128 | ## *Special variable* `*color-mode*` 129 | 130 | Controls the way `make-color-string` emits the color code. 131 | 132 | It should be one of the following keyword symbols: `:3bit`, `:8bit`, `:24bit`. 133 | The specified color is converted to the nearest color in the color space. 134 | The default value is `:8bit`. 135 | 136 | Note that the actual appearance of the screen in the `:3bit` mode may be affected by 137 | the terminal setting -- For example, many terminals do not use `FF0000` for the red. 138 | 139 | ## *Constant* `+reset-color-string+` 140 | 141 | A constant string that resets the color state of the terminal. 142 | 143 | 144 | # Running test 145 | 146 | Run `./testscr.ros` with Roswell. You can also manually run the test with 147 | `(ql:quickload :cl-ansi-text.test) (fiveam:run! :cl-ansi-text)`. 148 | 149 | 150 | ## CI tests 151 | 152 | You can view the list of lisp implementation this library is tested on 153 | the Github Action tab. The testing environment is Linux, but we 154 | believe this should work also on OSX. 155 | 156 | 157 | # Note 158 | 159 | Note that your terminal MUST be ANSI-compliant to show these 160 | colors. 161 | 162 | SLIME REPL does not display these colors by default (2019.12.13). 163 | To make it understand the ANSI escape sequence, 164 | install `slime-repl-ansi-color` package available from [MELPA](https://melpa.org/) 165 | using `package-install` and add the following in `.emacs`: 166 | 167 | ``` lisp 168 | (with-eval-after-load 'slime-repl 169 | (require 'slime-repl-ansi-color)) 170 | (add-hook 'slime-repl-mode-hook 'slime-repl-ansi-color-mode) 171 | ``` 172 | 173 | 174 | License: LLGPL 175 | -------------------------------------------------------------------------------- /test/cl-ansi-text-test.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; test suite for cl-ansi-text 3 | 4 | (defpackage :cl-ansi-text-test 5 | (:use :common-lisp 6 | :cl-user 7 | :cl-ansi-text 8 | :fiveam)) 9 | 10 | (in-package :cl-ansi-text-test) 11 | 12 | (def-suite :cl-ansi-text :description "test suite.") 13 | 14 | (in-suite :cl-ansi-text) 15 | 16 | (defun make-color-string-as-list (&rest args) 17 | (coerce (apply #'cl-ansi-text:make-color-string args) 'list)) 18 | 19 | (test basic-color-strings 20 | "Test the basic stuff" 21 | (let ((*color-mode* :3bit)) 22 | (is (equal '(#\Esc #\[ #\3 #\1 #\m) 23 | (make-color-string-as-list :red :effect :unset :style :foreground))) 24 | (is (equal '(#\Esc #\[ #\4 #\1 #\m) 25 | (make-color-string-as-list :red :effect :unset :style :background))) 26 | (is (equal '(#\Esc #\[ #\4 #\2 #\; #\1 #\m) 27 | (make-color-string-as-list :green :effect :bright :style :background))))) 28 | 29 | (test enabled-connectivity 30 | "Test *enabled*'s capability" 31 | (let ((*color-mode* :3bit)) 32 | (is (equal '(#\Esc #\[ #\3 #\1 #\m) 33 | (let ((*enabled* t)) 34 | (make-color-string-as-list :red)))) 35 | (is (equal '() 36 | (let ((*enabled* nil)) 37 | (make-color-string-as-list :red)))) 38 | (is (equal '(#\Esc #\[ #\3 #\1 #\m) 39 | (make-color-string-as-list :red :enabled t))) 40 | (is (equal '() 41 | (make-color-string-as-list :red :enabled nil))) 42 | (is (equal "hi" 43 | (let ((*enabled* nil)) 44 | (with-output-to-string (s) 45 | (with-color (:red :stream s) (format s "hi")))))) 46 | (is (equal '(#\Esc #\[ #\3 #\1 #\m #\T #\e #\s #\t #\! #\Esc #\[ #\0 #\m) 47 | (concatenate 48 | 'list 49 | (with-output-to-string (s) 50 | (with-color (:red :stream s) 51 | (format s "Test!")))))))) 52 | 53 | (test rgb-suite 54 | "Test RGB colors" 55 | (let ((*color-mode* :3bit)) 56 | (is (equal '(#\Esc #\[ #\3 #\1 #\m) 57 | (make-color-string-as-list #xFF0000 :effect :unset :style :foreground))) 58 | (is (equal '(#\Esc #\[ #\4 #\2 #\m) 59 | (make-color-string-as-list #x00FF00 :effect :unset :style :background))) 60 | (is (equal '(#\Esc #\[ #\4 #\4 #\m) 61 | (make-color-string-as-list #x0000FF :effect :unset :style :background))) 62 | (is (equal '(#\Esc #\[ #\4 #\0 #\m) 63 | (make-color-string-as-list #x000000 :effect :unset :style :background))) 64 | (is (equal '(#\Esc #\[ #\4 #\7 #\m) 65 | (make-color-string-as-list #xFFFFFF :effect :unset :style :background)))) 66 | (let ((*color-mode* :8bit)) 67 | (is (equal '(#\Esc #\[ #\3 #\8 #\; #\5 #\; #\2 #\1 #\4 #\m) 68 | (make-color-string-as-list #xFFAA00 :effect :unset :style :foreground))) 69 | (is (equal '(#\Esc #\[ #\4 #\8 #\; #\5 #\; #\2 #\1 #\4 #\m) 70 | (make-color-string-as-list #xFFAA00 :effect :unset :style :background))) 71 | (is (equal '(#\Esc #\[ #\4 #\8 #\; #\5 #\; #\1 #\6 #\m) 72 | (make-color-string-as-list #x000000 :effect :unset :style :background))) 73 | (is (equal '(#\Esc #\[ #\4 #\8 #\; #\5 #\; #\2 #\3 #\1 #\m) 74 | (make-color-string-as-list #xFFFFFF :effect :unset :style :background)))) 75 | (let ((*color-mode* :24bit)) 76 | (is (equal '(#\Esc #\[ #\3 #\8 #\; #\2 #\; #\2 #\5 #\5 #\; #\1 #\7 #\0 #\; #\0 #\m) 77 | (make-color-string-as-list #xFFAA00 :effect :unset :style :foreground))) 78 | (is (equal '(#\Esc #\[ #\4 #\8 #\; #\2 #\; #\2 #\5 #\5 #\; #\1 #\7 #\0 #\; #\0 #\m) 79 | (make-color-string-as-list #xFFAA00 :effect :unset :style :background))) 80 | (is (equal '(#\Esc #\[ #\4 #\8 #\; #\2 #\; #\0 #\; #\0 #\; #\0 #\m) 81 | (make-color-string-as-list #x000000 :effect :unset :style :background))) 82 | (is (equal '(#\Esc #\[ #\4 #\8 #\; #\2 #\; #\2 #\5 #\5 #\; #\2 #\5 #\5 #\; #\2 #\5 #\5 #\m) 83 | (make-color-string-as-list #xFFFFFF :effect :unset :style :background))))) 84 | 85 | (test color-rgb 86 | ;; RGB plain 87 | (is (equal (coerce (cl-ansi-text:make-color-string "ff0000") 'list) 88 | '(#\Esc #\[ #\3 #\1 #\m))) 89 | ;; Web Style 90 | (is (equal (coerce (cl-ansi-text:make-color-string "#ff0000") 'list) 91 | '(#\Esc #\[ #\3 #\1 #\m))) 92 | 93 | ;; redux, but with 3 octets not 3 16-lets 94 | (is (equal (coerce (cl-ansi-text:make-color-string "f00") 'list) 95 | '(#\Esc #\[ #\3 #\1 #\m))) 96 | (is (equal (coerce (cl-ansi-text:make-color-string "#f00") 'list) 97 | '(#\Esc #\[ #\3 #\1 #\m)))) 98 | 99 | (test color-named-functions 100 | (let ((str "Test string.")) 101 | (is (equal (black str) 102 | (with-output-to-string (s) 103 | (with-color (:black :stream s) 104 | (format s str))))) 105 | (is (equal (red str) 106 | (with-output-to-string (s) 107 | (with-color (:red :stream s) 108 | (format s str))))) 109 | 110 | (is (equal (green str) 111 | (with-output-to-string (s) 112 | (with-color (:green :stream s) 113 | (format s str))))) 114 | 115 | (is (equal (yellow str) 116 | (with-output-to-string (s) 117 | (with-color (:yellow :stream s) 118 | (format s str))))) 119 | (is (equal (blue str) 120 | (with-output-to-string (s) 121 | (with-color (:blue :stream s) 122 | (format s str))))) 123 | (is (equal (magenta str) 124 | (with-output-to-string (s) 125 | (with-color (:magenta :stream s) 126 | (format s str))))) 127 | (is (equal (cyan str) 128 | (with-output-to-string (s) 129 | (with-color (:cyan :stream s) 130 | (format s str))))) 131 | (is (equal (white str) 132 | (with-output-to-string (s) 133 | (with-color (:white :stream s) 134 | (format s str))))))) 135 | 136 | (test color-named-functions-*enabled* 137 | (let ((str "Other test string.") 138 | (*enabled* nil)) 139 | (is 140 | (equal str 141 | (white (cyan (magenta (blue (yellow (green (red (black str)))))))))))) 142 | -------------------------------------------------------------------------------- /src/cl-ansi-text.lisp: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;;;; Paul Nathan 2013 3 | ;;;; cl-ansi-text.lisp 4 | ;;;; 5 | ;;;; Portions of this code were written by taksatou under the 6 | ;;;; cl-rainbow name. 7 | ;;;; 8 | ;;;; A library to produce ANSI escape sequences. Particularly, 9 | ;;;; produces colorized text on terminals 10 | 11 | (defpackage :cl-ansi-text 12 | (:use :common-lisp) 13 | (:export 14 | #:color-specifier 15 | #:with-color 16 | #:make-color-string 17 | #:+reset-color-string+ 18 | #:*enabled* 19 | #:black 20 | #:red 21 | #:green 22 | #:yellow 23 | #:blue 24 | #:magenta 25 | #:cyan 26 | #:white 27 | #:*color-mode* 28 | #:color-string)) 29 | (in-package :cl-ansi-text) 30 | 31 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 | ;; constants 33 | 34 | (defvar *enabled* t 35 | "Turns on/off the colorization.") 36 | 37 | (declaim (type (member :3bit :8bit :24bit) *color-mode*)) 38 | (defvar *color-mode* :3bit 39 | "Controls the way `make-color-string` emits the color code. 40 | 41 | It should be one of the following keyword symbols: `:3bit`, `:8bit`, `:24bit`. 42 | The specified color is converted to the nearest color in the color space. 43 | 44 | Note that the actual appearance of the screen in the `:3bit` mode may be affected by 45 | the terminal setting -- For example, many terminals do not use `FF0000` for the red.") 46 | 47 | (defvar +reset-color-string+ 48 | (concatenate 'string (list (code-char 27) #\[ #\0 #\m)) 49 | "A constant string that resets the color state of the terminal.") 50 | 51 | (defvar +cl-colors-basic-colors+ 52 | (vector 53 | cl-colors2:+black+ 54 | cl-colors2:+red+ 55 | cl-colors2:+green+ 56 | cl-colors2:+yellow+ 57 | cl-colors2:+blue+ 58 | cl-colors2:+magenta+ 59 | cl-colors2:+cyan+ 60 | cl-colors2:+white+) 61 | "CL-COLORS2 basic colors") 62 | 63 | (defvar +term-colors+ 64 | (vector 65 | :black 66 | :red 67 | :green 68 | :yellow 69 | :blue 70 | :magenta 71 | :cyan 72 | :white) 73 | "Basic colors") 74 | 75 | (defvar +text-style+ 76 | '((:foreground . 30) 77 | (:background . 40)) 78 | "One or the other. Not an ANSI effect") 79 | 80 | (defvar +term-effects+ 81 | '((:unset . t) 82 | (:reset . 0) 83 | (:bright . 1) 84 | (:italic . 3) 85 | (:underline . 4) 86 | (:blink . 5) 87 | (:inverse . 7) 88 | (:hide . 8) 89 | (:normal . 22) 90 | (:framed . 51) 91 | (:encircled . 52) 92 | (:overlined . 53) 93 | (:not-framed-or-circled . 54) 94 | (:not-overlined . 55)) 95 | "ANSI terminal effects") 96 | 97 | (defun color-string-p (string) 98 | (every (lambda (c) 99 | (member c '(#\# #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 100 | #\a #\b #\c #\d #\e #\f #\A #\B #\C #\D #\E #\F))) 101 | string)) 102 | 103 | (deftype color-specifier () 104 | `(or unsigned-byte 105 | (cons (real 0 256) 106 | (cons (real 0 256) 107 | (cons (real 0 256) 108 | null))) 109 | cl-colors2:rgb 110 | cl-colors2:hsv 111 | term-colors 112 | color-string)) 113 | 114 | (deftype color-string () 115 | `(and (or (string 3) 116 | (string 4) 117 | (string 6) 118 | (string 7)) 119 | (satisfies color-string-p))) 120 | 121 | (deftype term-colors () 122 | `(member :black :red :green :yellow :blue :magenta :cyan :white)) 123 | 124 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 125 | 126 | (defun find-effect-code (effect) 127 | "Returns the number for the text effect OR 128 | t if no effect should be used OR 129 | nil if the effect is unknown. 130 | 131 | effect should be a member of +term-effects+" 132 | (cdr (assoc effect +term-effects+))) 133 | 134 | (defun find-style-code (style) 135 | (cdr (assoc style +text-style+))) 136 | 137 | ;; Public callables. 138 | 139 | (defun make-color-string (color &key 140 | (effect :unset) 141 | (style :foreground) 142 | ((:enabled *enabled*) *enabled*)) 143 | "Takes an object of `color-specifier` and returns a string sufficient to change to the given color. 144 | 145 | Colorization is controlled by *enabled* unless manually specified otherwise by `:enabled` keyword." 146 | (declare (type color-specifier color)) 147 | (when *enabled* 148 | (let ((effect-code (find-effect-code effect))) 149 | ;; Nil here indicates an error 150 | (assert effect-code) 151 | (let ((codes nil)) 152 | (unless (eq effect-code t) 153 | (push effect-code codes)) 154 | 155 | ;; on 3bit, a list containing an integer in 30 - 37, 40 - 47. 156 | ;; on 8bit, a list containing 5 and an integer. 38;5;n 157 | ;; on 24bit, a list containing 2 and 3 more integers (r,g,b). 38;2;r;g;b 158 | (setf codes (append (rgb-color-code color style) codes)) 159 | (format nil "~c[~{~A~^;~}m" (code-char #o33) codes))))) 160 | 161 | (defmacro with-color ((color &key 162 | (stream t) 163 | (effect :unset) 164 | (style :foreground)) 165 | &body body) 166 | "Writes out the ANSI escape code string 167 | denoting `effect`, `style`, and a switch to `color`, then executes `body`, 168 | then writes out the string that resets the decoration." 169 | `(progn 170 | (when *enabled* 171 | (format ,stream "~a" (make-color-string ,color 172 | :effect ,effect 173 | :style ,style))) 174 | (unwind-protect 175 | (progn 176 | ,@body) 177 | (when *enabled* 178 | (format ,stream "~a" +reset-color-string+))))) 179 | 180 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 181 | ;; color handling 182 | 183 | (defgeneric rgb-color-code (color &optional style) 184 | (:documentation 185 | "Returns a list of codes suitable for the current color mode.")) 186 | 187 | (defmethod rgb-color-code ((color list) &optional (style :foreground)) 188 | (assert (and (= 3 (length color)) 189 | (every #'realp color) 190 | (every (lambda (x) (<= 0 x 256)) color)) 191 | nil "~a must be a list of numbers in [0,256]" color) 192 | (rgb-color-code (apply #'cl-colors2:rgb (mapcar (lambda (x) (/ x 256)) color)) 193 | style)) 194 | 195 | (defmethod rgb-color-code ((color integer) &optional (style :foreground)) 196 | "Takes RGB integer ala Web integers" 197 | (rgb-color-code (cl-colors2:rgb 198 | ;; classic bitmask 199 | (/ (ash (logand color #xff0000) -16) 256) 200 | (/ (ash (logand color #x00ff00) -8) 256) 201 | (/ (logand color #x0000ff) 256)) 202 | style)) 203 | 204 | (defmethod rgb-color-code ((color string) &optional (style :foreground)) 205 | "Takes RGB integer ala Web integers" 206 | (rgb-color-code (cl-colors2:parse-hex-rgb color) 207 | style)) 208 | 209 | (defmethod rgb-color-code ((color cl-colors2:rgb) &optional (style :foreground)) 210 | (code-from-rgb color style)) 211 | 212 | (defmethod rgb-color-code ((color cl-colors2:hsv) &optional (style :foreground)) 213 | (code-from-rgb (cl-colors2:hsv-to-rgb color) style)) 214 | 215 | (defmethod rgb-color-code ((color symbol) &optional (style :foreground)) 216 | (code-from-rgb (aref +cl-colors-basic-colors+ (position color +term-colors+)) style)) 217 | 218 | (defun code-from-rgb (color style) 219 | (ecase *color-mode* 220 | (:3bit 221 | (list (+ (find-style-code style) ; 30 or 40 222 | ;; 0-7 223 | (rgb-to-ansi-3bit color)))) 224 | (:8bit 225 | (list (+ (find-style-code style) 8) ; 38 or 48 226 | 5 227 | (rgb-to-ansi-8bit color))) 228 | (:24bit 229 | (list (+ (find-style-code style) 8) 230 | 2 231 | (ceiling (* 255 (cl-colors2:rgb-red color))) 232 | (ceiling (* 255 (cl-colors2:rgb-green color))) 233 | (ceiling (* 255 (cl-colors2:rgb-blue color))))))) 234 | 235 | (defun rgb-to-ansi-3bit (color) 236 | "find the closest color from +cl-colors-basic-colors+" 237 | (labels ((square (x) 238 | (* x x)) 239 | (distance (color2) 240 | (+ (square (- (cl-colors2:rgb-red color) (cl-colors2:rgb-red color2))) 241 | (square (- (cl-colors2:rgb-green color) (cl-colors2:rgb-green color2))) 242 | (square (- (cl-colors2:rgb-blue color) (cl-colors2:rgb-blue color2)))))) 243 | (position (reduce (lambda (a b) 244 | (if (< (distance a) (distance b)) 245 | a b)) 246 | +cl-colors-basic-colors+) 247 | +cl-colors-basic-colors+))) 248 | 249 | (defun rgb-to-ansi-8bit (color) 250 | "http://www.frexx.de/xterm-256-notes/" 251 | (+ 16 252 | (* 36 (min 5 (floor (* 6 (cl-colors2:rgb-red color))))) 253 | (* 6 (min 5 (floor (* 6 (cl-colors2:rgb-green color))))) 254 | (* 1 (min 5 (floor (* 6 (cl-colors2:rgb-blue color))))))) 255 | --------------------------------------------------------------------------------