Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 06:09:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding background colors, as-italic

Browse source
This commit is contained in:
Alex Shinn 2020-07-03 10:42:11 +09:00
parent e3fddebb26
commit 39344bcaa0
3 changed files with 47 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
lib/srfi/166.sld
View file

@ -31,6 +31,9 @@
;; color
as-red as-blue as-green as-cyan as-yellow
as-magenta as-white as-black
as-bold as-underline
as-bold as-italic as-underline
as-color as-true-color
on-red on-blue on-green on-cyan on-yellow
on-magenta on-white on-black
on-color on-true-color
))

38
lib/srfi/166/color.scm
View file

@ -6,6 +6,7 @@
(case x
((bold) "1")
((dark) "2")
((italic) "3")
((underline) "4")
((black) "30")
((red) "31")
@ -16,6 +17,15 @@
((cyan) "36")
((white) "37")
((reset) "39")
((on-black) "40")
((on-red) "41")
((on-green) "42")
((on-yellow) "43")
((on-blue) "44")
((on-magenta) "45")
((on-cyan) "46")
((on-white) "47")
((on-reset) "49")
(else "0")))
(define (ansi-escape color)
@ -43,9 +53,19 @@
(define (as-white . args) (colored 'white (each-in-list args)))
(define (as-black . args) (colored 'black (each-in-list args)))
(define (as-bold . args) (colored 'bold (each-in-list args)))
(define (as-italic . args) (colored 'italic (each-in-list args)))
(define (as-underline . args) (colored 'underline (each-in-list args)))
(define (rgb-escape red-level green-level blue-level)
(define (on-red . args) (colored 'on-red (each-in-list args)))
(define (on-blue . args) (colored 'on-blue (each-in-list args)))
(define (on-green . args) (colored 'on-green (each-in-list args)))
(define (on-cyan . args) (colored 'on-cyan (each-in-list args)))
(define (on-yellow . args) (colored 'on-yellow (each-in-list args)))
(define (on-magenta . args) (colored 'on-magenta (each-in-list args)))
(define (on-white . args) (colored 'on-white (each-in-list args)))
(define (on-black . args) (colored 'on-black (each-in-list args)))
(define (rgb-escape red-level green-level blue-level bg?)
(when (not (and (exact-integer? red-level) (<= 0 red-level 5)))
(error "invalid red-level value" red-level))
(when (not (and (exact-integer? green-level) (<= 0 green-level 5)))
@ -53,11 +73,11 @@
(when (not (and (exact-integer? blue-level) (<= 0 blue-level 5)))
(error "invalid blue-level value" blue-level))
(string-append
"\x1B;[38;5;"
(if bg? "\x1B;[48;5;" "\x1B;[38;5;")
(number->string (+ (* 36 red-level) (* 6 green-level) blue-level 16))
"m"))
(define (rgb24-escape red-level green-level blue-level)
(define (rgb24-escape red-level green-level blue-level bg?)
(when (not (and (exact-integer? red-level) (<= 0 red-level 255)))
(error "invalid red-level value" red-level))
(when (not (and (exact-integer? green-level) (<= 0 green-level 255)))
@ -65,14 +85,20 @@
(when (not (and (exact-integer? blue-level) (<= 0 blue-level 255)))
(error "invalid blue-level value" blue-level))
(string-append
"\x1B;[38;2;"
(if bg? "\x1B;[48;2;" "\x1B;[38;2;")
(number->string red-level) ";"
(number->string green-level) ";"
(number->string blue-level)
"m"))
(define (as-color red green blue . fmt)
(colored (rgb-escape red green blue) (each-in-list fmt)))
(colored (rgb-escape red green blue #f) (each-in-list fmt)))
(define (as-true-color red green blue . fmt)
(colored (rgb24-escape red green blue) (each-in-list fmt)))
(colored (rgb24-escape red green blue #f) (each-in-list fmt)))
(define (on-color red green blue . fmt)
(colored (rgb-escape red green blue #t) (each-in-list fmt)))
(define (on-true-color red green blue . fmt)
(colored (rgb24-escape red green blue #t) (each-in-list fmt)))

15
lib/srfi/166/color.sld
View file

@ -1,10 +1,17 @@
(define-library (srfi 166 color)
(import (scheme base) (srfi 130) (srfi 165) (srfi 166 base))
(export as-red as-blue as-green as-cyan as-yellow
as-magenta as-white as-black
as-bold as-underline
as-color as-true-color)
(export
;; foreground
as-red as-blue as-green as-cyan as-yellow
as-magenta as-white as-black
as-bold as-italic as-underline
as-color as-true-color
;; background
on-red on-blue on-green on-cyan on-yellow
on-magenta on-white on-black
on-color on-true-color
)
(begin
(define color
(make-computation-environment-variable 'color #f #f)))