Some cleanup of the API pre-documentation
This commit is contained in:
parent
1a560ea3d3
commit
af27fed35c
|
|
@ -7,61 +7,18 @@
|
|||
#:use-module (srfi srfi-9 gnu)
|
||||
#:export (make-foreground
|
||||
make-background
|
||||
current-color-profile
|
||||
color-r
|
||||
color-g
|
||||
color-b
|
||||
color?
|
||||
color-styled
|
||||
rgb->hsl
|
||||
rgb->cie-lab
|
||||
hex->color
|
||||
rgb->ansi
|
||||
rgb->ansi-index
|
||||
rgb->ansi256
|
||||
rgb->ansi256-index
|
||||
hsl-uv-distance))
|
||||
|
||||
(define current-color-profile (make-parameter #f))
|
||||
|
||||
(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 (make-foreground hex)
|
||||
"Create a foreground color"
|
||||
(hex->color hex 'foreground))
|
||||
|
||||
(define (make-background hex)
|
||||
"Create a background color"
|
||||
(hex->color hex 'background))
|
||||
|
||||
(define %FOREGROUND "38")
|
||||
(define %BACKGROUND "48")
|
||||
|
||||
(define (color-styled color)
|
||||
(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 (rgb->ansi256-index color)))
|
||||
((ansi) (format #f "~d" (rgb->ansi-index color)))
|
||||
(else "")))
|
||||
|
||||
;; TODO: probably could do oop goops and be neater
|
||||
current-color-profile
|
||||
color->sequence
|
||||
color->ansi
|
||||
color->ansi-index
|
||||
color->ansi256
|
||||
color->ansi256-index
|
||||
hex->color))
|
||||
|
||||
(define %ANSI-COLOR-NAMES
|
||||
'(black
|
||||
|
|
@ -339,6 +296,14 @@
|
|||
"#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 %ANSI256-COLORS
|
||||
(map hex->color %ANSI256-HEX))
|
||||
|
||||
|
|
@ -347,39 +312,43 @@
|
|||
(define %ANSI-COLORS
|
||||
(map hex->color %ANSI-HEX))
|
||||
|
||||
;; https://stackoverflow.com/a/58426404/826692
|
||||
(define (rgb->hsl c)
|
||||
(define r (/ (color-r c) 255.0))
|
||||
(define g (/ (color-g c) 255.0))
|
||||
(define b (/ (color-b c) 255.0))
|
||||
(define c-min (min r g b))
|
||||
(define c-max (max r g b))
|
||||
(define delta (- c-max c-min))
|
||||
(define h
|
||||
(round
|
||||
(* 60.0
|
||||
(cond
|
||||
((= delta 0.0) 0.0)
|
||||
((= c-max r) (floor-remainder (/ (- g b) delta) 6.0))
|
||||
|
||||
(else (+ (/ (- r g) delta) 4.0))))))
|
||||
(when (< h 0.0)
|
||||
(set! h (+ h 360.0)))
|
||||
(define %FOREGROUND "38")
|
||||
(define %BACKGROUND "48")
|
||||
|
||||
(define l (/ (+ c-max c-min) 2.0))
|
||||
;; 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 s
|
||||
(if (= delta 0.0)
|
||||
0.0
|
||||
(/ delta (- 1.0 (abs (- (* 2.0 l) 1.0))))))
|
||||
(define (make-foreground hex)
|
||||
"Create a foreground color from a hex code"
|
||||
(hex->color hex 'foreground))
|
||||
|
||||
(set! s (* s 100.0))
|
||||
(set! l (* l 100.0))
|
||||
(values h s l))
|
||||
(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 (rgb->cie-lab c)
|
||||
(define (color->cie-lab c)
|
||||
(define (modulate x)
|
||||
(if (> x 0.008856)
|
||||
(expt x 1/3)
|
||||
|
|
@ -393,27 +362,15 @@
|
|||
(* 500 (- x y))
|
||||
(* 200 (- y z))))
|
||||
|
||||
(define (rgb->delta-e-cie c1 c2)
|
||||
(define-values (cie-l1 cie-a1 cie-b1) (rgb->cie-lab c1))
|
||||
(define-values (cie-l2 cie-a2 cie-b2) (rgb->cie-lab c2))
|
||||
(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 (hsl-uv-distance c1 c2)
|
||||
"the Euclidean distance in the HSLuv colorspace"
|
||||
(define (sq x) (* x x))
|
||||
(define-values (h1 s1 l1) (rgb->hsl c1))
|
||||
(define-values (h2 s2 l2) (rgb->hsl c2))
|
||||
|
||||
(define dh (/ (min (abs (- h2 h1)) (- 360.0 (abs (- h2 h1)))) 180.0))
|
||||
(define ds (abs (- s2 s1)))
|
||||
(define dv (/ (abs (- l2 l1)) 255.0))
|
||||
|
||||
(sqrt (+ (sq (/ (- h1 h2) 100.0)) (sq (- s1 s2)) (sq (- l1 l2)))))
|
||||
|
||||
(define* (hex->color str #:optional (type 'foreground))
|
||||
(define trimmed (string-trim str #\#))
|
||||
(define width (floor (/ (string-length trimmed) 3)))
|
||||
|
|
@ -431,31 +388,31 @@
|
|||
(locale-string->integer b 16)
|
||||
type))
|
||||
|
||||
(define (rgb->ansi color)
|
||||
(define (color->ansi color)
|
||||
"Given a full color, convert to the nearest ansi color equivalent"
|
||||
(rgb->table color %ANSI-COLORS))
|
||||
(color->table color %ANSI-COLORS))
|
||||
|
||||
(define (rgb->ansi256 color)
|
||||
(define (color->ansi256 color)
|
||||
"Given a full color, convert to the nearest ansi256 color equivalent"
|
||||
(rgb->table color %ANSI256-COLORS))
|
||||
(color->table color %ANSI256-COLORS))
|
||||
|
||||
(define (rgb->table color table)
|
||||
(list-ref (rgb->table-index color table) table))
|
||||
(define (color->table color table)
|
||||
(list-ref (color->table-index color table) table))
|
||||
|
||||
(define (rgb->ansi-index color)
|
||||
(define (color->ansi-index color)
|
||||
"Given a full color, convert to the index of the nearest ansi color equivalent"
|
||||
(rgb->table-index color %ANSI-COLORS))
|
||||
(color->table-index color %ANSI-COLORS))
|
||||
|
||||
(define (rgb->ansi256-index color)
|
||||
(define (color->ansi256-index color)
|
||||
"Given a full color, convert to the index of the nearest ansi color equivalent"
|
||||
(rgb->table-index color %ANSI256-COLORS))
|
||||
(color->table-index color %ANSI256-COLORS))
|
||||
|
||||
(define (rgb->table-index color table)
|
||||
(define (color->table-index color table)
|
||||
(define cur-min #f)
|
||||
(define min-index #f)
|
||||
|
||||
(fold (λ (val acc)
|
||||
(let ((min (rgb->delta-e-cie color val)))
|
||||
(let ((min (delta-e-cie color val)))
|
||||
(unless (and cur-min (> min cur-min))
|
||||
(set! cur-min min)
|
||||
(set! min-index acc)))
|
||||
|
|
|
|||
|
|
@ -76,15 +76,15 @@
|
|||
|
||||
(define* (set-foreground-color hex #:optional (port #t))
|
||||
"Sets the default foreground color"
|
||||
(format port (string-append %OSC %SET-FOREGROUND-COLOR) (color-styled (make-foreground hex))))
|
||||
(format port (string-append %OSC %SET-FOREGROUND-COLOR) (color->sequence (make-foreground hex))))
|
||||
|
||||
(define* (set-background-color hex #:optional (port #t))
|
||||
"Sets the default background color"
|
||||
(format port (string-append %OSC %SET-BACKGROUND-COLOR) (color-styled (make-background hex))))
|
||||
(format port (string-append %OSC %SET-BACKGROUND-COLOR) (color->sequence (make-background hex))))
|
||||
|
||||
(define* (set-cursor-color hex #:optional (port #t))
|
||||
"Sets the cursor color"
|
||||
(format port (string-append %OSC %SET-CURSOR-COLOR) (color-styled (make-foreground hex))))
|
||||
(format port (string-append %OSC %SET-CURSOR-COLOR) (color->sequence (make-foreground hex))))
|
||||
|
||||
(define* (restore-screen #:optional (port #t))
|
||||
"Restores a previously saved screen state"
|
||||
|
|
|
|||
|
|
@ -5,10 +5,7 @@
|
|||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-9 gnu)
|
||||
#:export (make-style
|
||||
styled
|
||||
style-sequences
|
||||
foreground
|
||||
#:export (foreground
|
||||
background
|
||||
bold
|
||||
faint
|
||||
|
|
@ -17,9 +14,7 @@
|
|||
overline
|
||||
blink
|
||||
reverse
|
||||
cross-out
|
||||
;; get-width
|
||||
))
|
||||
cross-out))
|
||||
|
||||
(define %RESET "0")
|
||||
(define %BOLD "1")
|
||||
|
|
@ -33,7 +28,7 @@
|
|||
|
||||
;; Leaf node of style tree
|
||||
(define-immutable-record-type <style>
|
||||
(_make-style string sequences)
|
||||
(make-style string sequences)
|
||||
style?
|
||||
(string style-string)
|
||||
(sequences style-sequences set-style-sequences))
|
||||
|
|
@ -44,20 +39,17 @@
|
|||
style-node?
|
||||
(children style-node-children set-style-node-children))
|
||||
|
||||
(define (style-node-styled node port)
|
||||
(define (style-node->sequence node port)
|
||||
(for-each
|
||||
(λ (n)
|
||||
(if (style? n)
|
||||
(styled n port)
|
||||
(style-node-styled n port)))
|
||||
(style->sequence n port)
|
||||
(style-node->sequence n port)))
|
||||
(style-node-children node)))
|
||||
|
||||
(set-record-type-printer! <style-node> style-node-styled)
|
||||
(set-record-type-printer! <style-node> style-node->sequence)
|
||||
|
||||
(define (make-style str)
|
||||
(_make-style str '()))
|
||||
|
||||
(define (styled style port)
|
||||
(define (style->sequence style port)
|
||||
(define str (style-string style))
|
||||
(define (just-str) (format port "~a" str))
|
||||
|
||||
|
|
@ -65,7 +57,7 @@
|
|||
;; Colors don't get resolved until we have the port because we don't know the color profile until then.
|
||||
(define (sequence->str seq)
|
||||
(if (color? seq)
|
||||
(color-styled seq)
|
||||
(color->sequence seq)
|
||||
seq))
|
||||
|
||||
(cond
|
||||
|
|
@ -76,11 +68,11 @@
|
|||
(just-str)
|
||||
(format port "~a~am~a~a~am" %CSI seq str %CSI %RESET))))))
|
||||
|
||||
(set-record-type-printer! <style> styled)
|
||||
(set-record-type-printer! <style> style->sequence)
|
||||
|
||||
(define (cons-seq stylish sequence)
|
||||
(match stylish
|
||||
((? string? str) (_make-style str (list sequence)))
|
||||
((? string? str) (make-style str (list sequence)))
|
||||
((style) (cons-seq style sequence))
|
||||
((? list? l) (make-style-node (map (cut cons-seq <> sequence) l)))
|
||||
((? style? style) (set-style-sequences style (cons* sequence (style-sequences style))))
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
#:export (color-profile))
|
||||
|
||||
(define (color-profile port)
|
||||
"Get the best color profile supported by the given output port"
|
||||
(cond
|
||||
((not (isatty? port)) 'ascii)
|
||||
((equal? "true" (get-environment-variable "GOOGLE_CLOUD_SHELL")) 'true-color)
|
||||
|
|
|
|||
Loading…
Reference in New Issue