;;; xpm-mode.el --- minor mode for editing XPM files ;; Copyright (C) 1995 Joe Rumsey ;; Copyright (C) 1995 Rich Williams ;; Copyright (C) 2011 Byrel Mitchell ;; Copyright (C) 2011 Steve Mitchell ;; Authors: Joe Rumsey ;; Rich Williams ;; Cleanup: Chuck Thompson ;; New features and fixes: Byrel Mitchell ;; New Features and fixes: Steven Mitchell ;; Version: 2.0 ;; Modified: Rich Williams , 13 July 1995 ;; Last Modified Byrel and Steve Mitchell, 9 July 2011 ;; Keywords: data tools ;; This file is part of XEmacs. ;; XEmacs is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; XEmacs is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. ;; ;; xpm mode: Display xpm files in color ;; ;; thanks to Rich Williams for mods to do this without font-lock-mode, ;; resulting in much improved performance and a better display ;; (headers don't get colored strangely). Also for the palette toolbar. ;; ;; Non-standard minor mode in that it starts picture-mode automatically. ;; ;; To get this turned on automatically for .xpms, add an entry ;; ("\\.xpm" . xpm-mode) ;; to your auto-mode-alist. For example, my .emacs has this: (abbreviated) ;; (setq auto-mode-alist (mapcar 'purecopy ;; '(("\\.c$" . c-mode) ;; ("\\.h$" . c-mode) ;; ("\\.el$" . emacs-lisp-mode) ;; ("\\.emacs$" . emacs-lisp-mode) ;; ("\\.a$" . c-mode) ;; ("\\.xpm" . xpm-mode)))) ;; (autoload 'xpm-mode "xpm-mode") ;; ;; I am a lisp newbie, practically everything in here I had to look up ;; in the manual. It probably shows, suggestions for coding ;; improvements are welcomed. ;; ;; May fail on some xpm's. Seems to be fine with files generated by ;; xpaint and ppmtoxpm anyway. Will definitely fail on xpm's with ;; more than one character per pixel. Not that hard to fix, but I've ;; never seen one like that. ;; ;; If your default font is proportional, this will not be very useful. ;; ;; Changes 7/2011: ;; - added doc strings to existing functions ;; - changed several functions with eye toward speed of execution. ;; - fixed support for multi-byte colors in several functions, ;; these occur when more than ~100 colors exist in an .xpm ;; which are very common in xpm's used today. ;; - added support for Alpha layer, inplemented as an xpm extension ;; - added an xpm-mode toolbar with 16 new icons ;; - added function to create a new blank xpm, w/transparent background ;; - added functions to create several kinds of gradient backgrounds ;; - added feature to overlay one xpm onto another xpm, combining ;; data, combining color maps into a new color map, ;; fixing color name collisions, removing unused colors ;; the 2nd file can be overlaid with x and/or y offsets. ;; - added functions to shift image up/down/left/right by pixel(s) ;; - added functions to rotate xpm 90 deg. cc and ccw ;; - added functions to mirror the xpm about horiz. and vert. axis' ;; - added cropping of xpm, updating 'colors' & 'values' sections to match. ;; - added function to enlarge an existing XPM in width and/or height ;; - added function to create a 3d "bevel" around outside of an xpm. ;; - in the colors section, displays the colors on the same line that ;; defines them, useful for "seeing" RGB colors in hexedecimal. ;; - added function to show/hide the characters in the pixels section to ;; make the image more like what the fiished xpm will look like. ;; - with all the new commands, added a menu button "xpm mode help" with ;; a list of commands for reference, opens in new window. ;; - added functions to dim or brighten the image with the alpha channel. ;; perhaps also useful for creating greyed-out disabled buttons. ;; ;; ;; Future Items still to do: ;; 1. on files with large number of colors, creating the color pallet ;; icons on the side toolbar still takes inordinately long. ;; a 128 x 128 image could have up to 16,384 colors, though commonly ;; has 700-2000 colors per file ;; Explore faster way to generate these. ;; we stopped it generating them after the first 200 colors, as you ;; cannot display more that (a 30" monitor = a column of 96 per side) ;; ;; 2. Rather than just attempting to load in a file and hoping it is ;; formatted correctly, we should examine the file and make sure: ;; -that it is an xpm file, no matter filename extension ;; -that each of the 5 sections can be parsed and contain the right ;; amount of data. ;; -generate error codes that tell exactly what it cannot parse ;; and which line number it fails at. ;; ;; 3. Since 2 characters wide is about square on most monitors, and it ;; is a better representation of the graphic as a whole, maybe ;; we should eliminate the displaying of single-byte colored files ;; and display both single and 2-byte-color xpms as 2 chars wide in ;; our display. When saved, they would have been converted to 2-byte ;; per color files, which is not a big deal--they get displayed on a ;; computer the same... ;; ;; to run, load an xpm into XEmacs, or type M-x xpm-mode in the minibuffer. ;; ;;; Code: (require 'annotations) (defvar xpm-gradient-menu nil) (defvar xpm-menu nil) (defvar xpm-open-icon nil) (defvar xpm-save-icon nil) (defvar xpm-undo-icon nil) (defvar xpm-new-image-icon nil) (defvar xpm-sh-l-icon nil) (defvar xpm-sh-r-icon nil) (defvar xpm-sh-u-icon nil) (defvar xpm-sh-d-icon nil) (defvar xpm-r-cw-icon nil) (defvar xpm-r-ccw-icon nil) (defvar xpm-m-vert-icon nil) (defvar xpm-m-horiz-icon nil) (defvar xpm-crop-icon nil) (defvar xpm-enlarge-icon nil) (defvar xpm-show-chars-icon nil) (defvar xpm-hide-chars-icon nil) (defvar xpm-color-icon nil) (defvar xpm-chars-icon nil) (defvar xpm-black-color-icon-path nil) (defvar xpm-white-color-icon-path nil) (defvar xpm-help-icon nil) (defvar xpm-pencil-icon nil) (defvar xpm-eyedropper-image nil) (defvar xpm-pencil-image nil) (defvar xpm-select-image nil) (defvar xpm-tool 'xpm-eyedropper "Should be the name of a tool implemented in xpm mode. Currently, there are only three tools: 'xpm-pencil 'xpm-select 'xpm-eyedropper") (defvar text-modes-toolbar-icon-directory nil) (defvar xpm-pixel-values nil) (defvar xpm-alpha-values nil) (defvar xpm-glyph nil) (defvar xpm-anno nil) (defvar xpm-paint-string nil) (defvar xpm-xsize 1) (defvar xpm-ysize 1) (defvar xpm-num-colors 1) (defvar xpm-chars-per-pixel 1) (defvar xpm-color-start 1) (defvar xpm-body-start 1) (defvar xpm-body-end 1) (defvar xpm-palette nil) (defvar xpm-image-cache nil) (defvar xpm-always-update-image nil "If non-nil, update actual-size image after every click or drag movement. Otherwise, only update on button releases or when asked to. This is slow.") (defvar xpm-max-palette-size 200 "Maximum number of colors loaded into pallete. You can set this higher if you want, but each color takes up about 15 pixels, so the default will still take the full screen height on nearly all displays. Setting s this too high will make loading xpms with large numbers of colors slow.") (defvar xpm-show-characters nil) (defvar xpm-toolbar '([ xpm-open-icon toolbar-open t "Open a file" ] [ xpm-save-icon toolbar-save t "Save a file" ] [ xpm-undo-icon toolbar-undo t "Undo Edit" ] [ xpm-new-image-icon xpm-new-transparent t "Create New XPM file" ] [ xpm-sh-l-icon (lambda () (interactive) (xpm-shift-image-left 1)) t "Shift left 1 pixel" ] [ xpm-sh-r-icon (lambda () (interactive) (xpm-shift-image-right 1)) t "Shift right 1 pixel" ] [ xpm-sh-u-icon (lambda () (interactive) (xpm-shift-image-up 1)) t "Shift up 1 pixel" ] [ xpm-sh-d-icon (lambda () (interactive) (xpm-shift-image-down 1)) t "Shift down 1 pixel" ] [ xpm-r-cw-icon xpm-rotate-image-cw t "Rotate Clockwise 90 degrees." ] [ xpm-r-ccw-icon xpm-rotate-image-ccw t "Rotate Counter-Clockwise 90 degrees." ] [ xpm-m-vert-icon xpm-mirror-image-vertical-axis t "Mirror about Vertical axis" ] [ xpm-m-horiz-icon xpm-mirror-image-horizontal-axis t "Mirror about Horizontal axis" ] [ xpm-enlarge-icon xpm-enlarge t "Enlarge XPM height and/or width" ] [ xpm-chars-icon xpm-toggle-chars t "Show/Hide characters in the graphic." ] [ xpm-pencil-icon xpm-pencil-tool t "Switch to the pencil tool" ] [ xpm-color-icon xpm-eyedropper-tool t "switch to the set color tool" ] [ xpm-crop-icon xpm-crop t "Mark with mouse, crop tool" ] nil [ xpm-help-icon xpm-help-display t "List commands for xpm-editor" ])) (defun xpm-make-face (name) "Makes a face with name xpm-NAME, and colour NAME." (let ((face (make-face (intern (concat "xpm-" name)) "Temporary xpm-mode face" t))) (set-face-background face name) face)) (defun xpm-init () "Treat the current buffer as an xpm file and colorize it." (interactive) (require 'picture) (setq xpm-alpha-values nil) (setq xpm-pixel-values nil) (xpm-clear-extents) (setq xpm-palette nil) (message "Mapping Buffer...") (xpm-map-buffer) (message "Finding number of colors...") (save-excursion (goto-char xpm-color-start) (loop repeat xpm-num-colors do (xpm-parse-color "c") (forward-line))) (save-excursion (goto-char (point-min)) (when (search-forward-regexp "\"XPMEXT *xemacs_alpha_values" nil t) (forward-line) (loop until (search-forward "\"XPMENDEXT" (point-at-eol) t) do (xpm-parse-color "a") (forward-line)))) (if (featurep 'toolbar) (progn ;; Use `current-buffer', not `selected-frame', here. ;; Fixes bug where switching to another buffer causes its ;; full-width left toolbar to be truncated to the xpm-mode ;; palette (16 pixels). Causes "window bounce" if sharing a ;; frame with a window displaying a buffer with a full-width ;; toolbar (suggested workaround: don't reset toolbar width ;; for palette). (set-specifier left-toolbar-width (cons (current-buffer) 16)) (set-specifier left-toolbar (cons (current-buffer) xpm-palette)))) (message "Parsing body...") (xpm-color-colors) (xpm-color-data) (xpm-color-alpha-extension) (message "Parsing body...done") (xpm-show-image)) (defun xpm-clear-extents () "Clears all extents in the current buffer." (loop for ext being the extents of (current-buffer) do (delete-extent ext))) (defun xpm-color-data () "Make extents and color them for each pixel in the xpm." (interactive) (save-excursion (xpm-goto-body-line 0) (let (ext pixel-chars pixel-color) (loop until (search-forward "\"XPMEXT" (point-at-eol) t) while (< (+ (point) xpm-chars-per-pixel) (point-max)) do (if (string-match "\"" (buffer-substring (point) (+ (point) xpm-chars-per-pixel))) ;If there is a quote in our next chunk (progn (search-forward "\"") (unless (string-match "^\\s-*\"$" (buffer-substring (point-at-bol) (point))) ; unless nothing but whitespace before quote (forward-line))) (setq pixel-chars (buffer-substring (point) (+ (point) xpm-chars-per-pixel)) pixel-color (assoc pixel-chars xpm-pixel-values) ext (make-extent (point) (+ (point) xpm-chars-per-pixel))) (if pixel-color (progn (set-extent-face ext (cdr pixel-color))) (set-extent-face ext 'default)) (forward-char xpm-chars-per-pixel)))))) (defun xpm-color-colors () "Make extents and color them for every color defined in xpm" (interactive) (save-excursion (xpm-goto-color-def 0) (loop for colornum from 1 to xpm-num-colors do (search-forward-regexp (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\)") nil t) (let* ((pixel-color (assoc (match-string 1) xpm-pixel-values)) (ext (make-extent (match-beginning 1) (match-end 1)))) (if pixel-color (progn (set-extent-face ext (cdr pixel-color))) (set-extent-face ext 'default))) (forward-line)))) (defun xpm-color-alpha-extension () "Make extents and color them for every color defined in xpm" (interactive) (save-excursion (goto-char (point-min)) (when (search-forward-regexp "\"XPMEXT *xemacs_alpha_values" nil t) (forward-line) (loop until (search-forward "\"XPMENDEXT" (point-at-eol) t) do (search-forward-regexp (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\)") nil t) (let* ((pixel-color (assoc (match-string 1) xpm-pixel-values)) (ext (make-extent (match-beginning 1) (match-end 1)))) (if pixel-color (progn (set-extent-face ext (cdr pixel-color))) (set-extent-face ext 'default))) (forward-line))))) (defun xpm-make-solid-image-strings (width height) "Makes a pair of strings, which can be used to make a solid color xpm image. The first string consists of the header section, the values section, and the first part of the color section. The second string is rest of the color section, and the image body. concat with a color name in between for a complete xpm file. Image body will be `width' x `height' size, and will use ?\\. as the symbol for the color. The return value is a list of the two strings. So you can, for instance, make a green glyph of this image as follows: \(let \(strings \(xpm-make-solid-image-strings\)\) \(make-glyph \(concat \(car strings\) \"green\" \(cadr strings\)\)\)\)" (unless (and (eq (car xpm-image-cache) width) (eq (cadr xpm-image-cache) height)) (setq xpm-image-cache (cons width (cons height (list (concat "/* XPM */\nstatic char * solid[] = {\n\"" (format "%d %d" width height) " 1 1\",\n\". \tc ") (concat (loop repeat height concat "\",\n\"" concat (make-string width ?.)) "\"};\n")))))) (cddr xpm-image-cache)) (defun xpm-store-alpha (str alpha) "Add STR to xpm-alpha-values." (setq xpm-alpha-values (cons (cons str alpha) xpm-alpha-values))) (defun xpm-add-alpha-extension () "Adds an alpha extension section to the current xpm." (interactive) (save-excursion (goto-char (point-min)) (unless (search-forward-regexp "XPMEXT\\s-*xemacs_alpha_values" nil t) (let (transparent-colors) (goto-char xpm-color-start) (setq transparent-colors (loop repeat xpm-num-colors while (search-forward-regexp (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\).*?c\\s-*\\(none\\)\\(\\s-\\|\"\\)" ) nil t) collect (match-string 1))) (goto-char xpm-body-end) (forward-line) (insert "\"XPMEXT xemacs_alpha_values\",\n" (loop for symbol in transparent-colors concat "\"" concat symbol concat "\ta 0\",\n") "\"XPMENDEXT\",") (unless (search-forward "};" nil t) (search-backward "\",") (replace-match "\"};")) (backward-char) (while (search-backward "\"};" nil t) (replace-match "\",")))))) (defun xpm-make-two-char (&optional more-than-two) "Makes the current buffer use two chars per pixel. Will return nil if buffer was two chars per pixel or greater, t otherwise. With prefix argument, skips check for two chars." (interactive "p") (if (and (> xpm-chars-per-pixel 1) (not more-than-two)) nil (goto-char xpm-color-start) (loop repeat xpm-num-colors do (search-forward-regexp (concat "\"" (make-string xpm-chars-per-pixel ?.)) nil t) (insert " ") (forward-line)) (goto-char xpm-body-start) (search-forward "\"") (loop repeat xpm-ysize do (loop repeat xpm-xsize do (forward-char xpm-chars-per-pixel) (insert " ")) (forward-line) (search-forward "\"" nil t)) (goto-char xpm-body-end) (when (search-forward-regexp "XPMEXT\\s-*xemacs_alpha_values" nil t) (forward-line) (loop until (search-forward "XPMENDEXT" (point-at-eol) t) do (search-forward-regexp (concat "\"" (make-string xpm-chars-per-pixel ?.)) nil t) (insert " ") (forward-line))) (setq xpm-chars-per-pixel (1+ xpm-chars-per-pixel)) (goto-char (point-min)) (search-forward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)" nil t) (replace-match (number-to-string xpm-chars-per-pixel) nil nil nil 4) t)) (defun xpm-darken-image (&optional strength buffer) "Darkens xpm image in current buffer by 5% If `buffer' is specified, uses that buffer instead. If `strength' is specified, it should be a floating point number between 0.0 and 1.0." (interactive) (unless strength (setq strength 0.05)) (save-excursion (let* ((target-buffer (or buffer (current-buffer))) (filter-buffer (get-buffer-create "*Filter Buffer*")) (xsize xpm-xsize) (ysize xpm-ysize) (filter-list)) (set-buffer filter-buffer) (erase-buffer) (setq filter-list (xpm-make-solid-image-strings xsize ysize)) (insert (car filter-list) "#000000000000" (cadr filter-list)) (xpm-map-buffer) (xpm-add-alpha-extension) (xpm-add-alpha "." (format "%i" (* 65535 strength))) (xpm-make-two-char) (xpm-overlay-buffer target-buffer filter-buffer 0 0)))) (defun xpm-lighten-image (&optional strength buffer) "Lightens xpm image in current buffer by 5% If `buffer' is specified, uses that buffer instead." (interactive) (unless strength (setq strength 0.05)) (save-excursion (let* ((target-buffer (or buffer (current-buffer))) (filter-buffer (get-buffer-create "*Filter Buffer*")) (xsize xpm-xsize) (ysize xpm-ysize) (filter-list)) (set-buffer filter-buffer) (erase-buffer) (setq filter-list (xpm-make-solid-image-strings xsize ysize)) (insert (car filter-list) "#ffffffffffff" (cadr filter-list)) (xpm-map-buffer) (xpm-add-alpha-extension) (xpm-add-alpha "." (format "%i" (* 65535 strength))) (xpm-make-two-char) (xpm-overlay-buffer target-buffer filter-buffer 0 0)))) (defun xpm-add-bevel (bevel-width &optional strength buffer) "Adds a bevel `bevel-width' wide around the image If `buffer' is specified, use that instead of the current-buffer. If `strength' is specified, use that for the maximum dimming/brightening. This applies light from the top-left corner." (interactive "nWidth of bevel? (in pixels): ") (unless strength (setq strength 0.10)) (save-excursion (let* ((target-buffer (or buffer (current-buffer))) (filter-buffer (get-buffer-create "*Filter Buffer*")) (xsize xpm-xsize) (ysize xpm-ysize) (filter-list)) (set-buffer filter-buffer) (erase-buffer) (setq filter-list (xpm-make-solid-image-strings xsize ysize)) (insert (car filter-list) "#00000000ffff" (cadr filter-list)) (xpm-map-buffer) (xpm-add-alpha-extension) (xpm-add-alpha "." "0") (xpm-make-two-char) (loop for x from 1 to bevel-width do (xpm-add-color (concat "l" (format "%x" (- bevel-width x))) "#ffffffffffff") (xpm-add-alpha (concat "l" (format "%x" (- bevel-width x))) (format "%i" (/ (* x 65535 strength) bevel-width))) (xpm-add-color (concat "d" (format "%x" (- bevel-width x))) "#000000000000") (xpm-add-alpha (concat "d" (format "%x" (- bevel-width x))) (format "%i" (/ (* x 65535 strength) bevel-width)))) (goto-char xpm-body-start) (search-forward "\"") (loop for x from 0 to (1- bevel-width) do (goto-char xpm-body-start) (forward-line x) (search-forward "\"") (forward-char (* xpm-chars-per-pixel x)) (loop repeat (- xpm-ysize (* 2 x)) do (delete-char xpm-chars-per-pixel) (insert (concat "l" (format "%x" x))) (next-line 1) (backward-char xpm-chars-per-pixel))) (goto-char xpm-body-start) (loop for x from 0 to (1- bevel-width) do (search-forward ".") (backward-char) (loop repeat (- xpm-xsize (* 2 x) 1) do (delete-char xpm-chars-per-pixel) (insert (concat "l" (format "%x" x)))) (forward-line)) (goto-char xpm-body-end) (goto-char (point-at-bol)) (loop for x from 0 to (1- bevel-width) do (search-forward ".") (backward-char) (loop repeat (- xpm-xsize (* 2 x) 1) do (delete-char xpm-chars-per-pixel) (insert (concat "d" (format "%x" x)))) (forward-line -1)) (loop for x from 0 to (1- bevel-width) do (goto-char xpm-body-start) (forward-line (1+ x)) (search-forward "\"") (search-forward "\"") (backward-char (+ 1 (* xpm-chars-per-pixel (1+ x)))) (loop repeat (- xpm-ysize (* 2 x) 1) do (delete-char xpm-chars-per-pixel) (insert (concat "d" (format "%x" x))) (next-line 1) (backward-char xpm-chars-per-pixel))) ;Finished constructing the filter (xpm-overlay-buffer target-buffer filter-buffer 0 0)))) (defun xpm-new-solid-color ( width height color ) "Creates a new xpm file with a solid background color." (interactive "nWidth: nHeight: ") (save-excursion (let ((new-buffer (create-file-buffer "Untitled.xpm")) new-list) (unless color (setq color (facemenu-read-color "Background color (tab for list): "))) (switch-to-buffer new-buffer) (setq new-list (xpm-make-solid-image-strings width height)) (insert (car new-list) color (cadr new-list)) (xpm-map-buffer) (xpm-add-color " " "None") (xpm-add-alpha-extension) (xpm-add-alpha " " "0") (xpm-make-two-char) (xpm-mode)))) (defun xpm-new-transparent ( width height ) "Creates a new xpm file with a transparent background." (interactive "nWidth: nHeight: ") (save-excursion (let ((new-buffer (create-file-buffer "Untitled.xpm")) new-list) (switch-to-buffer new-buffer) (setq new-list (xpm-make-solid-image-strings width height)) (insert (car new-list) "None" (cadr new-list)) (xpm-map-buffer) (xpm-add-color " " "None") (xpm-add-alpha-extension) (xpm-make-two-char) (xpm-mode)))) (defun xpm-new-vertical-gradient ( width height &optional topcolor bottomcolor ) "Creates a new xpm file with a vetical gradient background." (interactive "nWidth: nHeight: ") (save-excursion (unless topcolor (setq topcolor (facemenu-read-color "Top color (tab for list): "))) (unless bottomcolor (setq bottomcolor (facemenu-read-color "Bottom color (tab for list): "))) (let ((new-buffer (create-file-buffer "Untitled.xpm")) (topcc (color-rgb-components (make-color-specifier topcolor))) (bottomcc (color-rgb-components (make-color-specifier bottomcolor))) (newcc '(0 0 0)) (color-list nil) new-str new-list) (switch-to-buffer new-buffer) (setq new-list (xpm-make-solid-image-strings width height)) (insert (car new-list) "None" (cadr new-list)) (xpm-init) (xpm-add-color " " "None") (xpm-add-alpha-extension) (xpm-make-two-char) (loop for x from 0 to (1- height) do (setq newcc (mapcar* (lambda (bottom top) (+ (/ (* x (- bottom top)) (1- height)) top)) topcc bottomcc)) (setq new-str (xpm-generate-str)) (xpm-add-color new-str (apply 'format "#%04x%04x%04x" newcc)) (xpm-add-alpha new-str "65536") (push new-str color-list)) (goto-char xpm-body-start) (loop for x from 0 to (1- height) do (search-forward "\"") (loop repeat width do (delete-char xpm-chars-per-pixel) (insert (nth x color-list))) (forward-line)) (xpm-mode)))) (defun xpm-new-vertical-twosided-gradient (width height &optional endcolor centercolor) "Creates a new xpm file with a vertical gradient background." (interactive "nWidth: nHeight: ") (save-excursion (unless endcolor (setq endcolor (facemenu-read-color "End color (tab for list): "))) (unless centercolor (setq centercolor (facemenu-read-color "Center color (tab for list): "))) (let ((new-buffer (create-file-buffer "Untitled.xpm")) (endcc (color-rgb-components (make-color-specifier endcolor))) (centercc (color-rgb-components (make-color-specifier centercolor))) (newcc '(0 0 0)) (color-list nil) new-str new-list) (switch-to-buffer new-buffer) (setq new-list (xpm-make-solid-image-strings width height)) (insert (car new-list) "None" (cadr new-list)) (xpm-init) (xpm-add-color " " "None") (xpm-add-alpha-extension) (xpm-make-two-char) (loop for x from 0 to (1- (/ (1+ height) 2)) do (setq newcc (mapcar* (lambda (center end) (+ (/ (* x (- center end)) (1- (/ (1+ height) 2 ))) end)) endcc centercc)) (setq new-str (xpm-generate-str)) (xpm-add-color new-str (apply 'format "#%04x%04x%04x" newcc)) (xpm-add-alpha new-str "65536") (push new-str color-list)) (goto-char xpm-body-start) (loop for x from 0 to (1- (/ (1+ height) 2)) do (search-forward "\"") (loop repeat width do (delete-char xpm-chars-per-pixel) (insert (nth x color-list))) (forward-line)) (if (oddp height) (forward-line -1)) (loop for x from 0 to (1- (/ (1+ height) 2)) do (search-forward "\"") (loop repeat width do (delete-char xpm-chars-per-pixel) (insert (nth (- (1- (/ (1+ height) 2)) x ) color-list))) (forward-line)) (xpm-mode)))) (defun xpm-new-diagonal-gradient ( &optional width height topcolor bottomcolor) "Creates a new xpm file with a diagonal gradient background." (interactive "nWidth: nHeight: ") (save-excursion (unless topcolor (setq topcolor (facemenu-read-color "Top left color (tab for list): "))) (unless bottomcolor (setq bottomcolor (facemenu-read-color "Bottom right color (tab for list): "))) (let ((new-buffer (create-file-buffer "Untitled.xpm")) (topcc (color-rgb-components (make-color-specifier topcolor))) (bottomcc (color-rgb-components (make-color-specifier bottomcolor))) (newcc '(0 0 0)) (color-list nil) (colors (+ height width -1)) new-str new-list) (switch-to-buffer new-buffer) (setq new-list (xpm-make-solid-image-strings width height)) (insert (car new-list) "None" (cadr new-list)) (xpm-init) (xpm-add-color " " "None") (xpm-add-alpha-extension) (xpm-make-two-char) (loop for x from 0 to (1- colors) do (setq newcc (mapcar* (lambda (bottom top) (+ (/ (* x (- bottom top)) (1- colors)) top)) topcc bottomcc)) (setq new-str (xpm-generate-str)) (xpm-add-color new-str (apply 'format "#%04x%04x%04x" newcc)) (xpm-add-alpha new-str "65536") (push new-str color-list)) (goto-char xpm-body-start) (search-forward "\"") (loop for x from 0 to (1- colors) do (loop do (delete-char xpm-chars-per-pixel) (insert (nth x color-list)) until (eq (line-number) (line-number xpm-body-start)) until (eq (char-after) ?\") do (previous-line 1)) (loop do (next-line 1) (backward-char xpm-chars-per-pixel) until (eq (line-number) (line-number xpm-body-end)) until (eq (char-before) ?\"))) (xpm-mode)))) (defun xpm-pythag (x y) "Calculates the square root of the sum of the squares of x and y" (sqrt (+ (* x x) (* y y)))) (defun xpm-new-circles-gradient (&optional width height centercolor edgecolor centerx centery) "Creates a new xpm file with a circular gradient about centerx and centery." (interactive "nWidth: nHeight: nCenter X: nCenter Y: ") (unless centercolor (setq centercolor (facemenu-read-color "Center color (tab for list): "))) (unless edgecolor (setq edgecolor (facemenu-read-color "Edge color (tab for list): "))) (save-excursion (let ((new-buffer (create-file-buffer "Untitled.xpm")) (edgecc (color-rgb-components (make-color-specifier edgecolor))) (centercc (color-rgb-components (make-color-specifier centercolor))) (newcc '(0 0 0)) (color-list nil) (colors (ceiling (* 2 (max (xpm-pythag (- width centerx) (- height centery)) (xpm-pythag (- 0 centerx) (- height centery)) (xpm-pythag (- width centerx) (- 0 centery)) (xpm-pythag (- 0 centerx) (- 0 centery)))))) new-str new-list) (switch-to-buffer new-buffer) (setq new-list (xpm-make-solid-image-strings width height)) (insert (car new-list) "None" (cadr new-list)) (xpm-init) (xpm-add-color " " "None") (xpm-add-alpha-extension) (xpm-make-two-char) (loop for x from 0 to colors do (setq newcc (mapcar* (lambda (edge center) (+ (/ (* x (- center edge)) colors) edge)) edgecc centercc)) (setq new-str (xpm-generate-str)) (xpm-add-color new-str (apply 'format "#%04x%04x%04x" newcc)) (xpm-add-alpha new-str "65536") (push new-str color-list)) (goto-char xpm-body-start) (search-forward "\"") (loop for y from 0 to (1- height) do (loop for x from 0 to (1- width) do (delete-char xpm-chars-per-pixel) (insert (nth (round (* 2 (xpm-pythag (- x centerx) (- y centery)))) color-list))) (forward-line) (search-forward "\"" nil t)) (xpm-mode)))) (defun xpm-new-circles-from-center-gradient (&optional width height centercolor edgecolor) "Creates a new xpm file with a circular gradient about the center of the image." (interactive "nWidth: nHeight: ") (xpm-new-circles-gradient width height nil nil (/ width 2) (/ height 2))) (defun xpm-new-squares-gradient (&optional width height centercolor edgecolor centerx centery) "Creates a new xpm file with a square gradient about centerx and centery." (interactive "nWidth: nHeight: i i nCenter X: nCenter Y: ") (save-excursion (unless centercolor (setq centercolor (facemenu-read-color "Center color (tab for list): "))) (unless edgecolor (setq edgecolor (facemenu-read-color "Edge color (tab for list): "))) (let ((new-buffer (create-file-buffer "Untitled.xpm")) (edgecc (color-rgb-components (make-color-specifier edgecolor))) (centercc (color-rgb-components (make-color-specifier centercolor))) (newcc '(0 0 0)) (color-list nil) (colors (apply 'max (mapcar 'abs (list (- width centerx) (- height centery) (- 0 centerx) (- 0 centery))))) new-str new-list) (switch-to-buffer new-buffer) (setq new-list (xpm-make-solid-image-strings width height)) (insert (car new-list) "None" (cadr new-list)) (xpm-init) (xpm-add-color " " "None") (xpm-add-alpha-extension) (xpm-make-two-char) (loop for x from 0 to colors do (setq newcc (mapcar* (lambda (edge center) (+ (/ (* x (- center edge)) colors) edge)) edgecc centercc)) (setq new-str (xpm-generate-str)) (xpm-add-color new-str (apply 'format "#%04x%04x%04x" newcc)) (xpm-add-alpha new-str "65536") (push new-str color-list)) (goto-char xpm-body-start) (search-forward "\"") (loop for y from 0 to (1- height) do (loop for x from 0 to (1- width) do (delete-char xpm-chars-per-pixel) (insert (nth (max (abs (- x centerx)) (abs (- y centery))) color-list))) (forward-line) (search-forward "\"" nil t)) (xpm-mode)))) (defun xpm-new-squares-from-center-gradient (&optional width height centercolor edgecolor) "Creates a new xpm file with a square gradient about the center of the image." (interactive "nWidth: nHeight: ") (xpm-new-squares-gradient width height nil nil (/ width 2) (/ height 2))) (defun xpm-overlay-alpha (overstr understr) "Overlays `overstr' and `understr' colors. Returns a list of three elements: a new str (made with `xpm-generate-str'), a new face, and a new alpha value. Note that the display ignores alpha layer." (let (overface underface overalpha underalpha overcc undercc newstr newface newcc newalpha) (setq overface (cdr (assoc overstr xpm-pixel-values)) underface (cdr (assoc understr xpm-pixel-values)) overalpha (string-to-number (or (cdr (assoc overstr xpm-alpha-values)) "65536")) underalpha (string-to-number (or (cdr (assoc understr xpm-alpha-values)) "65536")) overcc (color-rgb-components (face-background overface)) undercc (color-rgb-components (face-background underface)) newcc '(0 0 0)) (setf (car newcc) (floor (/ (+ (* (car overcc) (float overalpha)) (/ (* (- 65536.0 overalpha) (* (car undercc) (float underalpha))) 65536)) 65536))) (setf (cadr newcc) (floor (/ (+ (* (cadr overcc) (float overalpha)) (/ (* (- 65536.0 overalpha) (* (cadr undercc) (float underalpha))) 65536)) 65536))) (setf (caddr newcc) (floor (/ (+ (* (caddr overcc) (float overalpha)) (/ (* (- 65536.0 overalpha) (* (caddr undercc) (float underalpha))) 65536)) 65536))) (setf newalpha (number-to-string (floor (+ overalpha (/ (* underalpha (- 65336.0 overalpha)) 65536))))) (setq newface (xpm-make-face (apply 'format "#%04x%04x%04x" newcc))) (if (and (rassoc newalpha xpm-alpha-values) (equal (car (rassoc newalpha xpm-alpha-values)) (car (rassoc newface xpm-pixel-values)))) (setq newstr (car (rassoc newalpha xpm-alpha-values))) (setq newstr (xpm-generate-str)) (xpm-add-color newstr (apply 'format "#%04x%04x%04x" newcc)) (xpm-add-alpha newstr newalpha)) (list newstr newface newalpha))) (defun xpm-merge-in-color-list (pixel-values alpha-values) "Merges another set of xpm faces and alpha values into this one, and updates the buffer to match." (let ((new-colors nil) (rename-colors nil) xpmstr alpha) (loop for (str . face) in pixel-values do (setq alpha (cdr (assoc str alpha-values))) (setq xpmstr (car (rassoc face xpm-pixel-values))) (if (and xpmstr ;If the face exists locally (or (and (not alpha) (not (assoc xpmstr xpm-alpha-values))) ; and either we both don't specify an alpha (equal alpha (assoc xpmstr xpm-alpha-values)))) ; or our alphas are identical. (unless (equal str xpmstr) (unless (member (cons str xpmstr) rename-colors) (setq rename-colors (cons (cons str xpmstr) rename-colors)))) (setq new-colors (cons (cons str (cons face (or alpha "65536"))) new-colors)))) (loop for (oldstr face . alpha) in new-colors do (setq xpmstr (xpm-generate-str)) (xpm-add-color xpmstr (apply 'format "#%04x%04x%04x" (color-rgb-components (face-background face)))) ;;;;Long and slow; Maybe there is a better way? (xpm-add-alpha xpmstr alpha) (setq rename-colors (cons (cons oldstr xpmstr) rename-colors))) rename-colors)) (defun xpm-rename-colors (rename-list image-list) "Renames all the pixels in `image-list' according to `rename-list'. `image-list' is of the format produced by (`xpm-read-image-in'). `rename-list' is of the format produced by (`xpm-merge-in-color-list'). Returns new image-list." (let ((middle-list nil) middle) (setq middle-list (loop for (first . last) in rename-list ; Generate a middle stage with unique strs for x from 1 to 10000 for y = "0" then (number-to-string x) with string = (make-string xpm-chars-per-pixel ?X) do (setq middle (concat string y)) collect (cons first middle))) (loop for row in (loop for row in image-list collect (loop for pixel in row collect (or (cdr (assoc pixel middle-list)) pixel))) collect (loop for pixel in row collect (or (cdr (assoc (car (rassoc pixel middle-list)) rename-list)) pixel))))) (defun xpm-overlay-image (image-list xoffset yoffset) "Overlays the image described by image-list onto the current-xpm file. Requires the colors to already be identical between the two images" (save-excursion (let ((image-xsize (length (car image-list))) (image-ysize (length image-list)) newface) (xpm-goto-body-line yoffset) (search-forward "\"") (forward-char (* xpm-chars-per-pixel xoffset)) (loop for y from 0 to (1- image-ysize) while (< (+ y yoffset) xpm-ysize) do (loop for x from 0 to (1- image-xsize) while (< (+ x xoffset) xpm-xsize) do (setq newface (xpm-overlay-alpha (nth x (nth y image-list)) (buffer-substring (point) (+ xpm-chars-per-pixel (point))))) (delete-char xpm-chars-per-pixel) (insert (car newface))) (forward-line) (search-forward "\"") (forward-char (* xpm-chars-per-pixel xoffset)))) (xpm-init))) (defun xpm-overlay-buffer (target-buffer overlay-buffer xoff yoff) "Overlays an xpm in `overlay-buffer' on the xpm in `target-buffer' with x and y as offsets from upper left corner." (interactive "bTarget Buffer: bOverlay Buffer: nOffset in x direction: nOffset in y direction: ") (save-excursion (set-buffer overlay-buffer) (xpm-init) (let ((overlay-image-list (xpm-read-pixels-in)) (overlay-pixel-values xpm-pixel-values) (overlay-alpha-values xpm-alpha-values)) (set-buffer target-buffer) (xpm-init) (message "Overlaying images...") (xpm-overlay-image (xpm-rename-colors (xpm-merge-in-color-list overlay-pixel-values overlay-alpha-values) overlay-image-list) xoff yoff)) (message "Removing duplicate colors...") (xpm-replace-duplicate-colors) (message "Removing unused colors...") (xpm-remove-unused-colors) (message "Removing unused colors...Done") (xpm-init))) (defun xpm-remove-unused-colors () "Removes unused color definitions from current buffer." (interactive) (save-excursion (let ((used-colors nil)) (goto-char xpm-body-start) (search-forward "\"") (setq used-colors (loop repeat xpm-ysize append (loop repeat xpm-xsize collect (buffer-substring (point) (+ (point) xpm-chars-per-pixel)) do (forward-char xpm-chars-per-pixel)) do (forward-line) (search-forward "\"" nil t))) (goto-char xpm-color-start) (setq xpm-num-colors (loop until (eq (line-number) (line-number xpm-body-start)) do (search-forward-regexp (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\)")) count (member (match-string 1) used-colors) do (if (member (match-string 1) used-colors) (forward-line) (delete-region (point-at-bol) (point-at-bol 2))))) (goto-char (point-min)) (search-forward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)" nil t) (replace-match (number-to-string xpm-num-colors) nil nil nil 3) (goto-char xpm-body-end) (when (search-forward-regexp "\"XPMEXT *xemacs_alpha_value" nil t) (forward-line) (loop until (search-forward "XPMENDEXT" (point-at-eol) t) do (search-forward-regexp (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\)")) (if (member (match-string 1) used-colors) (forward-line) (delete-region (point-at-bol) (point-at-bol 2))))) (xpm-init)))) (defun xpm-find-duplicate-colors (&optional no-alpha) "Finds all colors with identical values, and returns a list of suggested conversions. Pays attention to the alpha extension. If `no-color' is non-nil, ignore alpha extension. This function tests on the basis of the color name; it is possible for two colors with different names, but the same RGB values to exist." (let ((color-changes nil) (known-colors nil) (known-alphas nil) (kept-colors nil) color-key color-alpha) (goto-char xpm-color-start) (loop until (eq (line-number) (line-number xpm-body-start)) do (search-forward-regexp (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\).*?c\\s-+\\(.*?\\)\\(\\s-\\|\"\\)")) (setq known-colors (cons (cons (match-string 1) (match-string 2)) known-colors)) (forward-line)) (when (and (not no-alpha) (search-forward-regexp "\"XPMEXT\\s-*xemacs_alpha_values" nil t)) (forward-line) (loop until (search-forward "XPMENDEXT" (point-at-eol) t) do (goto-char (point-at-bol)) (search-forward-regexp (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\).*?a\\s-+\\(.*?\\)\\(\\s-\\|\"\\)")) (unless (assoc (match-string 1) known-alphas) (setq known-alphas (cons (cons (match-string 1) (match-string 2)) known-alphas))) (forward-line))) (setq color-changes (loop for (str . color) in known-colors do (setq color-alpha (or (cdr (assoc str known-alphas)) "65536")) collect (if (setq color-key (car (rassoc (concat color-alpha "-" color) kept-colors))) (cons str color-key) (setq kept-colors (cons (cons str (concat color-alpha "-" color )) kept-colors)) nil))) (setq color-changes (remove-if-not 'identity color-changes)))) (defun xpm-replace-duplicate-colors () "Replaces all instances of one color with another in the image and removes the original color. This also modifies the alpha extension. " (interactive) (save-excursion (let ((color-changes (xpm-find-duplicate-colors)) color-found) (goto-char xpm-body-start) (loop repeat xpm-ysize do (search-forward "\"") (loop repeat xpm-xsize do (if (setq color-found (assoc (buffer-substring (point) (+ (point) xpm-chars-per-pixel)) color-changes)) (progn (delete-char xpm-chars-per-pixel) (insert (cdr color-found))) (forward-char xpm-chars-per-pixel))) (forward-line)) (goto-char xpm-color-start) (loop until (eq (line-number) (line-number xpm-body-start)) do (search-forward-regexp (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\)")) (if (assoc (match-string 1) color-changes) (delete-region (point-at-bol) (point-at-bol 2)) (forward-line))) (when (search-forward-regexp "\"XPMEXT\\s-*xemacs_alpha_values" nil t) (forward-line) (loop until (search-forward "XPMENDEXT" (point-at-eol) t) do (search-forward-regexp (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\).*?a")) (if (assoc (match-string 1) color-changes) (delete-region (point-at-bol) (point-at-bol 2)) (forward-line)))) (setq xpm-num-colors (- xpm-num-colors (length color-changes))) (goto-char (point-min)) (search-forward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)" nil t) (replace-match (number-to-string xpm-num-colors) nil nil nil 3))) (xpm-init)) (defun xpm-store-color (str color) "Add STR to xpm-pixel-values with a new face set to background COLOR if STR already has an entry, the existing face will be used, with the new color replacing the old (on the display only, not in the xpm color defs!)" (let (new-face) (setq new-face (xpm-make-face color)) (if xpm-show-characters (let ((ccc (color-rgb-components (make-color-specifier color)))) (if ccc (if (or (or (> (elt ccc 0) 32767) ; If any color component is greater than 50% (> (elt ccc 1) 32767)) ; Maybe some more gradual change could be used, to better preserve appearance? (> (elt ccc 2) 32767)) (set-face-foreground new-face "black") (set-face-foreground new-face "white")))) (set-face-foreground new-face color)) (setq xpm-pixel-values (cons (cons str new-face) xpm-pixel-values)) (if (featurep 'toolbar) (when (< (length xpm-palette) xpm-max-palette-size) (let ((strings (xpm-make-solid-image-strings 12 12))) (setq xpm-palette (cons (vector (list (make-glyph (concat (car strings) color (cadr strings)))) ;; Major cool things with quotes..... (setq str "a " color "green") (`(lambda (event) (interactive "e") (xpm-toolbar-select-colour event (,str) (,color)))) t color) xpm-palette))))))) (defun xpm-parse-color (class) "Parse xpm color string from current line and set the color. `class' is the string that indicates the proper colors (\"c\" would be standard color)" (interactive) (save-excursion (goto-char (point-at-bol)) (if (re-search-forward ;; Generate a regexp on the fly (concat "\"\\(" (make-string xpm-chars-per-pixel ?.) "\\)" ; chars ".*?" ; other classes class ; our class "\\s-+\\(.+?\\)\\(\\s-\\|\"\\)") ;Simplified by non-greedy operators. (point-at-eol) t) (if (equal class "a") (xpm-store-alpha (match-string 1) (match-string 2)) (xpm-store-color (match-string 1) (match-string 2))) (error (concat "Unable to parse color on line " (number-to-string (line-number))))))) (defun xpm-generate-str () "Generates a unique color string in the current xpm's color-space. Returns nil if space is full." (let ((valid-chars "1234567890-=qwertyuiop[]asdfghjkl;'zxcvbnm,./`!@#$%^&*()_+QWERTYUIOP{|ASDFGHJKL:ZXCVBNM<>?~")) ;Technically, almost all control characters will also work just fine; unfortunately ;they will display as two characters wide per char, and mess with your columns dreadfully. (if (>= xpm-num-colors (loop repeat xpm-chars-per-pixel for x = (length valid-chars) then (* x (length valid-chars)) finally return x)) nil (let ((newstr (make-string xpm-chars-per-pixel ?1))) (loop while (assoc newstr xpm-pixel-values) do (setq newstr (loop repeat xpm-chars-per-pixel concat (char-to-string (elt valid-chars (random* (length valid-chars))))))) ;If xpm is written by hand, this will probably be quite efficient. newstr)))) (defun xpm-add-color (str color) "add a color to an xpm's list of color defs" (interactive "sPixel character: sPixel color (any valid color string):") (save-excursion (xpm-goto-color-def xpm-num-colors) (insert-before-markers (format "\"%s\tc %s\",\n" str color)) (forward-line -1) (xpm-parse-color "c") (goto-char (point-min)) (incf xpm-num-colors) (search-forward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)" nil t) (replace-match (int-to-string xpm-num-colors) nil nil nil 3))) (defun xpm-add-alpha (str alpha) "add an alpha to the xpm alpha extension list" (interactive "sPixel character: nPixel alpha (any number from 0-65536):") (save-excursion (xpm-goto-color-def xpm-num-colors) (unless (search-forward-regexp "\"XPMEXT\\s-*xemacs_alpha_values" nil t) (error "No alpha extention in this XPM.")) (forward-line) (insert-before-markers (format "\"%s\ta %s\",\n" str alpha)) (forward-line -1) (xpm-parse-color "a"))) (defun xpm-map-buffer () "Finds the start and end positions of each section, and sets the markers accordingly. This function sets `xpm-color-start', `xpm-body-start', and `xpm-body-end' to markers at the appropriate locations. Note that this function places xpm-color-start at the beginning of the first color definition line, xpm-body-start at the beginning of the first body line and xpm-body-end at the end of the last body string." (save-excursion (goto-char (point-min)) (unless (search-forward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)" nil t) (error "Cannot parse xpm file: can't find size string!")) (setq xpm-chars-per-pixel (string-to-int (match-string 4)) xpm-num-colors (string-to-int (match-string 3)) xpm-xsize (string-to-int (match-string 1)) xpm-ysize (string-to-int (match-string 2))) (forward-line) (while (and (not (eobp)) (not (looking-at "\\s-*\""))) (forward-line)) (setq xpm-color-start (point-marker)) (forward-line xpm-num-colors) (search-forward "\"") (backward-char) (setq xpm-body-start (point-marker)) (forward-line (1- xpm-ysize)) (search-forward "\"") (search-forward "\"") (setq xpm-body-end (point-marker)))) (defun xpm-shift-image ( x y ) "Shifts xpm down and to the right by `x' and `y'. Negative values mean up and to the left, respectively." (interactive "nNumber of pixels to shift right: nNumber of pixels to shift down: ") (if (> x 0) (xpm-shift-image-right x) (xpm-shift-image-left (- x))) (if (> y 0) (xpm-shift-image-down y) (xpm-shift-image-up (- y)))) (defun xpm-shift-image-left ( &optional pixels ) "Shifts the xpm left `pixels', defaults to one. Fills empty column(s) with removed columns." (interactive) (unless pixels (setq pixels (string-to-number (read-string "Number of pixels to shift left (1): " nil nil "1")))) (save-excursion (xpm-goto-body-line 0) (loop repeat xpm-ysize do (search-forward "\"") (delete-char (* xpm-chars-per-pixel pixels) t) (search-forward "\"") (forward-char -1) (yank) (forward-line))) (xpm-init)) (defun xpm-shift-image-right ( &optional pixels ) "Shifts the xpm right `pixels', defaults to one. Fills empty column(s) with removed columns." (interactive) (unless pixels (setq pixels (string-to-number (read-string "Number of pixels to shift right (1): " nil nil "1")))) (save-excursion (xpm-goto-body-line 0) (loop repeat xpm-ysize do (search-forward "\"") (search-forward "\"") (forward-char -1) (delete-backward-char (* xpm-chars-per-pixel pixels) t) (search-backward "\"") (forward-char 1) (yank) (forward-line))) (xpm-init)) (defun xpm-shift-image-up ( &optional pixels ) "Shifts the xpm up `pixels', defaults to one. Fills empty row(s) with removed rows." (interactive) (unless pixels (setq pixels (string-to-number (read-string "Number of pixels to shift up (1): " nil nil "1")))) (save-excursion (xpm-goto-body-line 0) (kill-entire-line pixels) (goto-char xpm-body-end) (insert ",\n") (yank) (search-backward-regexp ",\\s-*") (replace-match "")) (xpm-init)) (defun xpm-shift-image-down ( &optional pixels ) "Shifts the xpm down `pixels', defaults to one. Fills empty row(s) with removed rows." (interactive) (unless pixels (setq pixels (string-to-number (read-string "Number of pixels to shift down (1): " nil nil "1")))) (save-excursion (goto-char xpm-body-end) (insert ",\n") (kill-entire-line (* -1 pixels)) (search-backward-regexp ",\\s-*\n") (replace-match "") (goto-char xpm-body-start) (yank)) (xpm-init)) (defun xpm-read-pixels-in () "Reads the pixels out of the image into a nested list format. format is: (( row_1 ) ( row_2 ) ( row_3 ))" (let (xpm-pixels) (save-excursion (goto-char xpm-body-start) (setq xpm-pixels (loop repeat xpm-ysize do (search-forward "\"") collect (loop repeat xpm-xsize collect (buffer-substring (point) (+ (point) xpm-chars-per-pixel)) do (forward-char xpm-chars-per-pixel)) do (forward-line)))) xpm-pixels)) (defun xpm-rotate-image-cw () "Rotates the image 90 degrees clockwise. Modifies the x and y size in the image." (interactive) (let ((xpm-pixels (xpm-read-pixels-in))) (save-excursion (goto-char xpm-body-start) (loop for x from 0 to (1- xpm-xsize) do (insert "\"") (loop for y from (1- xpm-ysize) downto 0 do (insert (nth x (nth y xpm-pixels)))) (insert "\",\n") finally (loop until (search-forward "XPMEXT" (point-at-eol) t) until (eobp) do (delete-region (point-at-bol) (point-at-eol)) (delete-char)) (unless (search-forward "};" nil t) (search-backward "\",") (replace-match "\"};"))) (goto-char xpm-color-start) (rotatef xpm-xsize xpm-ysize) (search-backward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)") (replace-match (number-to-string xpm-xsize) nil nil nil 1) (replace-match (number-to-string xpm-ysize) nil nil nil 2))) (xpm-init)) (defun xpm-rotate-image-ccw () "Rotates the image 90 degrees counterclockwise. Modifies the x and y size in the image." (interactive) (let ((xpm-pixels (xpm-read-pixels-in))) (save-excursion (goto-char xpm-body-start) (loop for x from (1- xpm-xsize) downto 0 do (insert "\"") (loop for y from 0 to (1- xpm-ysize) do (insert (nth x (nth y xpm-pixels)))) (insert "\",\n") finally (loop until (search-forward "XPMEXT" (point-at-eol) t) until (eobp) do (delete-region (point-at-bol) (point-at-eol)) (delete-char)) (unless (search-forward "};" nil t) (search-backward "\",") (replace-match "\"};"))) (goto-char xpm-color-start) (rotatef xpm-xsize xpm-ysize) (search-backward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)") (replace-match (number-to-string xpm-xsize) nil nil nil 1) (replace-match (number-to-string xpm-ysize) nil nil nil 2))) (xpm-init)) (defun xpm-mirror-image-vertical-axis () "Mirrors an image about a vertical axis." (interactive) (save-excursion (let (row) (goto-char xpm-body-start) (loop repeat xpm-ysize do (search-forward "\"") (setq row (loop repeat xpm-xsize collect (buffer-substring (point) (+ (point) xpm-chars-per-pixel)) do (forward-char xpm-chars-per-pixel))) (delete-region (point-at-bol) (point-at-eol)) (insert "\"") (loop for pixel from (1- xpm-xsize) downto 0 do (insert (nth pixel row))) (insert "\",") (forward-line) finally (unless (search-forward "};" nil t) (search-backward "\",") (replace-match "\"};"))))) (xpm-init)) (defun xpm-mirror-image-horizontal-axis () "Mirrors an image about a horizontal axis." (interactive) (save-excursion (let (rows) (goto-char xpm-body-start) (setq rows (loop repeat xpm-ysize collect (buffer-substring (point-at-bol) (point-at-eol)) do (forward-line))) (goto-char xpm-body-start) (loop for row in (nreverse rows) do (insert row "\n")) (loop until (search-forward "XPMEXT" (point-at-eol) t) until (eobp) do (delete-region (point-at-bol) (point-at-eol)) (delete-char)) (unless (search-forward "};" nil t) (search-backward "\",") (replace-match "\"};"))) (search-backward "};") (and (search-backward "};" nil t) (replace-match ","))) (xpm-init)) (defun xpm-eyedropper-tool () "Sets the xpm tool to eyedropper." (interactive) (setq xpm-tool 'xpm-eyedropper) (set-glyph-image text-pointer-glyph (make-image-instance xpm-eyedropper-image nil 'pointer) (current-buffer)) (set-glyph-image text-pointer-glyph xpm-eyedropper-image (current-buffer))) (defun xpm-pencil-tool () "Sets the xpm tool to pencil." (interactive) (setq xpm-tool 'xpm-pencil) (set-glyph-image text-pointer-glyph (make-image-instance xpm-pencil-image nil 'pointer) (current-buffer)) (set-glyph-image text-pointer-glyph xpm-pencil-image (current-buffer))) (defun xpm-select-tool () "Sets the xpm tool to select." (interactive) (setq xpm-tool 'xpm-select) (set-glyph-image text-pointer-glyph (make-image-instance xpm-select-image nil 'pointer) (current-buffer)) (set-glyph-image text-pointer-glyph xpm-select-image (current-buffer))) (defun xpm-crop (&optional point mark) "Crops to a rectangle described by point and mark." (interactive) (or point (setq point (point))) (or mark (setq mark (mark))) (if (eq xpm-tool 'xpm-select) (when (and (xpm-in-bodyp point) (xpm-in-bodyp mark)) (let ((p (move-marker (make-marker) point)) (m (move-marker (make-marker) mark)) left right top bottom left-margin right-margin top-margin bottom-margin) (setq top (if (> p m) m p)) (setq bottom (if (> p m) p m)) (if (< (- m (point-at-bol (1+ (- (line-number m) (line-number))))) (- p (point-at-bol))) (progn (setq left m) (setq right p)) (setq left p) (setq right m)) (goto-line (line-number left)) (search-forward "\"") (setq left-margin (- left (point))) (goto-line (line-number right)) (search-forward "\",") (backward-char 2) (setq right-margin (- (point) right)) (setq top-margin (- (line-number top) (line-number xpm-body-start))) (setq bottom-margin (- (line-number xpm-body-end) (line-number bottom))) (goto-char xpm-body-start) (loop repeat top-margin do (delete-region (point-at-bol) (point-at-bol 2))) (goto-char bottom) (forward-line) (loop repeat bottom-margin do (delete-region (point-at-bol) (point-at-bol 2))) (unless (search-forward "};" nil t) (goto-char bottom) (goto-char (point-at-eol)) (search-backward "\",") (replace-match "\"};")) (goto-char xpm-body-start) (loop repeat (- (line-number bottom) (line-number top) -1) do (search-forward "\"") (delete-char left-margin) (search-forward "\"") (backward-char) (delete-backward-char right-margin) (forward-line)) (setq xpm-xsize (- xpm-xsize left-margin right-margin)) (setq xpm-ysize (- xpm-ysize top-margin bottom-margin)) (goto-char (point-min)) (search-forward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)") (replace-match (number-to-string xpm-xsize) nil nil nil 1) (replace-match (number-to-string xpm-ysize) nil nil nil 2))) (xpm-select-tool))) (defun xpm-enlarge (x y) "Adds space at the bottom and left sides of the image in the current colors." (interactive "nHow many more pixels to the right: nHow many more pixels to the bottom: ") (save-excursion (goto-char xpm-body-start) (search-forward "\"") (search-forward "\"") (backward-char) (loop repeat xpm-ysize do (loop repeat x do (insert xpm-paint-string)) (forward-line) (search-forward "\"") (search-forward "\"") (backward-char)) (setq xpm-xsize (+ xpm-xsize x)) (forward-line 0) (loop repeat y do (insert "\"") (loop repeat xpm-xsize do (insert xpm-paint-string)) (insert "\",\n")) (unless (search-forward "};" nil t) (search-backward "\",") (replace-match "\"};")) (backward-char) (while (search-backward "\"};" nil t) (replace-match "\",")) (setq xpm-ysize (+ xpm-ysize y)) (goto-char (point-min)) (search-forward-regexp "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)") (replace-match (number-to-string xpm-xsize) nil nil nil 1) (replace-match (number-to-string xpm-ysize) nil nil nil 2) (xpm-init))) (defun xpm-goto-color-def (def) "move to color DEF in the xpm header" (interactive "nColor number:") (goto-char xpm-color-start) (forward-line def)) (defun xpm-goto-body-line (line) "move to LINE lines down from the start of the body of an xpm" (interactive "nBody line:") (goto-char xpm-body-start) (forward-line line)) (defun xpm-show-characters () "Sets the `xpm-show-characters' flag, and re-sets all the faces" (interactive) (setq xpm-show-characters t) (loop for (str . face) in xpm-pixel-values do (let ((ccc (color-rgb-components (face-background face)))) (if ccc (if (or (or (> (elt ccc 0) 32767) ; If any color component is greater than 50% (> (elt ccc 1) 32767)) ; Maybe some more gradual change could be used, to better preserve appearance? (> (elt ccc 2) 32767)) (set-face-foreground face "black") (set-face-foreground face "white")))))) (defun xpm-hide-characters () "Clears the `xpm-show-characters' flag, and re-sets all the faces" (interactive) (setq xpm-show-characters nil) (loop for (str . face) in xpm-pixel-values do (set-face-foreground face (face-background face)))) (defun xpm-show-image () "Display the xpm in the current buffer at the end of the topmost line" (interactive) (save-excursion (if (annotationp xpm-anno) (delete-annotation xpm-anno)) (setq xpm-glyph (make-glyph (vector 'xpm :data (buffer-substring (point-min) (point-max))))) (goto-char (point-min)) (goto-char (point-at-eol)) (setq xpm-anno (make-annotation xpm-glyph (point) 'text)))) (defun xpm-hide-image () "Remove the image of the xpm from the buffer" (interactive) (if (annotationp xpm-anno) (delete-annotation xpm-anno))) (defun xpm-change-str-color (str newcolor) "Changes the `str' to use `newcolor'" (interactive "sCharacter to change: ") (unless newcolor (setq newcolor (facemenu-read-color "New color (tab for list): "))) (xpm-map-buffer) (goto-char xpm-color-start) (if (not (search-forward (concat "\"" str) xpm-body-start t)) (error (concat "Color " str " cannot be found")) (search-forward-regexp "c\\s-*\\(.*?\\)\\(\\s-\\|\"\\)") (replace-match newcolor nil nil nil 1))) (defun xpm-in-bodyp (&optional pos) "Checks if current cursor position is inside the body of the xpm." (setq pos (or pos (point))) (and (< pos xpm-body-end) (> pos xpm-body-start))) (defun xpm-in-colorsp () "Checks if current cursor position is inside the color definitions of the xpm." (and (< (point) xpm-body-start) (> (point) xpm-color-start))) (defun xpm-toolbar-select-colour (event chars color) "The function called by toolbar (palette) buttons. `chars' is the color symbol, and `color' is the color corresponding to it." (message "Toolbar selected %s (%s)" color chars) (xpm-pencil-tool) (setq xpm-palette (mapcar #'(lambda (but) (aset but 2 (not (eq color (aref but 3)))) but) xpm-palette)) (xpm-set-paint-str chars) (set-specifier left-toolbar (cons (current-buffer) xpm-palette))) (defun xpm-help-display () "Displays a new frame with the help for this mode in it." (interactive) (let ((help-buffer (get-buffer-create "XPM Mode Help")) (help-frame (get-other-frame))) (display-buffer help-buffer nil help-frame) (set-buffer help-buffer) (erase-buffer) (insert "XPM Mode is a mode principally designed for editing icons. To make this easier, we've added a few default keybindings, which you can see below. Feel free to change these like the examples you'll see below in the keymap, and even add more! We've added several functions which aren't in our default keymap, but can only be accessed from the XPM menu. If you want to get the command that any of them runs, you can just type C-x k and then use the mouse to select whichever menu item you're interested in. Default XPM Mode Keymap: Key combination Command Purpose --------------- ------- ------- C-c C-r xpm-show-image Reloads the preview image at the top of the buffer S-button1 mouse-track Allows you to paint on the screen with the cursor C-c C-c xpm-add-color Adds a new color to the xpm file M-up xpm-shift-up Shifts the image up on the screen M-down xpm-shift-down Shifts the image down on the screen M-left xpm-shift-left Shifts the image left on the screen M-right xpm-shift-right Shifts the image right on the screen M-m M-l xpm-rotate-left Rotates the image left M-m M-r xpm-rotate-right Rotates the image right M-m M-v xpm-mirror- Mirrors the image about a vertical-axis vertical axis M-m M-h xpm-mirror- Mirrors the image about a horizontal-axis horizontal axis M-m M-c xpm-crop Allows you to crop using the mouse M-m M-e xpm-enlarge Pads the image on the bottom and right side with the current color M-m M-l xpm-show-characters Shows the characters in the editing area M-m M-i xpm-hide-characters Hides the characters in the editing area M-m M-f1 xpm-mode-help Pulls up a new frame with this help document in it. Using the mouse: There are three tools you can use with the mouse: a pencil, a color picker, and a crop tool. These are selected by the three icons to the left of this help icon on the toolbar. The pencil is used for drawing on the image. To use it, you either have to hold down shift, and click with your primary button, or just click with button2 (usually your middle button). Before you can use it you have to select a color. This can be done with the color picker tool, or a couple of ways without switching tools. You can select the color from the palette on the far left of the screen with the pencil, or from the color definition section of the buffer, with either a middle click, or a shifted primary click. The color picker is used for selecting colors. With the color picker chosen, you can pick a color three ways: you can select it from the palette on the far left of the screen, or you can middle click or shifted primary click in either the color definition section, or on any pixel in the image. The color picker toolbar icon will show you what color is selected. The crop tool is used for cutting the buffer to a certain selection. You use it by selecting the tool, then middle clicking or shift-clicking each corner of the box you want to cut the image down to. Finally, when the selected area is what you want, click the crop tool again. Examples: To assign a new function to a key, try the following: I wanted to add xpm-init to a handy key so I could reload the page easily. To do this, I put the following in my init.el: (define-key xpm-mode-map [(control c) (control i)] 'xpm-init) This adds the key to the xpm mode-map, so next time I load xpm-mode, this key will be available. It's as easy as that!") (raise-frame help-frame))) (defun xpm-mouse-down (event n) ; (interactive "ep") (case xpm-tool ('xpm-pencil (mouse-set-point event) (unless xpm-paint-string (error "Select a color before painting!")) (if (xpm-in-bodyp) ;; in body, overwrite the paint string where the mouse is clicked (let ((ext (extent-at-event event)) (pixel-color (assoc xpm-paint-string xpm-pixel-values))) (goto-char (extent-start-position ext)) (insert xpm-paint-string) (delete-char xpm-chars-per-pixel) (if xpm-always-update-image (xpm-show-image)) (if pixel-color (set-extent-face ext (cdr pixel-color)) (set-extent-face ext 'default))) ;; otherwise, select the color defined by the line where the mouse ;; was clicked (if (xpm-in-colorsp) (save-excursion (goto-char (point-at-bol)) (when (search-forward-regexp (concat "\"\\s-*\\(" (make-string xpm-chars-per-pixel ?.) "\\)") (point-at-eol) t) (xpm-set-paint-str (match-string 1)))))) (mouse-set-point event)) ('xpm-select (let ((ext1 (extent-at (point))) (ext2 (extent-at-event event))) (if (< (- (extent-start-position ext1) (point-at-bol)) (- (extent-start-position ext2) (point-at-bol))) (progn (goto-char (extent-start-position ext1)) (push-mark) (goto-char (extent-end-position ext2))) (goto-char (extent-end-position ext1)) (push-mark) (goto-char (extent-start-position ext2)))) (zmacs-activate-region)) ('xpm-eyedropper (mouse-set-point event) (if (xpm-in-bodyp) (let ((face (extent-face (extent-at-event event)))) (xpm-set-paint-str (car (rassoc (make-face face) xpm-pixel-values)))) (if (xpm-in-colorsp) (save-excursion (goto-char (point-at-bol)) (when (search-forward-regexp (concat "\"\\s-*\\(" (make-string xpm-chars-per-pixel ?.) "\\)") (point-at-eol) t) (xpm-set-paint-str (match-string 1))))))))) (defun xpm-set-paint-str (str) "Sets the current paint color." (save-excursion (setq xpm-paint-string str) (let* ((color (face-background-name (cdr (assoc str xpm-pixel-values)))) (ccc (color-rgb-components (make-color-specifier color)))) (if ccc (if (or (or (> (elt ccc 0) 32767) ; If any color component is greater than 50% (> (elt ccc 1) 32767)) ; Maybe some more gradual change could be used, to better preserve appearance? (> (elt ccc 2) 32767)) (progn (set-buffer (get-buffer-create "*Icon*")) (insert-file-contents xpm-black-color-icon-path) (xpm-change-str-color " " color) (setq xpm-color-icon (list (make-glyph (vector 'xpm :data (buffer-string))))) (kill-buffer (current-buffer))) (set-buffer (get-buffer-create "*Icon*")) (insert-file-contents xpm-white-color-icon-path) (xpm-change-str-color " " color) (setq xpm-color-icon (list (make-glyph (vector 'xpm :data (buffer-string))))) (kill-buffer (current-buffer)))))) (xpm-update-toolbar)) (defun xpm-mouse-drag (event n timeout) (case xpm-tool ('xpm-pencil (mouse-set-point event) (or timeout (progn (if (xpm-in-bodyp) ;; Much improved by not using font-lock-mode (or (string= xpm-paint-string (buffer-substring (point) (+ xpm-chars-per-pixel (point)))) (let ((ext (extent-at-event event)) (pixel-color (assoc xpm-paint-string xpm-pixel-values))) (goto-char (extent-start-position ext)) (insert xpm-paint-string) (delete-char xpm-chars-per-pixel) (if xpm-always-update-image (xpm-show-image)) (if pixel-color (set-extent-face ext (cdr pixel-color)) (set-extent-face ext 'default))))))) (mouse-set-point event)) ('xpm-select (mouse-set-point event) (zmacs-activate-region)) ('xpm-eyedropper (mouse-set-point event)))) (defun xpm-mouse-up (event n) (case xpm-tool ('xpm-pencil (xpm-show-image)) ('xpm-select (if (< (- (mark) (point-at-bol (1+ (- (line-number (mark)) (line-number))))) (- (point) (point-at-bol))) ; Checks if mark is closer to the beginning of its line than point. (goto-char (extent-end-position (extent-at-event event))) (goto-char (extent-start-position (extent-at-event event)))) (zmacs-activate-region)) ('xpm-eye-dropper (if (xpm-in-bodyp) (let ((face (extent-face (extent-at-event event)))) (xpm-set-paint-str (car (rassoc (make-face face) xpm-pixel-values)))) (if (xpm-in-colorsp) (save-excursion (goto-char (point-at-bol)) (when (search-forward-regexp (concat "\"\\s-*\\(" (make-string xpm-chars-per-pixel ?.) "\\)") (point-at-eol) t) (xpm-set-paint-str (match-string 1))))))))) (defun xpm-toggle-chars () "Toggles whether characters are shown in the editting area. Also modifies the toolbar icon." (interactive) (if xpm-show-characters (progn (xpm-hide-characters) (setq xpm-chars-icon xpm-show-chars-icon)) (xpm-show-characters) (setq xpm-chars-icon xpm-hide-chars-icon)) (xpm-update-toolbar)) (defun xpm-update-toolbar () "Hack to update toolbar. If I find a better way, I'll put it here, but for now it simply removes the toolbar, redisplays, and adds it again." (remove-specifier default-toolbar (current-buffer)) (sit-for 0) (set-specifier default-toolbar xpm-toolbar (current-buffer))) (defun xpm-movement-right () "Move right after self-inserting character in Picture mode." (interactive) (xpm-set-motion 0 1)) (defun xpm-movement-left () "Move left after self-inserting character in Picture mode." (interactive) (xpm-set-motion 0 -1)) (defun xpm-movement-up () "Move up after self-inserting character in Picture mode." (interactive) (xpm-set-motion -1 0)) (defun xpm-movement-down () "Move down after self-inserting character in Picture mode." (interactive) (xpm-set-motion 1 0)) (defun xpm-movement-nw () "Move up and left after self-inserting character in Picture mode." (interactive) (xpm-set-motion -1 -1)) (defun xpm-movement-ne () "Move up and right after self-inserting character in Picture mode." (interactive) (xpm-set-motion -1 1)) (defun xpm-movement-sw () "Move down and left after self-inserting character in Picture mode." (interactive) (xpm-set-motion 1 -1)) (defun xpm-movement-se () "Move down and right after self-inserting character in Picture mode." (interactive) (xpm-set-motion 1 1)) (defun xpm-set-motion (vert horiz) "Set VERTICAL and HORIZONTAL increments for movement in Picture mode. The modeline is updated to reflect the current direction." (setq picture-vertical-step vert picture-horizontal-step horiz) (setq mode-name (format "XPM:%s" (car (nthcdr (+ 1 (% horiz 2) (* 3 (1+ (% vert 2)))) '(nw up ne left none right sw down se))))) (redraw-modeline) (message nil)) (defun xpm-make-toolbar-buttons() "Makes all the buttons for the xpm toolbar. Can use either locate-data-directory to find the files or data-directory." (if (not text-modes-toolbar-icon-directory) (setq text-modes-toolbar-icon-directory (if (fboundp 'locate-data-directory) (locate-data-directory "text-modes") (file-name-as-directory (expand-file-name "text-modes" data-directory))))) ;--- define buttons for the xpm-mode toolbar (setq xpm-open-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-open-file-icon-48-48.xpm") ) )) (setq xpm-save-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-save-file-icon-48-48.xpm") ) )) (setq xpm-undo-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-undo-icon-48-48.xpm" )) )) (setq xpm-new-image-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-new-image-icon-48-48.xpm" )) )) (setq xpm-sh-l-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-shift-left-icon-48-48.xpm") ) )) (setq xpm-sh-r-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-shift-right-icon-48-48.xpm") ) )) (setq xpm-sh-u-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-shift-up-icon-48-48.xpm") ) )) (setq xpm-sh-d-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-shift-down-icon-48-48.xpm") ) )) (setq xpm-r-cw-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-rotate-cw-icon-48-48.xpm") ) )) (setq xpm-r-ccw-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-rotate-ccw-icon-48-48.xpm") ) )) (setq xpm-m-vert-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-mirror-vertical-icon-48-48.xpm") ) )) (setq xpm-m-horiz-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-mirror-horizontal-icon-48-48.xpm") ) )) (setq xpm-crop-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-crop-icon-48-48.xpm") ) )) (setq xpm-enlarge-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-enlarge-icon-48-48.xpm") ) )) (setq xpm-show-chars-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-show-chars-icon-48-48.xpm") ) )) (setq xpm-hide-chars-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-hide-chars-icon-48-48.xpm") ) )) (setq xpm-help-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-help-icon-48-48.xpm") ) )) (setq xpm-color-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-black-color-icon-48-48.xpm") ) )) (setq xpm-pencil-icon (toolbar-make-button-list (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-set-pencil-icon-48-48.xpm") ) )) (setq xpm-black-color-icon-path (concat text-modes-toolbar-icon-directory "xpm-black-color-icon-48-48.xpm")) (setq xpm-white-color-icon-path (concat text-modes-toolbar-icon-directory "xpm-white-color-icon-48-48.xpm")) (setq xpm-eyedropper-image (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-eyedropper.xpm" ))) (setq xpm-select-image (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-select.xpm"))) (setq xpm-pencil-image (vector 'xpm :file (concat text-modes-toolbar-icon-directory "xpm-pencil.xpm" ))) (if xpm-show-characters (setq xpm-chars-icon xpm-hide-chars-icon) (setq xpm-chars-icon xpm-show-chars-icon))) ;--- Add an icon specification to the xpm-top-toolbar for each icon (load "picture") (defvar xpm-mode nil) (make-variable-buffer-local 'xpm-mode) (defvar xpm-mode-map nil) (if xpm-mode-map () (setq xpm-mode-map (copy-keymap picture-mode-map)) (define-key xpm-mode-map [(control c) (control r)] 'xpm-show-image) (define-key xpm-mode-map [(shift button1)] 'mouse-track) (define-key xpm-mode-map [button1] 'mouse-track-default) (define-key xpm-mode-map [(control c) (control c)] 'xpm-add-color) (define-key xpm-mode-map [(control c) (control p)] 'xpm-parse-color) (define-key xpm-mode-map [(meta up)] (lambda () (interactive) (xpm-shift-image-up 1))) (define-key xpm-mode-map [(meta down)] (lambda () (interactive) (xpm-shift-image-down 1))) (define-key xpm-mode-map [(meta left)] (lambda () (interactive) (xpm-shift-image-left 1))) (define-key xpm-mode-map [(meta right)] (lambda () (interactive) (xpm-shift-image-right 1))) (define-key xpm-mode-map [(meta m) (meta l)] 'xpm-rotate-image-ccw) (define-key xpm-mode-map [(meta m) (meta r)] 'xpm-rotate-image-cw) (define-key xpm-mode-map [(meta m) (meta v)] 'xpm-mirror-image-vertical-axis) (define-key xpm-mode-map [(meta m) (meta h)] 'xpm-mirror-image-horizontal-axis) (define-key xpm-mode-map [(meta m) (meta c)] 'xpm-crop) (define-key xpm-mode-map [(meta m) (meta e)] 'xpm-enlarge) (define-key xpm-mode-map [(meta m) (meta v)] 'xpm-show-characters) (define-key xpm-mode-map [(meta m) (meta i)] 'xpm-hide-characters) (define-key xpm-mode-map [(meta m) (meta f1)] 'xpm-help-display) (define-key xpm-mode-map "\C-c<" 'xpm-movement-left) (define-key xpm-mode-map "\C-c>" 'xpm-movement-right) (define-key xpm-mode-map "\C-c^" 'xpm-movement-up) (define-key xpm-mode-map "\C-c." 'xpm-movement-down) (define-key xpm-mode-map "\C-c`" 'xpm-movement-nw) (define-key xpm-mode-map "\C-c'" 'xpm-movement-ne) (define-key xpm-mode-map "\C-c/" 'xpm-movement-sw) (define-key xpm-mode-map "\C-c\\" 'xpm-movement-se)) (if xpm-menu () (setq xpm-menu '("XPM" ["Refresh buffer" xpm-init ] ["Create New .xpm Image" xpm-new-transparent ] ["Enlarge Existing .xpm" xpm-enlarge ] ["Crop .xpm" xpm-crop ] ["Overlay .xpm over .xpm" xpm-overlay-buffer ] "---" ["Lighten Image" xpm-lighten-image ] ["Darken Image" xpm-darken-image ] ["Show Characters" xpm-toggle-chars :style toggle :selected xpm-show-characters] "---" ["Shift Left" xpm-shift-image-left ] ["Shift Right" xpm-shift-image-right ] ["Shift Up" xpm-shift-image-up ] ["Shift Down" xpm-shift-image-down ] ["Rotate CW 90 deg." xpm-rotate-image-cw ] ["Rotate CCW 90 deg." xpm-rotate-image-ccw ] ["Mirror On Vertical Axis" xpm-mirror-image-vertical-axis ] ["Mirror On Horizontal Axis" xpm-mirror-image-horizontal-axis ]))) (if xpm-gradient-menu () (setq xpm-gradient-menu '("Gradients" ["Gradient 2 colors type 1" xpm-new-vertical-gradient ] ["Gradient 2 colors type 2" xpm-new-vertical-twosided-gradient ] ["Gradient Diagonal" xpm-new-diagonal-gradient ] ["Gradient Circles From Center" xpm-new-circles-from-center-gradient ] ["Gradient Squares From Center" xpm-new-squares-from-center-gradient ]))) ;;;###autoload(add-to-list 'auto-mode-alist '("\\.xpm$" . xpm-mode)) ;;;###autoload (define-derived-mode xpm-mode picture-mode "XPM" "A mode for editing xpm files. Based on picture-mode. Shift-button-1 lets you paint by dragging the mouse. Shift-button-1 on a color definition line will change the current painting color to that line's value. Characters inserted from the keyboard will NOT be colored properly yet. Use the mouse, or do xpm-init (\\[xpm-init]) after making changes. \\[xpm-add-color] Add a new color, prompting for character and value \\[xpm-show-image] show the current image at the top of the buffer \\[xpm-parse-color] parse the current line's color definition and add it to the color table. Provided as a means of changing colors. XPM major mode bindings: \\{xpm-mode-map}" (make-local-variable 'xpm-palette) (make-local-variable 'xpm-xsize) (make-local-variable 'xpm-ysize) (make-local-variable 'xpm-num-colors) (make-local-variable 'xpm-chars-per-pixel) (make-local-variable 'xpm-paint-string) (make-local-variable 'xpm-color-start) (make-local-variable 'xpm-body-start) (make-local-variable 'xpm-body-end) (make-local-variable 'xpm-glyph) (make-local-variable 'xpm-anno) (make-local-variable 'xpm-pixel-values) (make-local-variable 'xpm-alpha-values) (make-local-variable 'mouse-track-down-hook) (make-local-variable 'mouse-track-drag-hook) (make-local-variable 'mouse-track-up-hook) (make-local-variable 'mouse-track-drag-up-hook) (make-local-variable 'mouse-track-click-hook) (make-local-variable 'current-menubar) (xpm-make-toolbar-buttons) (xpm-init) (xpm-pencil-tool) (setq mouse-track-down-hook 'xpm-mouse-down) (setq mouse-track-drag-hook 'xpm-mouse-drag) (setq mouse-track-up-hook 'xpm-mouse-up) (setq mouse-track-drag-up-hook 'xpm-mouse-up) (setq mouse-track-click-hook nil) (set-specifier default-toolbar xpm-toolbar (current-buffer)) (add-submenu nil xpm-menu nil) (add-submenu '("XPM") xpm-gradient-menu nil) (xpm-set-motion 0 1) (use-local-map xpm-mode-map) (set-specifier default-toolbar-height 53 (current-buffer))) ; Set toolbar height to match toolbar icons. (provide 'xpm-mode) ;;; xpm-mode.el ends here