132 lines
5.4 KiB
Diff
132 lines
5.4 KiB
Diff
diff --git a/color.lisp b/color.lisp
|
|
index 2085fbc..5ada58a 100644
|
|
--- a/color.lisp
|
|
+++ b/color.lisp
|
|
@@ -66,31 +66,38 @@ then call (update-color-map).")
|
|
(xlib:alloc-color (xlib:screen-default-colormap (screen-number screen)) color))
|
|
|
|
(defun lookup-color (screen color)
|
|
- (cond
|
|
- ((typep color 'xlib:color) color)
|
|
- (t (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 = (lookup-color screen 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
|
|
|