forked from tensorfork/tlarc
-
Notifications
You must be signed in to change notification settings - Fork 0
/
colors.arc
161 lines (130 loc) · 4.38 KB
/
colors.arc
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
(def cat args
(apply string "" args))
(def scat args
(sym:cat args))
(= term*
(obj colors (obj
black 0
red 1
green 2
yellow 3
blue 4
magenta 5
cyan 6
white 7)
attrs (obj
off 0
reset 0
rst 0
bold 1 nobold 22
bld 1 nobld 22
ul 4 noul 24
underline 4 nounderline 24
blink 5 noblink 25
black 30 fgblack 30 bgblack 40
blk 30 fgblk 30 bgblk 40
red 31 fgred 31 bgred 41
green 32 fggreen 32 bggreen 42
grn 32 fggrn 32 bggrn 42
yellow 33 fgyellow 33 bgyellow 43
ylw 33 fgylw 33 bgylw 43
blue 34 fgblue 34 bgblue 44
blu 34 fgblu 34 bgblu 44
magenta 35 fgmagenta 35 bgmagenta 45
mag 35 fgmag 35 bgmag 45
cyan 36 fgcyan 36 bgcyan 46
cyn 36 fgcyn 36 bgcyn 46
white 37 fgwhite 37 bgwhite 47
wht 37 fgwht 37 bgwht 47)))
(def denil (xs)
(keep ~no xs))
(def windows () nil)
(def prcode (codes (o sep #\;))
(unless (windows)
(let xs (flat:list codes)
(pr (cat "\033[" (apply cat (intersperse sep denil.xs)) "m")))))
(def lerp (a b vt)
;(w/infix vt `* (b `- a) `+ a))
(+ a (* vt (- b a))))
(def rgb16 (r g b (o bg nil))
(+ 16 (* 36 (trunc:lerp 0 6 (/ r 256.0)))
(* 6 (trunc:lerp 0 6 (/ g 256.0)))
(trunc:lerp 0 6 (/ b 256.0))))
(def termval (val)
(term*!attrs val))
(def termfx fxs
(when (some [in (type _) 'int 'num] fxs)
(= fxs (list fxs)))
(each val fxs
(if (acons val)
(if (is len.val 3) (apply termrgb val)
(caris val 'fg) (apply termrgb (cdr val))
(caris val 'bg) (apply termrgb (+ (cdr val) '(t)))
(err "termfx: unknown spec" val))
(prcode (term*!attrs val)))))
(def termrgb (r g b (o bg))
(prcode (list (if bg 48 38) 5 (rgb16 r g b))))
(def prcol (col s)
(pr (cat "\033[1;" (string (+ 40 (term*!colors col))) "m"))
(pr s)
(pr "\033[1;0m")
s)
(def prfx (spec . vals)
(after
(do (apply termfx (flat:list spec))
(apply pr vals))
(termfx nil)))
(def prnfx args
(apply prfx args)
(prn))
(def mkfx args
(tostring:apply prfx args))
(mac w/fx (spec . vals)
(let f (afn (xs)
(when xs
(let x (car xs)
(cons
(if (and (acons x) (caris x 'unquote))
(cadr x)
(list 'quote x))
(self (cdr xs))))))
`(tostring (prfx ',spec (cat ,@(intersperse #\space (f vals)))))))
(mac w/colors (var . body)
`(each ,var '(blk red grn ylw blu mag cyn wht)
(let ,(scat 'bg var) (scat 'bg ,var)
,@body)))
(mac w/attrs (var . body)
`(each ,var `(() (bold) (ul) (bold ul) (bold ul blink))
,@body))
(def prstyles (x)
(w/attrs attrs
(prfx attrs x)
(prn " ")
(w/colors col
(prfx `( ,col ,@attrs) x) (pr " ")
(prfx `(,bgcol ,@attrs) x) (pr " ")
(w/colors fg
(prfx `(,bgcol ,fg ,@attrs) x) (pr " "))
(prn))
(prn)))
(def makeprs (colors)
(accum a
(each col colors
(a `(def ,(scat 'pr col) (s) (prcol ',col s)))
(a `(def ,(scat 'prn col) (s) (prcol ',col s) (prn)))
(a `(def ,(scat 'mk col) (s) (tostring:prcol ',col s))))))
(mac evaldo (code)
`(eval `(do ,@(,@code))))
(evaldo:makeprs (keys term*!colors))
(def highlight (val str)
(replace val (mkred val) str))
(mac w/highlight (val . body)
`(let str (tostring (do ,@body))
(void:pr (highlight ,val str))))
(def replace (old new str (o start 0))
(iflet i (posmatch old str start)
(let s (+ (cut str 0 i)
new
(cut str (+ i (len old))))
(replace old new s (+ i (len new))))
str))