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
|
diff --git a/color.lisp b/color.lisp
index 30396bc..57cebf1 100644
--- a/color.lisp
+++ b/color.lisp
@@ -66,29 +66,38 @@ then call (update-color-map).")
(xlib:alloc-color (xlib:screen-default-colormap (screen-number screen)) color))
(defun lookup-color (screen color)
- (xlib:lookup-color (xlib:screen-default-colormap (screen-number screen)) color))
+ (flet ((hex ()
+ (apply #'xlib:make-color
+ (loop for (x y) in '((:red 16) (:green 8) (:blue 0))
+ nconcing (list x (/ (ldb (byte 8 y) color)
+ 256))))))
+ (cond ((integerp color) (hex))
+ ((typep color 'xlib:color) color)
+ (t (xlib:lookup-color (xlib:screen-default-colormap (screen-number screen)) color)))))
;; Normal colors are dimmed and bright colors are intensified in order
;; to more closely resemble the VGA pallet.
(defun update-color-map (screen)
"Read *colors* and cache their pixel colors for use when rendering colored text."
- (let ((scm (xlib:screen-default-colormap (screen-number screen))))
- (labels ((map-colors (amt)
- (loop for c in *colors*
- as color = (xlib:lookup-color scm c)
- do (adjust-color color amt)
- collect (xlib:alloc-color scm color))))
- (setf (screen-color-map-normal screen) (apply #'vector (map-colors -0.25))
- (screen-color-map-bright screen) (apply #'vector (map-colors 0.25))))))
+ (labels ((map-colors (amt)
+ (loop for c in *colors*
+ as color = (lookup-color screen c)
+ do (adjust-color color amt)
+ collect (alloc-color screen color))))
+ (let ((amt (if *bright-colors*
+ '(-0.25 . 0.25)
+ '(0.0 . 0.0))))
+ (setf (screen-color-map-normal screen) (apply #'vector (map-colors (car amt)))
+ (screen-color-map-bright screen) (apply #'vector (map-colors (cdr amt)))))))
(defun update-screen-color-context (screen)
- (let* ((cc (screen-message-cc screen))
- (bright (lookup-color screen *text-color*)))
- (setf
- (ccontext-default-fg cc) (screen-fg-color screen)
- (ccontext-default-bg cc) (screen-bg-color screen))
- (adjust-color bright 0.25)
- (setf (ccontext-default-bright cc) (alloc-color screen bright))))
+ (let ((cc (screen-message-cc screen))
+ (bright (lookup-color screen *text-color*)))
+ (when *bright-colors*
+ (adjust-color bright 0.25))
+ (setf (ccontext-default-fg cc) (screen-fg-color screen)
+ (ccontext-default-bg cc) (screen-bg-color screen)
+ (ccontext-default-bright cc) (alloc-color screen bright))))
(defun get-bg-color (screen cc color)
(setf *background* color)
diff --git a/mode-line.lisp b/mode-line.lisp
index d30dfb9..42c3bc2 100644
--- a/mode-line.lisp
+++ b/mode-line.lisp
@@ -282,8 +282,8 @@ critical."
(xlib:create-window
:parent parent
:x 0 :y 0 :width 1 :height 1
- :background (alloc-color screen *mode-line-background-color*)
- :border (alloc-color screen *mode-line-border-color*)
+ :background (alloc-color screen (lookup-color screen *mode-line-background-color*))
+ :border (alloc-color screen (lookup-color screen *mode-line-border-color*))
:border-width *mode-line-border-width*
;; You can click the modeline
:event-mask (xlib:make-event-mask :button-press :exposure)
@@ -350,15 +350,16 @@ critical."
(defun make-mode-line-gc (window screen)
(xlib:create-gcontext :drawable window
:font (screen-font screen)
- :foreground (alloc-color screen *mode-line-foreground-color*)
- :background (alloc-color screen *mode-line-background-color*)))
+ :foreground (alloc-color screen (lookup-color screen *mode-line-foreground-color*))
+ :background (alloc-color screen (lookup-color screen *mode-line-background-color*))))
(defun update-mode-line-color-context (ml)
(let* ((cc (mode-line-cc ml))
(screen (mode-line-screen ml))
(bright (lookup-color screen *mode-line-foreground-color*)))
- (adjust-color bright 0.25)
+ (when *bright-colors*
+ (adjust-color bright 0.25))
(setf (ccontext-default-bright cc) (alloc-color screen bright))))
(defun make-head-mode-line (screen head format)
diff --git a/primitives.lisp b/primitives.lisp
index 50d062e..c37a028 100644
--- a/primitives.lisp
+++ b/primitives.lisp
@@ -109,6 +109,7 @@
*default-group-name*
*window-border-style*
*data-dir*
+ *bright-colors*
add-hook
clear-window-placement-rules
concat
@@ -153,6 +154,9 @@ be an integer.")
(defvar *grab-pointer-count* 0
"The number of times the pointer has been grabbed")
+(defvar *bright-colors* t
+ "Make colors brighter. This is the default.")
+
;;; Hooks
(defvar *command-mode-start-hook* '(command-mode-start-message)
diff --git a/screen.lisp b/screen.lisp
index ab708c3..562dbf4 100644
--- a/screen.lisp
+++ b/screen.lisp
@@ -249,7 +249,7 @@ identity with a range check."
(defmacro set-any-color (val color)
`(progn (dolist (s *screen-list*)
- (setf (,val s) (alloc-color s ,color)))
+ (setf (,val s) (alloc-color s (lookup-color s ,color))))
(update-colors-all-screens)))
;; FIXME: I don't like any of this. Isn't there a way to define
|
