Download
(require 'color-theme)
(unless window-system
(error "Sorry, you need a window system to run color-browser"))
(defcustom cb-palettes-dir "~/.emacs/palettes/"
"Directory in which new palette files should be placed.
Usually best if this is different from `cb-themes-dir'. Must end in /.
Will be created if it does not already exist."
:type 'string
:group 'color-browser)
(defcustom cb-themes-dir "~/.emacs/themes/"
"Directory in which new color theme files will be placed and searched
for. Will be created if it does not already exist."
:type 'string
:group 'color-browser)
(defcustom cb-frame-width 24
"Desired width of the Color Browser tool. Resizing the frame will
usually produce an ugly result. Change this variable and reload
instead."
:type 'number
:group 'color-browser)
(defcustom cb-frame-height 47
"Desired height of the Color Browser tool. Resizing the frame will
usually produce an ugly result. Change this variable and reload
instead."
:type 'number
:group 'color-browser)
(eval-and-compile
(defvar cb-active-face 'default
"The face that the next color/property setting will act on.
Referenced by most key-map bindings")
(defvar cb-current-group "Basic"
"The name of the current face group displayed."))
(defvar cb-save-palette-hist nil
"Symbol used to store history of recently saved palettes.")
(defvar cb-save-theme-hist nil
"Symbol used to store history of recently saved themes.")
(defun cb-read-name (prompt alist init-input history)
"Temporally raise the minibuffer frame and read a string (one that
can be interned as a symbol) prompting with PROMPT, completing against
ALIST, using INIT-INPUT as the initial input string, and dereferencing
history events using HISTORY. This is used by functions normally called
via a mouse event."
(interactive)
(raise-frame (window-frame (minibuffer-window)))
(let ((frame (selected-frame))
(result (completing-read prompt alist nil nil init-input history)))
(raise-frame frame)
result))
(defvar cb-face-group-buffer nil)
(defvar cb-current-palette-buffer nil)
(defvar cb-old-palette-buffer nil)
(defvar cb-new-palette-buffer nil)
(defvar cb-theme-builder-p nil
"Non-nil if Color Browser is in Theme Builder mode. Otherwise the
Color Browser is in Palette Builder mode.")
(defvar cb-name ""
"Buffer local variable holding holding the name of the currently
displayed palette or face group. This is used by the dynamic
mode-line.")
(make-variable-buffer-local 'cb-name)
(defvar cb-list nil
"Buffer local variable holding the list of objects displayed in the
current buffer. This is used by the `cb-redraw-function' to draw the
buffer.")
(make-variable-buffer-local 'cb-list)
(defvar cb-default nil
"Buffer local variable holding the default list of objects to be
displayed in the current buffer. This is used by the
`cb-redraw-function' to unconditionally redraw the buffer.")
(make-variable-buffer-local 'cb-default)
(defvar cb-map nil
"Buffer local variable holding the key-map used by the buffer.")
(make-variable-buffer-local 'cb-map)
(defvar cb-action nil
"Buffer local variable holding the function called by events in the buffer.")
(make-variable-buffer-local 'cb-action)
(defvar cb-layer nil
"Buffer local variable holding the name of the layer displayed in
the buffer.")
(make-variable-buffer-local 'cb-layer)
(defvar cb-layer-map nil
"Buffer local variable holding the key-map that toggles the layer
displayed in the buffer.")
(make-variable-buffer-local 'cb-layer-map)
(defvar cb-face-groups-menu (make-sparse-keymap "Face Groups")
"Prefix keymap used to generate the \"Group:\" mode-line menu.")
(defun cb-define-if-required (name plist &optional package-list)
"Define a face group plist for NAME and PLIST, and a corresponding
key in the prefix-map `cb-face-groups-menu'. If PACKAGE-LIST is
non-nil, do this only if we can load each package in that list.
Returns the associated plist symbol. See
`cb-build-face-group-buffer' for details of how this plist is used."
(when (or (null package-list)
(condition-case nil
(dolist (package package-list 'return-value)
(require package))
(error nil)))
(let ((symbol (intern (concat "cb-" name "-faces-plist"))))
(set symbol plist)
(put symbol 'variable-documentation
(concat "A plist of " (upcase name)
" faces arranged according to level."))
(define-key cb-face-groups-menu (vector symbol)
`(menu-item ,name
(lambda ()
(interactive)
(cb-change-group (quote ,symbol)))
:button (:radio
. (string-equal cb-current-group ,name))
))
symbol
)))
(cb-define-if-required
"RPM Spec"
(list 'pre "rpm-spec-" 'post "-face"
'faces '(rpm-spec-tag-face
rpm-spec-macro-face
rpm-spec-doc-face
rpm-spec-dir-face
rpm-spec-package-face
rpm-spec-ghost-face))
'(rpm-spec-mode))
(cb-define-if-required
"Widget"
(list 'pre "widget-" 'post "-face"
'faces '(widget-documentation-face
widget-single-line-field-face
widget-field-face widget-button-face))
'(widget))
(cb-define-if-required
"W3M"
(list 'pre "w3m-" 'post "-face"
'faces '(w3m-form-face
w3m-header-line-location-title-face
w3m-header-line-location-content-face
w3m-image-face w3m-anchor-face
w3m-history-current-url-face
w3m-arrived-anchor-face
w3m-current-anchor-face
w3m-bold-face w3m-underline-face
w3m-tab-unselected-face
w3m-tab-unselected-retrieving-face
w3m-tab-selected-face
w3m-tab-selected-retrieving-face
w3m-tab-background-face
w3m-form-button-face
w3m-form-button-mouse-face
w3m-form-button-pressed-face))
'(w3m w3m-form w3m-image))
(cb-define-if-required
"Emacs Wiki"
(list 'pre nil 'post "-face"
'faces '(
emacs-wiki-link-face
emacs-wiki-bad-link-face
))
'(emacs-wiki))
(cb-define-if-required
"PCVS"
(list 'pre nil 'post "-face"
'faces '(cvs-header-face
cvs-msg-face
log-view-message-face
cvs-filename-face cvs-unknown-face
cvs-handled-face cvs-need-action-face
log-view-file-face
cvs-marked-face))
'(pcvs log-view))
(cb-define-if-required
"EDiff"
(list 'pre "ediff-" 'post nil
'faces '(ediff-current-diff-face-Ancestor
ediff-current-diff-face-A
ediff-current-diff-face-B
ediff-current-diff-face-C
ediff-fine-diff-face-Ancestor
ediff-fine-diff-face-C
ediff-fine-diff-face-B
ediff-fine-diff-face-A
ediff-odd-diff-face-Ancestor
ediff-odd-diff-face-A
ediff-odd-diff-face-B
ediff-odd-diff-face-C
ediff-even-diff-face-Ancestor
ediff-even-diff-face-A
ediff-even-diff-face-B
ediff-even-diff-face-C
))
'(ediff))
(cb-define-if-required
"Diff"
(list 'pre "diff-" 'post "-face"
'faces '(diff-removed-face
diff-added-face
diff-changed-face
diff-header-face diff-file-header-face
diff-hunk-header-face
diff-function-face diff-context-face
diff-nonexistent-face
diff-index-face))
'(diff-mode))
(cb-define-if-required
"Change-Log"
(list 'pre "change-log-" 'post "-face"
'faces '(change-log-acknowledgement-face
change-log-conditionals-face
change-log-function-face
change-log-name-face change-log-email-face
change-log-file-face change-log-list-face
change-log-date-face))
'(add-log))
(cb-define-if-required
"Speedbar"
(list 'pre "speedbar-" 'post "-face"
'faces '(speedbar-directory-face
speedbar-highlight-face speedbar-tag-face
speedbar-file-face speedbar-selected-face
speedbar-button-face ))
'(speedbar))
(defun cb-append-if-required (symbol list &optional package-list)
"Append LIST to the faces property of the face group SYMBOL iff we
can load each package in PACKAGE-LIST. This is a piece-wise version
of what `cb-define-if-required' does."
(when (or (null package-list)
(condition-case nil
(dolist (package package-list 'return-value)
(require package))
(error nil)))
(set symbol (list 'pre (plist-get (symbol-value symbol) 'pre)
'post (plist-get (symbol-value symbol) 'post)
'faces (append (plist-get (symbol-value symbol)
'faces)
list)
))))
(let ((symbol (cb-define-if-required "Minor" '())))
(set symbol '(pre nil post "-face"))
(cb-append-if-required symbol
'(flyspell-incorrect-face
flyspell-duplicate-face)
'(flyspell))
(cb-append-if-required symbol
'(sh-heredoc-face)
'(sh-script))
(cb-append-if-required symbol
'(show-tabs-tab-face show-tabs-space-face)
'(generic-x))
(cb-append-if-required symbol
'(show-paren-match-face show-paren-mismatch-face)
'(paren))
(cb-append-if-required symbol
'(highlight-changes-face highlight-changes-delete-face)
'(hilit-chg))
(cb-append-if-required symbol
'(comint-highlight-input comint-highlight-prompt)
'(comint))
(cb-append-if-required symbol
'(swbuff-default-face
swbuff-current-buffer-face
swbuff-special-buffers-face
swbuff-separator-face)
'(swbuff-x))
(cb-append-if-required symbol
'(cperl-nonoverridable-face
cperl-hash-face
cperl-array-face)
'(cperl-mode))
(cb-append-if-required symbol
'(woman-italic-face
woman-bold-face
woman-unknown-face
woman-addition-face)
'(woman))
(cb-append-if-required symbol
'(makefile-space-face)
'(make-mode))
(cb-append-if-required symbol
'(isearch
isearch-lazy-highlight-face
tooltip)
'())
)
(cb-define-if-required
"Info"
(list 'pre "info-" 'post "-face"
'faces '(Info-title-1-face
Info-title-2-face
Info-title-3-face Info-title-4-face
info-header-node info-menu-header
info-header-xref info-node info-xref
info-menu-5))
'(info))
(cb-define-if-required
"Latex"
(list 'pre "font-latex-" 'post "-face"
'faces '(tex-math-face
font-latex-bold-face
font-latex-italic-face
font-latex-math-face
font-latex-sedate-face
font-latex-warning-face))
'(tex-mode tex-site font-latex))
(cb-define-if-required
"Font-Lock"
(list 'pre "font-lock-" 'post "-face"
'faces '(font-lock-comment-face
font-lock-string-face
font-lock-doc-face
font-lock-function-name-face
font-lock-variable-name-face
font-lock-constant-face
font-lock-type-face
font-lock-builtin-face
font-lock-warning-face
font-lock-keyword-face))
'(font-lock))
(cb-define-if-required
"Basic"
(list 'pre nil 'post nil
'faces '(default
region secondary-selection
menu tool-bar header-line mode-line
fringe scroll-bar border
underline italic bold bold-italic
highlight fixed-pitch variable-pitch
mouse cursor trailing-whitespace)))
(defun cb-change-group (group)
"Redraw the \"Face Group\" buffer to display GROUP.
Called by keys in the prefix key-map `cb-face-groups-menu'."
(when group
(setq cb-active-face (car (plist-get (eval group) 'faces)))
(cb-redraw-buffer
cb-face-group-buffer
(list 'cb-list group))
(setq cb-current-group (save-excursion
(set-buffer cb-face-group-buffer)
cb-name))
(set-window-text-height (selected-window) (/ (frame-height) 2))
(shrink-window-if-larger-than-buffer)))
(defvar cb-props-menu (make-sparse-keymap "Props" )
"Prefix keymap used to generate the \"Props\" mode-line menu.")
(define-key cb-props-menu [cb-underline]
'(menu-item
"underline" cb-toggle-underline
:button (:toggle . (eq t (face-attribute cb-active-face :underline)))))
(define-key cb-props-menu [cb-italic]
'(menu-item
"italic" cb-toggle-italic
:button (:toggle . (eq 'italic (face-attribute cb-active-face :slant)))))
(define-key cb-props-menu [cb-bold]
'(menu-item
"bold" cb-toggle-bold
:button (:toggle . (eq 'bold (face-attribute cb-active-face :weight)))))
(defun cb-toggle-bold ()
(interactive)
"Toggle the bold attribute of the face corresponding to `cb-active-face'."
(save-window-excursion
(if (equal 'bold (face-attribute cb-active-face :weight))
(set-face-attribute cb-active-face nil :weight 'normal)
(set-face-attribute cb-active-face nil :weight 'bold))))
(defun cb-toggle-italic ()
(interactive)
"Toggle the italic attribute of the face corresponding to `cb-active-face'."
(save-window-excursion
(if (equal 'italic (face-attribute cb-active-face :slant))
(set-face-attribute cb-active-face nil :slant 'normal)
(set-face-attribute cb-active-face nil :slant 'italic))))
(defun cb-toggle-underline ()
(interactive)
"Toggle the underline attribute of the face corresponding to `cb-active-face'."
(save-window-excursion
(let ((underlined (face-attribute cb-active-face :underline)))
(if (or (null underlined) (equal underlined 'unspecified))
(set-face-attribute cb-active-face nil :underline t)
(set-face-attribute cb-active-face nil :underline 'unspecified)))))
(defun cb-height-plus-0 ()
(interactive)
"Increase the height attribute of the `cb-active-face' by 0%."
(save-window-excursion
(set-face-attribute cb-active-face nil :height 1.0)))
(defun cb-height-plus-10 ()
(interactive)
"Increase the height attribute of the `cb-active-face' by 10%."
(save-window-excursion
(set-face-attribute cb-active-face nil :height 1.1)))
(defun cb-height-plus-20 ()
(interactive)
"Increase the height attribute of the `cb-active-face' by 20%."
(save-window-excursion
(set-face-attribute cb-active-face nil :height 1.2)))
(defun cb-height-plus-50 ()
(interactive)
"Increase the height attribute of the `cb-active-face' by 50%."
(save-window-excursion
(set-face-attribute cb-active-face nil :height 1.5)))
(defun cb-height-minus-10 ()
(interactive)
"Decrease the height attribute of the `cb-active-face' by 50%."
(save-window-excursion
(let ((height (face-attribute cb-active-face :height)))
(set-face-attribute cb-active-face nil :height .1))))
(defun cb-height-minus-20 ()
(interactive)
"Decrease the height attribute of the `cb-active-face' by 50%."
(save-window-excursion
(let ((height (face-attribute cb-active-face :height)))
(set-face-attribute cb-active-face nil :height .8))))
(defun cb-height-minus-50 ()
(interactive)
"Decrease the height attribute of the `cb-active-face' by 50%."
(save-window-excursion
(let ((height (face-attribute cb-active-face :height)))
(set-face-attribute cb-active-face nil :height .5))))
(defvar cb-themes-menu nil
"Prefix keymap used to generate the \"Theme:\" mode-line menu.")
(defvar cb-current-theme "Default"
"The current theme selected using the color browser.")
(defvar cb-theme-list nil
"List used to track the set of currently defined themes and to allow
completion on existing theme names when a new them is saved.")
(defun cb-change-theme (theme)
"Switch to a theme from `cb-theme-list'"
(interactive)
(let ((symbol (intern (concat theme "-theme"))))
(require symbol (concat cb-themes-dir theme "-theme.el"))
(funcall symbol))
(save-excursion
(set-buffer cb-face-group-buffer)
(setq header-line-format nil)))
(defun cb-add-theme (name)
"Add theme called NAME to `cb-theme-list' and an appropriately name
symbol to cb-themes-menu."
(define-key cb-themes-menu
(vector (intern (concat "cb-" name "-theme")))
`(menu-item ,name
(lambda () (interactive) (cb-change-theme ,name))
:button (:radio
. (string-equal cb-current-theme ,name))
))
(setq cb-theme-list
(add-to-list 'cb-theme-list (list name))))
(defun cb-build-theme-list ()
"Set `cb-theme-list' to the names of themes saved in `cb-themes-dir'
and define corresponding keys in the prefix map `cb-themes-menu'.
Only theme files suffixed with \"-theme.el\" are considered."
(setq cb-theme-list nil)
(setq cb-themes-menu (make-sparse-keymap "Themes" ))
(define-key cb-themes-menu [cb-save-theme-as]
'(menu-item "Save Theme As ..." cb-save-theme-as))
(define-key cb-themes-menu [cb-save-theme]
'(menu-item "Save Theme" cb-save-theme))
(define-key cb-themes-menu [cb-separator]
'(menu-item "--shadow-etched-in"))
(unless (file-exists-p cb-themes-dir)
(make-directory cb-themes-dir 'and-parents))
(let ((files (directory-files cb-themes-dir nil "-theme.el$")))
(dolist (file files)
(cb-add-theme (substring file 0 -9)))))
(defun cb-save-theme-as ()
"Wrapper to cause `cb-save-theme' to prompt for a new theme name."
(interactive)
(cb-save-theme t))
(defun cb-save-theme (&optional as)
"Saving the current colors settings as a color theme.
\(With a small change: the theme function also sets the value of
`cb-current-theme'.) If AS is non-nil them prompt for a new theme name
othwise just save under the current theme."
(interactive)
(save-window-excursion
(save-excursion
(let* ((theme (if as
(cb-read-name "New theme name: "
cb-theme-list
cb-current-theme
'cb-save-theme-hist)
cb-current-theme
))
(symbol (concat theme "-theme"))
(file-name (concat cb-themes-dir symbol ".el")))
(when (file-exists-p file-name)
(copy-file file-name (concat file-name ".bak") 'overwite))
(save-excursion
(set-buffer (find-file-noselect file-name 'nowarn 'raw))
(erase-buffer)
(color-theme-print (current-buffer))
(beginning-of-buffer)
(insert "(require 'color-theme)\n\n")
(search-forward "my-color-theme" nil t)
(delete-region (match-beginning 0) (match-end 0))
(insert symbol)
(search-forward "(interactive)")
(insert "\n (setq cb-current-theme \"" theme "\")")
(search-forward "my-color-theme" nil t)
(delete-region (match-beginning 0) (match-end 0))
(insert symbol)
(end-of-buffer)
(insert "\n\n(provide '" symbol ")\n")
(save-buffer)
(kill-this-buffer))
(load-file file-name)
(message "wrote file: %s" file-name)
(cb-add-theme theme)
(save-excursion
(set-buffer cb-face-group-buffer)
(setq cb-current-theme theme)
(setq header-line-format nil)
(force-mode-line-update))))))
(defvar cb-group-map (make-sparse-keymap))
(defvar cb-theme-map (make-sparse-keymap))
(defvar cb-props-map (make-sparse-keymap))
(defun cb-build-face-group-maps ()
"This must be called after `cb-build-theme-list'"
(define-key cb-group-map [(mode-line) (mouse-1)] 'ignore)
(define-key cb-props-map [(mode-line) (mouse-1)] 'ignore)
(define-key cb-theme-map [(mode-line) (mouse-1)] 'ignore)
(define-key cb-group-map [(mode-line) (mouse-3)] 'ignore)
(define-key cb-props-map [(mode-line) (mouse-3)] 'ignore)
(define-key cb-theme-map [(mode-line) (mouse-3)] 'ignore)
(define-key cb-group-map [(mode-line) (mouse-2)]
(or cb-face-groups-menu 'ignore))
(define-key cb-props-map [(mode-line) (mouse-2)]
(or cb-props-menu 'ignore))
(define-key cb-theme-map [(mode-line) (mouse-2)]
(or cb-themes-menu 'ignore))
(define-key cb-group-map [(mode-line) (down-mouse-2)]
(or cb-face-groups-menu 'ignore))
(define-key cb-props-map [(mode-line) (down-mouse-2)]
(or cb-props-menu 'ignore))
(define-key cb-theme-map [(mode-line) (down-mouse-2)]
(or cb-themes-menu 'ignore)))
(defun cb-echo-face (&optional click)
"Echo the properties of the face of the text under point or mouse."
(interactive "@e")
(save-excursion
(let ((point (point))
(marker (make-marker))
(inhibit-read-only t)
face)
(if (eventp click)
(setq point (posn-point (event-start click)))
(select-window (posn-window (event-start click))))
(setq face (get-char-property point 'face))
(let ((foreground (face-attribute face :foreground))
(background (face-attribute face :background)))
(if (eq foreground 'unspecified) (setq foreground nil))
(if (eq background 'unspecified) (setq background nil))
(message (concat "(" (symbol-name face) ")"
(and foreground " fg: ") foreground
(and background " bg: ") background))))))
(defun cb-set-active-face (&optional click)
"Set the `cb-active-face' to the face of the text under point or mouse.
Mark the face name under point by surrounding it in []."
(interactive "@e")
(save-excursion
(let ((point (point))
(marker (make-marker))
(inhibit-read-only t))
(if (eventp click)
(setq point (posn-point (event-start click)))
(select-window (posn-window (event-start click))))
(setq cb-active-face (get-char-property point 'face))
(set-marker marker point)
(save-excursion
(beginning-of-buffer)
(and (search-forward "[" nil t) (delete-char -1))
(and (search-forward "]" nil t) (delete-char -1)))
(goto-char marker)
(skip-chars-backward "^ \t\n\r")
(insert (propertize "[" 'face 'bold))
(skip-chars-forward "^ \t\n\r")
(insert (propertize "]" 'face 'bold))
(let ((foreground (face-attribute cb-active-face :foreground))
(background (face-attribute cb-active-face :background)))
(if (eq foreground 'unspecified) (setq foreground nil))
(if (eq background 'unspecified) (setq background nil))
(message (concat "(" (symbol-name cb-active-face) ")"
(and foreground " fg: ") foreground
(and background " bg: ") background)))
)))
(defun cb-build-face-group-buffer ()
"Insert a structured list of key faces in the current buffer.
Each face name is presented using the corresponding face. Text properties
are arranged so that mouse-2 (or return) on any of the face names will set
the value of `cb-active-face' to the face under point.
The contents of this buffer is determined by the value of the buffer
local variable cb-list. This will be a plist consisting of three
fields. The `faces' field is simply a list of faces that are to be
display. The `pre-chop' field is a prefix of the face name that may be
omitted from the display without generating any ambiguity. Similarly
`post-chop' is a face name suffix that may be also omitted. By
omitting these superfluous prefixes and suffixes we can keep the
\"Face Group\" buffer relatively compact. Note that prefix/suffix
chopping is only performed on those faces that have a matching
prefix/suffix."
(setq cb-name (substring (substring (symbol-name cb-list) 3) 0 -12))
(let ((face-map (make-sparse-keymap))
(face-list (plist-get (eval cb-list) 'faces))
(pre-chop (plist-get (eval cb-list) 'pre))
(post-chop (plist-get (eval cb-list) 'post))
(inhibit-read-only t)
face-name start)
(define-key face-map [(down-mouse-2)] 'cb-set-active-face)
(define-key face-map [(return)] 'cb-set-active-face)
(dolist (face face-list)
(let ((case-fold-search t))
(setq face-name (symbol-name face))
(if (and pre-chop (string-match pre-chop face-name))
(setq face-name (substring face-name (match-end 0))))
(if (and post-chop (string-match post-chop face-name))
(setq face-name (substring face-name 0 (match-beginning 0)))))
(cond ((= (current-column) 0)
nil)
((>= (+ (current-column) 1 1 (length face-name) 1)
(window-width))
(insert "\n"))
(t
(insert " ")))
(when (equal face cb-active-face)
(insert (propertize "[" 'face 'bold)))
(setq start (point))
(insert face-name)
(let ((foreground (face-attribute face :foreground))
(background (face-attribute face :background)))
(if (eq foreground 'unspecified) (setq foreground nil))
(if (eq background 'unspecified) (setq background nil))
(set-text-properties start (point)
(list
'face face
'keymap face-map
'mouse-face 'highlight)))
(when (equal face cb-active-face)
(insert (propertize "]" 'face 'bold)))
)
(setq mode-line-format
(list
(propertize "<Props> "
'face 'menu
'local-map cb-props-map
'help-echo "mouse-2: select face property")
(propertize (concat "<Group> ")
'face 'menu
'local-map cb-group-map
'help-echo "mouse-2: select face group"
)
(propertize "<Theme>"
'face 'menu
'local-map cb-theme-map
'help-echo "mouse-2: select/save theme"
)))
(setq header-line-format nil)
(force-mode-line-update)
))
(defvar cb-current-palettes-menu nil
"Prefix keymap used to generate the \"Palette:\" mode-line menu in the
Color Palette buffer.")
(defvar cb-old-palettes-menu nil
"Prefix keymap used to generate the \"Palette:\" mode-line menu in the
Old Palette buffer.")
(defvar cb-new-palettes-menu nil
"Prefix keymap used to generate the \"Palette:\" mode-line menu in the
New Palette buffer.")
(defvar cb-All-Colors-palette nil
"A list of all colors supported by the current frame.")
(setq cb-All-Colors-palette (defined-colors))
(defvar cb-No-Colors-palette '()
"An empty list used as a place holder for new palettes.")
(defvar cb-Seaweed-palette
'(
"black" "dark slate gray" "SkyBlue4" "LightBlue4" "PaleTurquoise4"
"cadet blue" "LightBlue3" "dark turquoise" "aquamarine3"
"dark sea green" "light sea green" "medium sea green" "dark khaki"
"burlywood" "RosyBrown3" "plum3" "azure4" "thistle4"
)
"A sample color palette created by Kahlil HODGSON on Tue Dec 3 11:53:20
2002")
(defvar cb-palette-list nil
"Names of defined palettes stored under `cb-palettes-dir'. This is
used for completion.")
(defun cb-build-palette-list ()
"Set `cb-palette-list' to contain the default palettes and the names
of themes saved in `cb-palettes-dir'. Then load those palettes
and add them to both palette prefix-maps. Only default palettes
and palette files suffixed with \"-palette.el\" are considered."
(setq cb-palette-list nil)
(setq cb-current-palettes-menu (make-sparse-keymap "Color Palettes" ))
(define-key cb-current-palettes-menu [cb-delete-palette]
'(menu-item "Delete this palette"
(lambda ()
(interactive)
(cb-delete-palette
cb-current-palette-buffer))))
(define-key cb-current-palettes-menu [cb-separator-1]
'(menu-item "--shadow-etched-in"))
(define-key cb-current-palettes-menu [cb-save-palette-as]
'(menu-item "Save Palette As ..."
(lambda ()
(interactive)
(cb-save-palette
cb-current-palette-buffer t))))
(define-key cb-current-palettes-menu [cb-save-current-palette]
'(menu-item "Save Palette"
(lambda ()
(interactive)
(cb-save-palette
cb-current-palette-buffer))))
(define-key cb-current-palettes-menu [cb-separator-2]
'(menu-item "--shadow-etched-in"))
(define-key cb-current-palettes-menu [cb-No-colors-palette]
'(menu-item "No-Colors"
(lambda ()
(interactive)
(cb-redraw-buffer
cb-current-palette-buffer
(list 'cb-list 'cb-No-Colors-palette)))
:button (:radio
. (save-excursion
(set-buffer cb-current-palette-buffer)
(string-equal cb-name "No-Colors"))
)))
(define-key cb-current-palettes-menu [cb-All-colors-palette]
'(menu-item "All-Colors"
(lambda ()
(interactive)
(cb-redraw-buffer
cb-current-palette-buffer
(list 'cb-list 'cb-All-Colors-palette)))
:button (:radio
. (save-excursion
(set-buffer cb-current-palette-buffer)
(string-equal cb-name "All-Colors"))
)))
(define-key cb-current-palettes-menu [cb-Seaweed-palette]
'(menu-item "Seaweed"
(lambda ()
(interactive)
(cb-redraw-buffer
cb-current-palette-buffer
(list 'cb-list 'cb-Seaweed-palette)))
:button (:radio
. (save-excursion
(set-buffer cb-current-palette-buffer)
(string-equal cb-name "Seaweed"))
)))
(unless (file-exists-p cb-palettes-dir)
(make-directory cb-palettes-dir 'and-parents))
(setq cb-palette-list nil)
(let ((files (directory-files cb-palettes-dir nil "-palette.el$"))
file)
(dolist (file files)
(load-file (concat cb-palettes-dir file))
(setq cb-palette-list
(add-to-list 'cb-palette-list (list (substring file 0 -11))))))
(setq cb-old-palettes-menu
(cb-swap-keymap-functions
(copy-keymap cb-current-palettes-menu)
'cb-old-palette-buffer))
(setq cb-new-palettes-menu
(cb-swap-keymap-functions
(copy-keymap cb-current-palettes-menu)
'cb-new-palette-buffer))
)
(defun cb-swap-keymap-functions (tree buffer-symbol)
"Return a copy of the list TREE with instances of the symbol
`cb-current-palette-buffer' replaced by BUFFER-SYMBOL. This
function calls itself recursively."
(cond
((eq nil tree) nil)
((listp tree)
(cons (cb-swap-keymap-functions (car tree) buffer-symbol)
(cb-swap-keymap-functions (cdr tree) buffer-symbol)))
((eq 'cb-current-palette-buffer tree) buffer-symbol)
(t tree)))
(defun cb-save-palette (buffer &optional as)
"Save palette displayed in BUFFER to an appropriately named file.
This generates Elisp code that, when loaded, defines the requisite
symbols and keymaps for a functional Color Browser palette."
(unless (file-directory-p cb-palettes-dir)
(make-directory cb-palettes-dir 'parents))
(save-excursion
(set-buffer buffer)
(let* ((palette (if as (cb-read-name "Palette name: "
cb-palette-list
cb-name
'cb-save-palette-hist)
cb-name
))
(symbol (concat "cb-" palette "-palette"))
(file-name (concat cb-palettes-dir palette "-palette.el"))
color-names)
(when (or (string-equal palette "All-Colors")
(string-equal palette "No-Colors"))
(error "The palette name \"%s\" is reserved for internal use."
palette))
(beginning-of-buffer)
(while (search-forward "[DEL]" nil t)
(forward-char 2)
(setq color-names
(append color-names
(list (get-char-property (point) 'color)))))
(when (file-exists-p file-name)
(copy-file file-name (concat file-name ".bak") 'overwrite))
(save-excursion
(set-buffer (find-file-noselect file-name 'nowarn 'raw))
(erase-buffer)
(insert (concat "\n(defvar " symbol "'()"))
(insert "\n\"Color palette created by " (user-full-name)
" on " (current-time-string) "\")\n")
(insert ";; Ensure that the value changes when is the file reloaded\n")
(insert "(setq " symbol " '(")
(dolist (color color-names) (insert "\"" color "\" "))
(insert "))\n")
(insert
"\n(define-key cb-current-palettes-menu [" symbol "]"
"\n '(menu-item \"" palette "\""
"\n (lambda () (interactive)"
"\n (cb-redraw-buffer cb-current-palette-buffer"
"\n (list 'cb-list '" symbol " )))"
"\n :button (:radio . (save-excursion "
"\n (set-buffer cb-current-palette-buffer)"
"\n (string-equal cb-name \"" palette "\")"
"))))")
(save-buffer)
(kill-this-buffer))
(load-file file-name)
(setq cb-old-palettes-menu
(cb-swap-keymap-functions
(copy-keymap cb-current-palettes-menu)
'cb-old-palette-buffer))
(setq cb-new-palettes-menu
(cb-swap-keymap-functions
(copy-keymap cb-current-palettes-menu)
'cb-new-palette-buffer))
(cb-build-palette-maps)
(setq cb-palette-list (add-to-list 'cb-palette-list palette))
(setq header-line-format nil)
(setq cb-name palette)
(force-mode-line-update)
(message "wrote file: %s" file-name)
(unless (equal buffer cb-new-palette-buffer)
(set-buffer cb-new-palette-buffer)
(when (string-equal cb-name palette)
(cb-redraw-buffer cb-new-palette-buffer)))
(unless (equal buffer cb-old-palette-buffer)
(set-buffer cb-old-palette-buffer)
(when (string-equal cb-name palette)
(cb-redraw-buffer cb-old-palette-buffer)))
(unless (equal buffer cb-current-palette-buffer)
(set-buffer cb-current-palette-buffer)
(when (string-equal cb-name palette)
(cb-redraw-buffer cb-current-palette-buffer)))
)))
(defun cb-delete-palette (buffer)
"Delete the palette file for the palette displayed in BUFFER."
(save-excursion
(set-buffer buffer)
(when (or (string-equal cb-name "All-Colors")
(string-equal cb-name "No-Colors"))
(error "The palette name \"%s\" is reserved for internal use."
cb-name))
(let ((symbol (concat "cb-" cb-name "-palette"))
(file (concat cb-palettes-dir cb-name "-palette.el")))
(when (not (file-exists-p file))
(error "Could not find palette file for palette \"%s\"" cb-name))
(when (yes-or-no-p (concat "Delete " file "? "))
(delete-file file)
(cb-build-palette-list)
(cb-build-palette-maps)
(cb-redraw-buffer buffer (list 'cb-list cb-default))
))))
(defun cb-toggle-layer (buffer)
"Toggle the layer of the palette displayed in BUFFER."
(let* ((layer (save-excursion (set-buffer buffer) cb-layer))
(layer (if (string-equal layer "foreground" )
"background" "foreground")))
(cb-redraw-buffer buffer (list 'cb-layer layer))
))
(defvar cb-current-palettes-map (make-sparse-keymap))
(defvar cb-old-palettes-map (make-sparse-keymap))
(defvar cb-new-palettes-map (make-sparse-keymap))
(defvar cb-toggle-mode-map (make-sparse-keymap))
(defvar cb-toggle-current-layer-map (make-sparse-keymap))
(defvar cb-toggle-old-layer-map (make-sparse-keymap))
(defvar cb-toggle-new-layer-map (make-sparse-keymap))
(defun cb-build-palette-maps ()
"Thsi must be called after cb-build-palette-list."
(define-key cb-current-palettes-map [(mode-line) (mouse-1)] 'ignore)
(define-key cb-current-palettes-map [(mode-line) (mouse-2)] cb-current-palettes-menu)
(define-key cb-current-palettes-map [(mode-line) (down-mouse-2)] cb-current-palettes-menu)
(define-key cb-current-palettes-map [(mode-line) (mouse-3)] 'ignore)
(define-key cb-old-palettes-map [(mode-line) (mouse-1)] 'ignore)
(define-key cb-old-palettes-map [(mode-line) (mouse-2)] cb-old-palettes-menu)
(define-key cb-old-palettes-map [(mode-line) (down-mouse-2)] cb-old-palettes-menu)
(define-key cb-old-palettes-map [(mode-line) (mouse-3)] 'ignore)
(define-key cb-new-palettes-map [(mode-line) (mouse-1)] 'ignore)
(define-key cb-new-palettes-map [(mode-line) (mouse-2)] cb-new-palettes-menu)
(define-key cb-new-palettes-map [(mode-line) (mouse-3)] 'ignore)
(define-key cb-new-palettes-map [(mode-line) (down-mouse-2)] cb-new-palettes-menu)
(define-key cb-toggle-mode-map [(mode-line) (mouse-1)] 'ignore)
(define-key cb-toggle-mode-map [(mode-line) (mouse-2)] 'cb-toggle-mode)
(define-key cb-toggle-mode-map [(mode-line) (mouse-3)] 'ignore)
(define-key cb-toggle-current-layer-map [(mode-line) (mouse-1)] 'ignore)
(define-key cb-toggle-current-layer-map [(mode-line) (mouse-2)]
(lambda () (interactive) (cb-toggle-layer cb-current-palette-buffer)))
(define-key cb-toggle-current-layer-map [(mode-line) (mouse-3)] 'ignore)
(define-key cb-toggle-old-layer-map [(mode-line) (mouse-1)] 'ignore)
(define-key cb-toggle-old-layer-map [(mode-line) (mouse-2)]
(lambda () (interactive) (cb-toggle-layer cb-old-palette-buffer)))
(define-key cb-toggle-old-layer-map [(mode-line) (mouse-3)] 'ignore)
(define-key cb-toggle-new-layer-map [(mode-line) (mouse-1)] 'ignore)
(define-key cb-toggle-new-layer-map [(mode-line) (mouse-2)]
(lambda () (interactive) (cb-toggle-layer cb-new-palette-buffer)))
(define-key cb-toggle-new-layer-map [(mode-line) (mouse-3)] 'ignore)
)
(defun cb-delete-this-color (click)
"Delete the color line under point. Action bound to [DEL] buttons."
(interactive "@e")
(save-excursion
(when (eventp click)
(select-window (posn-window (event-start click)))
(goto-char (posn-point (event-start click))))
(beginning-of-line)
(let ((inhibit-read-only t))
(kill-line 1))
(setq header-line-format "Palette Modified")
(force-mode-line-update)))
(defun cb-this-color-up (click)
"Move the color line under point up one line. Action bound to [UP] buttons."
(interactive "@e")
(save-excursion
(when (eventp click)
(select-window (posn-window (event-start click)))
(goto-char (posn-point (event-start click))))
(let ((inhibit-read-only t)
(kill-ring kill-ring))
(beginning-of-line)
(kill-line 1)
(forward-line -1)
(when (bobp)
(end-of-buffer)
(forward-line -1))
(yank)
(setq header-line-format "Palette Modified")
(force-mode-line-update)
)))
(defun cb-last-color-down (click)
"Move the last color line in the buffer to the top of the list.
This action is bound to the [DOWN] button."
(interactive "@e")
(save-excursion
(when (eventp click)
(select-window (posn-window (event-start click))))
(let ((inhibit-read-only t)
(kill-ring kill-ring))
(end-of-buffer)
(forward-line -2)
(beginning-of-line)
(kill-line 1)
(beginning-of-buffer)
(forward-line 1)
(yank)
(setq header-line-format "Palette Modified")
(force-mode-line-update)
)))
(defun cb-add-color (&optional click)
"Copy the color line under point to the \"New Palette\" buffer.
This function should only be called by active text in the \"Old Palettes\"
buffer."
(interactive "@e")
(save-excursion
(let ((inhibit-read-only t)
(echo-map (make-sparse-keymap))
start)
(define-key echo-map [(mouse-2)] 'cb-echo-color)
(define-key echo-map [(down-mouse-2)] 'cb-echo-color)
(define-key echo-map [(return)] 'cb-echo-color)
(when (eventp click)
(select-window (posn-window (event-start click)))
(goto-char (posn-point (event-start click))))
(beginning-of-line)
(copy-region-as-kill (point) (save-excursion (forward-line 1) (point)))
(set-buffer cb-new-palette-buffer)
(beginning-of-line)
(unless (looking-at "\\[DEL\\]") (beginning-of-buffer))
(when (bobp) (forward-line 1))
(setq start (point))
(yank 1)
(add-text-properties (+ start 6) (- (point) 5)
(list 'keymap echo-map))
(setq header-line-format "Palette Modified")
(force-mode-line-update)
)))
(defun cb-echo-color (&optional click)
"Echo the color of the text under point or mouse.
Uses the text property `layer' to determine whether the foreground or
background is echoed. This function should only be called by active
text in the \"*New Palette*\" buffer."
(interactive "@e")
(save-excursion
(let* ((point (point)))
(when (eventp click)
(set-buffer (window-buffer (posn-window (event-start click))))
(setq point (posn-point (event-start click))))
(message "layer: %s, color: %s, weight: %s"
(get-char-property point 'layer)
(get-char-property point 'color)
(or (get-char-property point 'weight) 'normal)
))))
(defun cb-change-color (&optional click)
"Change the default text color to that under point or mouse.
Uses the text property `layer' to determine whether the foreground or
background is changed. This function should only be called by active
text in the \"*Current Palette*\" buffer."
(interactive "@e")
(let* ((point (point)))
(save-excursion
(when (eventp click)
(set-buffer (window-buffer (posn-window (event-start click))))
(setq point (posn-point (event-start click))))
(set-face-attribute cb-active-face nil
(get-char-property point 'layer)
(get-char-property point 'color)
)))
(save-excursion
(set-buffer cb-face-group-buffer)
(setq header-line-format "Theme Modified")
(force-mode-line-update)))
(defun cb-build-color-palette-buffer ()
"Insert a structured list of colors from the list PALETTE into the
current buffer. Colors are presented one per line in both foreground
and background forms. Text properties are arranged so that mouse-2
\(or return) on any of the color names will run ACTION which is
intended to use the value of `color' and `layer' properties under the
mouse (or point). The first line contains an buttons that let you set
the face property to an unspecified value. Each line is preceded a
\[DEL] button that deletes the line, and is followed by a [UP] button
that swaps the current line with the one above. The first line of the
buffer allows you to set the color properties to the `unspecified'
value."
(setq cb-name (substring (substring (symbol-name cb-list) 3) 0 -8))
(let* ((list (eval cb-list))
(mouse-map (make-sparse-keymap))
(del-map (make-sparse-keymap))
(up-map (make-sparse-keymap))
(down-map (make-sparse-keymap))
(width (- cb-frame-width 6 5 1))
(width-str (number-to-string width))
(background-p (string-equal cb-layer "background"))
start)
(define-key mouse-map [(mouse-2)] cb-action)
(define-key del-map [(mouse-2)] 'cb-delete-this-color)
(define-key up-map [(mouse-2)] 'cb-this-color-up)
(define-key down-map [(mouse-2)] 'cb-last-color-down)
(define-key mouse-map [(down-mouse-2)] cb-action)
(define-key del-map [(down-mouse-2)] 'cb-delete-this-color)
(define-key up-map [(down-mouse-2)] 'cb-this-color-up)
(define-key down-map [(down-mouse-2)] 'cb-last-color-down)
(define-key mouse-map [(return)] cb-action)
(define-key del-map [(return)] 'cb-delete-this-color)
(define-key up-map [(return)] 'cb-this-color-up)
(define-key down-map [(return)] 'cb-last-color-down)
(insert " ")
(setq start (point))
(if background-p
(progn
(insert (substring (format (concat "%" width-str "s")
"unspecified")
0 width))
(set-text-properties start (point)
(list 'layer ':background
'weight 'normal
'color 'unspecified
'mouse-face 'highlight
'keymap mouse-map)))
(insert (substring (format (concat "%" width-str "s")
"unspecified")
0 width))
(set-text-properties start (point)
(list 'layer ':foreground
'weight 'normal
'color 'unspecified
'mouse-face 'highlight
'keymap mouse-map)))
(insert "\n")
(let ((l list))
(while (cdr l)
(if (facemenu-color-equal (car l) (car (cdr l)))
(setcdr l (cdr (cdr l)))
(setq l (cdr l)))))
(while list
(setq start (point))
(insert "[DEL]")
(set-text-properties start (point)
(list 'face 'widget-button-face
'mouse-face 'highlight
'keymap del-map))
(insert " ")
(setq start (point))
(let ((start start))
(if background-p
(progn
(insert (substring (format (concat "%" width-str "s")
(concat (car list)
(car list)
(car list)
(car list)))
0 width))
(set-text-properties start (point)
(list 'layer ':background
'weight 'normal
'face `(:background ,(car list))
'mouse-face 'highlight)))
(setq start (point))
(insert (substring (format (concat "%" width-str "s")
(concat (car list)
(car list)
(car list)
(car list)))
0 width))
(set-text-properties start (point)
(list 'layer ':foreground
'weight 'normal
'face `(:foreground ,(car list))
'mouse-face 'highlight))
))
(add-text-properties start (point)
(list 'color (car list)
'keymap mouse-map))
(insert " ")
(setq start (point))
(insert "[UP]")
(set-text-properties start (point)
(list 'face widget-button-face
'mouse-face 'highlight
'keymap up-map))
(insert "\n")
(setq list (cdr list)))
(indent-to (+ 5 width))
(setq start (point))
(insert "[DOWN]")
(set-text-properties start (point)
(list 'face widget-button-face
'mouse-face 'highlight
'keymap down-map))
(insert "\n")
(buffer-enable-undo)
(setq mode-line-format
(list
(propertize "<Palette>"
'face 'menu
'local-map (eval cb-map)
'help-echo "mouse: select palette")
(propertize (if background-p " <Foreground>" " <Background>")
'face 'menu
'local-map (eval cb-layer-map)
'help-echo "mouse: change layer")
'(:eval (propertize (if cb-theme-builder-p " <PB>" " <TB>")
'face 'menu
'local-map cb-toggle-mode-map
'help-echo "mouse: change mode"))
))
(setq header-line-format nil)
(force-mode-line-update)
))
(defun cb-quit ()
"Delete all frames and buffers associated with the color browser."
(interactive)
(select-frame-by-name "Color Browser")
(condition-case nil (kill-buffer cb-current-palette-buffer) (error nil))
(condition-case nil (kill-buffer cb-new-palette-buffer) (error nil))
(condition-case nil (kill-buffer cb-old-palette-buffer) (error nil))
(condition-case nil (kill-buffer cb-face-group-buffer) (error nil))
(delete-frame))
(defun cb-read-only-undo ()
"Version of undo that works in read-only buffers. Since the buffer
is read-only hits will undo special edit that also set
`inhibit-read-only'."
(interactive)
(let ((inhibit-read-only t))
(undo)))
(defvar cb-redraw-function nil
"Buffer local variable holding the function used to redraw the buffer.")
(make-variable-buffer-local 'cb-redraw-function)
(defun cb-redraw-buffer (buffer &rest settings)
"Set buffer local variables in BUFFER from the list of variable /value
pairs in SETTINGS then redraw using the function held in the variable
cb-redraw-function."
(save-window-excursion
(save-excursion
(dolist (window (window-list))
(when (equal (window-buffer window) buffer)
(select-window window)))
(set-buffer buffer)
(dolist (pair settings)
(set (car pair) (cadr pair)))
(let ((inhibit-read-only t))
(erase-buffer)
(funcall cb-redraw-function))
)))
(defun cb-buffer-prepare (name)
"Create an empty a view-mode buffer called NAME
that initally ignores mouse-2 events, uses a special quit command
`cb-quit', and allow the keyboard undo command. That buffer selected
and the BODY form evaluated."
(set-buffer (get-buffer-create name))
(view-mode 1)
(use-local-map view-mode-map)
(local-set-key [(mouse-2)] 'ignore)
(local-set-key [(q)] 'cb-quit)
(local-set-key [(control ?/)] 'cb-read-only-undo)
(local-set-key [(control ?_)] 'cb-read-only-undo)
(current-buffer))
(defun cb-toggle-mode ()
"Toggle between Theme Builder and Palette Builder modes. This is
normally called via a keymap bound to text in the mode-line."
(interactive)
(if cb-theme-builder-p
(color-browser t)
(color-browser nil)))
(defun cb-initialize ()
"Setup initial color browser frame, buffers, and menu maps."
(interactive)
(select-frame
(make-frame
`((name . "Color Browser")
(width . ,cb-frame-width)
(height . ,cb-frame-height)
(minibuffer . nil)
(menu-bar-lines . nil)
(tool-bar-lines . nil)
(unsplittable. t)
)))
(cb-build-theme-list)
(cb-build-face-group-maps)
(cb-build-palette-list)
(cb-build-palette-maps)
(cb-redraw-buffer
(setq cb-face-group-buffer (cb-buffer-prepare " *Face Group*"))
(list 'cb-list 'cb-Basic-faces-plist)
(list 'cb-default 'cb-Basic-faces-plist)
(list 'cb-redraw-function 'cb-build-face-group-buffer))
(cb-redraw-buffer
(setq cb-current-palette-buffer (cb-buffer-prepare " *Current Palette*"))
(list 'cb-map 'cb-current-palettes-map)
(list 'cb-list 'cb-All-Colors-palette)
(list 'cb-default 'cb-All-Colors-palette)
(list 'cb-action 'cb-change-color)
(list 'cb-layer "foreground")
(list 'cb-layer-map 'cb-toggle-current-layer-map )
(list 'cb-redraw-function 'cb-build-color-palette-buffer))
(cb-redraw-buffer
(setq cb-old-palette-buffer (cb-buffer-prepare " *Old Palette*"))
(list 'cb-map 'cb-old-palettes-map)
(list 'cb-list 'cb-All-Colors-palette)
(list 'cb-default 'cb-All-Colors-palette)
(list 'cb-action 'cb-add-color)
(list 'cb-layer "foreground")
(list 'cb-layer-map 'cb-toggle-old-layer-map )
(list 'cb-redraw-function 'cb-build-color-palette-buffer))
(cb-redraw-buffer
(setq cb-new-palette-buffer (cb-buffer-prepare " *New Palette*"))
(list 'cb-map 'cb-new-palettes-map)
(list 'cb-list 'cb-No-Colors-palette)
(list 'cb-default 'cb-No-Colors-palette)
(list 'cb-action 'cb-echo-color)
(list 'cb-layer "foreground")
(list 'cb-layer-map 'cb-toggle-new-layer-map )
(list 'cb-redraw-function 'cb-build-color-palette-buffer))
)
(defun color-browser (&optional palette-builder)
"*Pop up a frame containing a color theme design tool.
If PALETTE-BUILDER is t, this tool consists of two color palette
buffers \(see `cb-build-color-palette-buffer'). Otherwise it consists
of on Color Palette buffer and one face group buffer \(see
`cb-build-face-group-buffer')"
(interactive) (save-excursion
(condition-case nil
(progn
(select-frame-by-name "Color Browser")
(raise-frame))
(error (cb-initialize)))
(set-mouse-position
(selected-frame)
(frame-width) (- (frame-height) 1))
(delete-other-windows)
(cond (palette-builder
(setq cb-theme-builder-p nil)
(modify-frame-parameters nil '((title . "CB - Palette Builder")))
(switch-to-buffer cb-old-palette-buffer)
(split-window-vertically)
(switch-to-buffer cb-new-palette-buffer))
(t
(setq cb-theme-builder-p t)
(modify-frame-parameters nil '((title . "CB - Theme Builder")))
(switch-to-buffer cb-current-palette-buffer)
(split-window-vertically)
(switch-to-buffer cb-face-group-buffer)
(set-window-text-height (selected-window) (/ (frame-height) 2))
(shrink-window-if-larger-than-buffer)
))
))
(provide 'color-browser)