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