Download
(require 'cl)
(require 'time-stamp)
(defvar color-theme-x-color-theme-source nil
"*The full path to your color-theme.el.
If this variable is nil, then the default is to discover the path
via `locate-library'")
(defvar color-theme-x-supported-attributes
'((:foreground . "Foreground")
(:background . "Background")
(:bold . "Bold")
(:italic . "Italic")
(:underline . "Underline")))
(defvar color-theme-x-supported-basic-attibutes
'((background-color . "background")
(foreground-color . "foreground")
(mouse-color . "pointerColor")
(cursor-color . "cursorColor")
(border-color . "borderColor")))
(defvar color-theme-x-output-buffer-name "*color-theme-xresources*")
(defvar color-theme-x-output-buffer nil)
(defun color-theme-x-locate-color-theme-source ()
(or color-theme-x-color-theme-source (locate-library "color-theme.el")))
(defun color-theme-x-read-theme (name &optional source)
(save-excursion
(with-temp-buffer
(insert-file-contents-literally (or source (color-theme-x-locate-color-theme-source)))
(goto-char 0)
(when (and (search-forward-regexp (concat "^(defun color-theme-" name) (point-max) t)
(search-forward "color-theme-install"))
(next-line 0)
(let ((function (read (current-buffer))))
(values (cdadr function)
(cadadr function)))))))
(defun color-theme-x-list-to-paired-list (list)
(let ((l list)
(resultant nil))
(while l
(let ((attribute (car l))
(value (cadr l)))
(setq resultant (cons (cons attribute value) resultant))
(setq l (cddr l))))
(nreverse resultant)))
(defun color-theme-x-traverse-theme (theme function)
(dolist (e theme)
(ignore-errors
(destructuring-bind (face-name ((true face-attributes))) e
(if (and (symbolp face-name)
(eq true t)
(listp face-attributes))
(funcall function
(symbol-name face-name)
(color-theme-x-list-to-paired-list face-attributes)))))))
(defun color-theme-x-traverse-basic-theme (theme function)
(dolist (e theme)
(let ((name (cdr (assoc (car e) color-theme-x-supported-basic-attibutes)))
(value (cdr e)))
(when name
(funcall function name (cdr e))))))
(defun color-theme-x-lisp-to-resource (value)
"Convert lisp symbols to X resource values."
(cond ((eq value t)
"on")
(t
value)))
(defun color-theme-x-xresource-writer (face-name attributes)
(dolist (a attributes)
(let ((attribute (car a))
(value (cdr a)))
(let ((xresource-attribute (cdr (assoc attribute color-theme-x-supported-attributes))))
(when xresource-attribute
(insert (format "\"Emacs.%s.attribute%s\"=\"%s\"\n"
face-name
xresource-attribute
(color-theme-x-lisp-to-resource value))))))))
(defun color-theme-x-basic-xresource-writer (name value)
(insert (format "\"Emacs.%s\"=\"%s\"\n" name value)))
(defun color-theme-reg (theme-name &optional theme-source)
(interactive
(list (read-string "Name of theme: ")
(and current-prefix-arg (read-file-name "Path to theme source: "))))
(setq theme-source (or theme-source (color-theme-x-locate-color-theme-source)))
(save-excursion
(setq color-theme-x-output-buffer
(get-buffer-create (or color-theme-x-output-buffer-name "*color-theme-xresources*")))
(set-buffer color-theme-x-output-buffer)
(goto-char (point-max))
(beginning-of-line)
(insert "Windows Registry Editor Version 5.00")
(insert "\n# X resources for color-theme-" theme-name)
(insert "\n# Generated by ctresource " (time-stamp-string) "\n\n")
(insert "\n[HKEY_LOCAL_MACHINE\\SOFTWARE\\GNU\\Emacs]\n")
(multiple-value-bind (face-resources basic-resources)
(color-theme-x-read-theme theme-name theme-source)
(color-theme-x-traverse-basic-theme basic-resources 'color-theme-x-basic-xresource-writer)
(color-theme-x-traverse-theme face-resources 'color-theme-x-xresource-writer))
(pop-to-buffer color-theme-x-output-buffer)))
(provide 'color-theme-reg)