Artifact ed4dbc52ea956374725d97527628158bcf360ff1:
- File fmt/fmt-color.scm — part of check-in [80c8c83034] at 2016-07-07 18:11:39 on branch trunk — initial import (user: ovenpasta@pizzahack.eu size: 2945)
0000: 3b 3b 3b 3b 20 66 6d 74 2d 63 6f 6c 6f 72 2e 73 ;;;; fmt-color.s 0010: 63 6d 20 2d 2d 20 63 6f 6c 6f 72 65 64 20 6f 75 cm -- colored ou 0020: 74 70 75 74 0a 3b 3b 0a 3b 3b 20 43 6f 70 79 72 tput.;;.;; Copyr 0030: 69 67 68 74 20 28 63 29 20 32 30 30 36 2d 32 30 ight (c) 2006-20 0040: 30 37 20 41 6c 65 78 20 53 68 69 6e 6e 2e 20 20 07 Alex Shinn. 0050: 41 6c 6c 20 72 69 67 68 74 73 20 72 65 73 65 72 All rights reser 0060: 76 65 64 2e 0a 3b 3b 20 42 53 44 2d 73 74 79 6c ved..;; BSD-styl 0070: 65 20 6c 69 63 65 6e 73 65 3a 20 68 74 74 70 3a e license: http: 0080: 2f 2f 73 79 6e 74 68 63 6f 64 65 2e 63 6f 6d 2f //synthcode.com/ 0090: 6c 69 63 65 6e 73 65 2e 74 78 74 0a 0a 28 64 65 license.txt..(de 00a0: 66 69 6e 65 20 28 66 6d 74 2d 63 6f 6c 6f 72 20 fine (fmt-color 00b0: 73 74 29 20 28 66 6d 74 2d 72 65 66 20 73 74 20 st) (fmt-ref st 00c0: 27 63 6f 6c 6f 72 29 29 0a 28 64 65 66 69 6e 65 'color)).(define 00d0: 20 28 66 6d 74 2d 69 6e 2d 68 74 6d 6c 3f 20 73 (fmt-in-html? s 00e0: 74 29 20 28 66 6d 74 2d 72 65 66 20 73 74 20 27 t) (fmt-ref st ' 00f0: 69 6e 2d 68 74 6d 6c 3f 29 29 0a 28 64 65 66 69 in-html?)).(defi 0100: 6e 65 20 28 66 6d 74 2d 75 73 65 2d 68 74 6d 6c ne (fmt-use-html 0110: 2d 66 6f 6e 74 3f 20 73 74 29 20 28 66 6d 74 2d -font? st) (fmt- 0120: 72 65 66 20 73 74 20 27 75 73 65 2d 68 74 6d 6c ref st 'use-html 0130: 2d 66 6f 6e 74 3f 29 29 0a 0a 28 64 65 66 69 6e -font?))..(defin 0140: 65 20 28 63 6f 6c 6f 72 2d 3e 61 6e 73 69 20 78 e (color->ansi x 0150: 29 0a 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f ). (if (number? 0160: 20 78 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 x). (let ( 0170: 28 72 20 28 61 72 69 74 68 6d 65 74 69 63 2d 73 (r (arithmetic-s 0180: 68 69 66 74 20 78 20 2d 31 36 29 29 0a 20 20 20 hift x -16)). 0190: 20 20 20 20 20 20 20 20 20 28 67 20 28 62 69 74 (g (bit 01a0: 77 69 73 65 2d 61 6e 64 20 28 61 72 69 74 68 6d wise-and (arithm 01b0: 65 74 69 63 2d 73 68 69 66 74 20 78 20 2d 38 29 etic-shift x -8) 01c0: 20 23 78 46 46 29 29 0a 20 20 20 20 20 20 20 20 #xFF)). 01d0: 20 20 20 20 28 62 20 28 62 69 74 77 69 73 65 2d (b (bitwise- 01e0: 61 6e 64 20 78 20 23 78 46 46 29 29 29 0a 20 20 and x #xFF))). 01f0: 20 20 20 20 20 20 3b 3b 20 6a 75 73 74 20 70 69 ;; just pi 0200: 63 6b 73 20 74 68 65 20 68 69 67 68 65 73 74 20 cks the highest 0210: 63 6f 6c 6f 72 20 76 61 6c 75 65 20 2d 20 6e 65 color value - ne 0220: 65 64 20 74 6f 20 64 65 74 65 63 74 20 62 6c 65 ed to detect ble 0230: 6e 64 73 0a 20 20 20 20 20 20 20 20 28 63 6f 6c nds. (col 0240: 6f 72 2d 3e 61 6e 73 69 0a 20 20 20 20 20 20 20 or->ansi. 0250: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 (cond. 0260: 20 20 20 28 28 3e 20 72 20 67 29 20 28 69 66 20 ((> r g) (if 0270: 28 3e 20 72 20 62 29 20 27 72 65 64 20 27 62 6c (> r b) 'red 'bl 0280: 75 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ue)). 0290: 28 28 3e 20 67 20 62 29 20 27 67 72 65 65 6e 29 ((> g b) 'green) 02a0: 0a 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 . (els 02b0: 65 20 27 62 6c 75 65 29 29 29 29 0a 20 20 20 20 e 'blue)))). 02c0: 20 20 28 63 61 73 65 20 78 0a 20 20 20 20 20 20 (case x. 02d0: 20 20 28 28 62 6f 6c 64 29 20 22 31 22 29 0a 20 ((bold) "1"). 02e0: 20 20 20 20 20 20 20 28 28 64 61 72 6b 29 20 22 ((dark) " 02f0: 32 22 29 0a 20 20 20 20 20 20 20 20 28 28 75 6e 2"). ((un 0300: 64 65 72 6c 69 6e 65 29 20 22 34 22 29 0a 20 20 derline) "4"). 0310: 20 20 20 20 20 20 28 28 62 6c 61 63 6b 29 20 22 ((black) " 0320: 33 30 22 29 0a 20 20 20 20 20 20 20 20 28 28 72 30"). ((r 0330: 65 64 29 20 22 33 31 22 29 0a 20 20 20 20 20 20 ed) "31"). 0340: 20 20 28 28 67 72 65 65 6e 29 20 22 33 32 22 29 ((green) "32") 0350: 0a 20 20 20 20 20 20 20 20 28 28 79 65 6c 6c 6f . ((yello 0360: 77 29 20 22 33 33 22 29 0a 20 20 20 20 20 20 20 w) "33"). 0370: 20 28 28 62 6c 75 65 29 20 22 33 34 22 29 0a 20 ((blue) "34"). 0380: 20 20 20 20 20 20 20 28 28 6d 61 67 65 6e 74 61 ((magenta 0390: 29 20 22 33 35 22 29 0a 20 20 20 20 20 20 20 20 ) "35"). 03a0: 28 28 63 79 61 6e 29 20 22 33 36 22 29 0a 20 20 ((cyan) "36"). 03b0: 20 20 20 20 20 20 28 28 77 68 69 74 65 29 20 22 ((white) " 03c0: 33 37 22 29 0a 20 20 20 20 20 20 20 20 28 65 6c 37"). (el 03d0: 73 65 20 22 30 22 29 29 29 29 0a 0a 28 64 65 66 se "0"))))..(def 03e0: 69 6e 65 20 28 61 6e 73 69 2d 65 73 63 61 70 65 ine (ansi-escape 03f0: 20 63 6f 6c 6f 72 29 0a 20 20 28 63 61 74 20 28 color). (cat ( 0400: 69 6e 74 65 67 65 72 2d 3e 63 68 61 72 20 32 37 integer->char 27 0410: 29 20 22 5b 22 20 28 63 6f 6c 6f 72 2d 3e 61 6e ) "[" (color->an 0420: 73 69 20 63 6f 6c 6f 72 29 20 22 6d 22 29 29 0a si color) "m")). 0430: 0a 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 69 6e .(define (fmt-in 0440: 2d 68 74 6d 6c 20 2e 20 61 72 67 73 29 0a 20 20 -html . args). 0450: 28 66 6d 74 2d 6c 65 74 20 27 69 6e 2d 68 74 6d (fmt-let 'in-htm 0460: 6c 3f 20 23 74 20 28 61 70 70 6c 79 2d 63 61 74 l? #t (apply-cat 0470: 20 61 72 67 73 29 29 29 0a 0a 28 64 65 66 69 6e args)))..(defin 0480: 65 20 28 66 6d 74 2d 63 6f 6c 6f 72 65 64 20 63 e (fmt-colored c 0490: 6f 6c 6f 72 20 2e 20 61 72 67 73 29 0a 20 20 28 olor . args). ( 04a0: 66 6d 74 2d 69 66 20 66 6d 74 2d 69 6e 2d 68 74 fmt-if fmt-in-ht 04b0: 6d 6c 3f 0a 20 20 20 20 20 20 20 20 20 20 28 63 ml?. (c 04c0: 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 ond. 04d0: 28 28 65 71 3f 20 63 6f 6c 6f 72 20 27 62 6f 6c ((eq? color 'bol 04e0: 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 d). 04f0: 28 63 61 74 20 22 3c 62 3e 22 20 28 61 70 70 6c (cat "<b>" (appl 0500: 79 2d 63 61 74 20 61 72 67 73 29 20 22 3c 2f 62 y-cat args) "</b 0510: 3e 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 >")). 0520: 20 28 28 65 71 3f 20 63 6f 6c 6f 72 20 27 75 6e ((eq? color 'un 0530: 64 65 72 6c 69 6e 65 29 0a 20 20 20 20 20 20 20 derline). 0540: 20 20 20 20 20 20 28 63 61 74 20 22 3c 75 3e 22 (cat "<u>" 0550: 20 28 61 70 70 6c 79 2d 63 61 74 20 61 72 67 73 (apply-cat args 0560: 29 20 22 3c 2f 75 3e 22 29 29 0a 20 20 20 20 20 ) "</u>")). 0570: 20 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 (else. 0580: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let ( 0590: 28 63 6e 61 6d 65 20 28 69 66 20 28 6e 75 6d 62 (cname (if (numb 05a0: 65 72 3f 20 63 6f 6c 6f 72 29 20 28 63 61 74 20 er? color) (cat 05b0: 22 23 22 20 63 6f 6c 6f 72 29 20 63 6f 6c 6f 72 "#" color) color 05c0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))). 05d0: 20 20 20 28 66 6d 74 2d 69 66 20 66 6d 74 2d 75 (fmt-if fmt-u 05e0: 73 65 2d 68 74 6d 6c 2d 66 6f 6e 74 3f 0a 20 20 se-html-font?. 05f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0600: 20 20 20 20 20 28 63 61 74 20 22 3c 66 6f 6e 74 (cat "<font 0610: 20 63 6f 6c 6f 72 3d 5c 22 22 20 63 6e 61 6d 65 color=\"" cname 0620: 20 22 5c 22 3e 22 20 28 61 70 70 6c 79 2d 63 61 "\">" (apply-ca 0630: 74 20 61 72 67 73 29 0a 20 20 20 20 20 20 20 20 t args). 0640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0650: 20 20 20 20 22 3c 2f 66 6f 6e 74 3e 22 29 0a 20 "</font>"). 0660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0670: 20 20 20 20 20 20 28 63 61 74 20 22 3c 73 70 61 (cat "<spa 0680: 6e 20 73 74 79 6c 65 3d 63 6f 6c 6f 72 3a 5c 22 n style=color:\" 0690: 22 20 63 6e 61 6d 65 20 22 5c 22 3e 22 0a 20 20 " cname "\">". 06a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 06b0: 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c 79 (apply 06c0: 2d 63 61 74 20 61 72 67 73 29 20 22 3c 2f 73 70 -cat args) "</sp 06d0: 61 6e 3e 22 29 29 29 29 29 0a 20 20 20 20 20 20 an>"))))). 06e0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 29 (lambda (st) 06f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 . (le 0700: 74 20 28 28 6f 6c 64 2d 63 6f 6c 6f 72 20 28 66 t ((old-color (f 0710: 6d 74 2d 63 6f 6c 6f 72 20 73 74 29 29 29 0a 20 mt-color st))). 0720: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 66 ((f 0730: 6d 74 2d 6c 65 74 20 27 63 6f 6c 6f 72 20 63 6f mt-let 'color co 0740: 6c 6f 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 lor. 0750: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 74 (cat 0760: 20 28 61 6e 73 69 2d 65 73 63 61 70 65 20 63 6f (ansi-escape co 0770: 6c 6f 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 lor). 0780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0790: 20 20 28 61 70 70 6c 79 2d 63 61 74 20 61 72 67 (apply-cat arg 07a0: 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 s). 07b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 07c0: 28 69 66 20 28 6f 72 20 28 6d 65 6d 76 20 63 6f (if (or (memv co 07d0: 6c 6f 72 20 27 28 62 6f 6c 64 20 75 6e 64 65 72 lor '(bold under 07e0: 6c 69 6e 65 29 29 0a 20 20 20 20 20 20 20 20 20 line)). 07f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0800: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 65 6d (mem 0810: 76 20 6f 6c 64 2d 63 6f 6c 6f 72 20 27 28 62 6f v old-color '(bo 0820: 6c 64 20 75 6e 64 65 72 6c 69 6e 65 29 29 29 0a ld underline))). 0830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0850: 20 28 61 6e 73 69 2d 65 73 63 61 70 65 20 27 72 (ansi-escape 'r 0860: 65 73 65 74 29 0a 20 20 20 20 20 20 20 20 20 20 eset). 0870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0880: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda ( 0890: 73 74 29 20 73 74 29 29 0a 20 20 20 20 20 20 20 st) st)). 08a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 08b0: 20 20 20 20 20 20 28 61 6e 73 69 2d 65 73 63 61 (ansi-esca 08c0: 70 65 20 6f 6c 64 2d 63 6f 6c 6f 72 29 29 29 0a pe old-color))). 08d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 s 08e0: 74 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 t)))))..(define 08f0: 28 66 6d 74 2d 72 65 64 20 2e 20 61 72 67 73 29 (fmt-red . args) 0900: 20 28 66 6d 74 2d 63 6f 6c 6f 72 65 64 20 27 72 (fmt-colored 'r 0910: 65 64 20 28 61 70 70 6c 79 2d 63 61 74 20 61 72 ed (apply-cat ar 0920: 67 73 29 29 29 0a 28 64 65 66 69 6e 65 20 28 66 gs))).(define (f 0930: 6d 74 2d 62 6c 75 65 20 2e 20 61 72 67 73 29 20 mt-blue . args) 0940: 28 66 6d 74 2d 63 6f 6c 6f 72 65 64 20 27 62 6c (fmt-colored 'bl 0950: 75 65 20 28 61 70 70 6c 79 2d 63 61 74 20 61 72 ue (apply-cat ar 0960: 67 73 29 29 29 0a 28 64 65 66 69 6e 65 20 28 66 gs))).(define (f 0970: 6d 74 2d 67 72 65 65 6e 20 2e 20 61 72 67 73 29 mt-green . args) 0980: 20 28 66 6d 74 2d 63 6f 6c 6f 72 65 64 20 27 67 (fmt-colored 'g 0990: 72 65 65 6e 20 28 61 70 70 6c 79 2d 63 61 74 20 reen (apply-cat 09a0: 61 72 67 73 29 29 29 0a 28 64 65 66 69 6e 65 20 args))).(define 09b0: 28 66 6d 74 2d 63 79 61 6e 20 2e 20 61 72 67 73 (fmt-cyan . args 09c0: 29 20 28 66 6d 74 2d 63 6f 6c 6f 72 65 64 20 27 ) (fmt-colored ' 09d0: 63 79 61 6e 20 28 61 70 70 6c 79 2d 63 61 74 20 cyan (apply-cat 09e0: 61 72 67 73 29 29 29 0a 28 64 65 66 69 6e 65 20 args))).(define 09f0: 28 66 6d 74 2d 79 65 6c 6c 6f 77 20 2e 20 61 72 (fmt-yellow . ar 0a00: 67 73 29 20 28 66 6d 74 2d 63 6f 6c 6f 72 65 64 gs) (fmt-colored 0a10: 20 27 79 65 6c 6c 6f 77 20 28 61 70 70 6c 79 2d 'yellow (apply- 0a20: 63 61 74 20 61 72 67 73 29 29 29 0a 28 64 65 66 cat args))).(def 0a30: 69 6e 65 20 28 66 6d 74 2d 6d 61 67 65 6e 74 61 ine (fmt-magenta 0a40: 20 2e 20 61 72 67 73 29 20 28 66 6d 74 2d 63 6f . args) (fmt-co 0a50: 6c 6f 72 65 64 20 27 6d 61 67 65 6e 74 61 20 28 lored 'magenta ( 0a60: 61 70 70 6c 79 2d 63 61 74 20 61 72 67 73 29 29 apply-cat args)) 0a70: 29 0a 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 77 ).(define (fmt-w 0a80: 68 69 74 65 20 2e 20 61 72 67 73 29 20 28 66 6d hite . args) (fm 0a90: 74 2d 63 6f 6c 6f 72 65 64 20 27 77 68 69 74 65 t-colored 'white 0aa0: 20 28 61 70 70 6c 79 2d 63 61 74 20 61 72 67 73 (apply-cat args 0ab0: 29 29 29 0a 28 64 65 66 69 6e 65 20 28 66 6d 74 ))).(define (fmt 0ac0: 2d 62 6c 61 63 6b 20 2e 20 61 72 67 73 29 20 28 -black . args) ( 0ad0: 66 6d 74 2d 63 6f 6c 6f 72 65 64 20 27 62 6c 61 fmt-colored 'bla 0ae0: 63 6b 20 28 61 70 70 6c 79 2d 63 61 74 20 61 72 ck (apply-cat ar 0af0: 67 73 29 29 29 0a 28 64 65 66 69 6e 65 20 28 66 gs))).(define (f 0b00: 6d 74 2d 62 6f 6c 64 20 2e 20 61 72 67 73 29 20 mt-bold . args) 0b10: 28 66 6d 74 2d 63 6f 6c 6f 72 65 64 20 27 62 6f (fmt-colored 'bo 0b20: 6c 64 20 28 61 70 70 6c 79 2d 63 61 74 20 61 72 ld (apply-cat ar 0b30: 67 73 29 29 29 0a 28 64 65 66 69 6e 65 20 28 66 gs))).(define (f 0b40: 6d 74 2d 75 6e 64 65 72 6c 69 6e 65 20 2e 20 61 mt-underline . a 0b50: 72 67 73 29 20 28 66 6d 74 2d 63 6f 6c 6f 72 65 rgs) (fmt-colore 0b60: 64 20 27 75 6e 64 65 72 6c 69 6e 65 20 28 61 70 d 'underline (ap 0b70: 70 6c 79 2d 63 61 74 20 61 72 67 73 29 29 29 0a ply-cat args))). 0b80: 0a .