1 ;;; xpm.el --- edit XPM images -*- lexical-binding: t -*-
3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
5 ;; Author: Thien-Thi Nguyen <ttn@gnu.org>
6 ;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
8 ;; Keywords: multimedia, xpm
9 ;; URL: http://www.gnuvola.org/software/xpm/
11 ;; This program is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; This program is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
26 ;; This package makes editing XPM images easy (and maybe fun).
27 ;; Editing is done directly on the (textual) image format,
28 ;; for maximal cohesion w/ the Emacs Way.
30 ;; Coordinates have the form (X . Y), with X from 0 to (width-1),
31 ;; and Y from 0 to (height-1), inclusive, in the 4th quadrant;
32 ;; i.e., X grows left to right, Y top to bottom, origin top-left.
34 ;; (0,0) … (width-1,0)
36 ;; (0,height-1) … (width-1,height-1)
38 ;; In xpm.el (et al), "px" stands for "pixel", a non-empty string
39 ;; in the external representation of the image. The px length is
40 ;; the image's "cpp" (characters per pixel). The "palette" is a
41 ;; set of associations between a px and its "color", which is an
42 ;; alist with symbolic TYPE and and string CVALUE. TYPE is one of:
44 ;; c -- color (most common)
47 ;; g4 -- four-level grayscale
50 ;; and CVALUE is a string, e.g., "blue" or "#0000FF". Two images
51 ;; are "congruent" if their width, height and cpp are identical.
53 ;; This package was originally conceived for non-interactive use,
54 ;; so its design is spartan at the core. However, we plan to add
55 ;; a XPM mode in a future release; monitor the homepage for updates.
57 ;; For now, the features (w/ correspondingly-named files) are:
58 ;; - xpm -- edit XPM images
59 ;; - xpm-m2z -- ellipse/circle w/ fractional center
61 ;; Some things are autoloaded. Which ones? Use the source, Luke!
62 ;; (Alternatively, just ask on help-gnu-emacs (at gnu dot org).)
68 (autoload 'image-toggle-display "image-mode" t) ; hmm is this TRT?
70 (defvar xpm-raster-inhibit-continuity-optimization nil
71 "Non-nil disables a heuristic in `xpm-raster' filling.
72 Normally, if you pass a well-formed (closed, no edge crossings)
73 shape to `xpm-raster', then you can ignore this variable.")
75 (cl-defstruct (xpm--gg ; gathered gleanings
76 (:type vector) ; no ‘:named’ so no predicate
78 (:constructor xpm--make-gg)
79 (:copier xpm--copy-gg))
80 (w :read-only t) (h :read-only t) (cpp :read-only t)
81 pinfo ; (MARKER . HASH-TABLE)
87 "Various bits for xpm.el (et al) internal use.")
90 (defun xpm-grok (&optional simple)
91 "Analyze buffer and prepare internal data structures.
92 When called as a command, display in the echo area a
93 summary of image dimensions, cpp and palette.
94 Set buffer-local variable `xpm--gg' and return its value.
95 Normally, preparation includes making certain parts of the
96 buffer intangible. Optional arg SIMPLE non-nil inhibits that."
100 (and (boundp 'image-type)
101 (eq 'xpm image-type))
104 (goto-char (point-min))
106 (buffer-substring-no-properties
107 (point) (line-end-position)))))
108 (error "Buffer not an XPM image"))
109 (when (eq 'image-mode major-mode)
110 (image-toggle-display))
111 (let ((ht (make-hash-table :test 'equal))
114 (goto-char (point-min))
116 (skip-chars-forward "^\"")
117 (cl-destructuring-bind (w h nc cpp &rest rest)
118 (read (format "(%s)" (read (current-buffer))))
119 (ignore rest) ; for now
121 (setq pinfo (point-marker))
124 do (let ((p (1+ (point))))
125 (puthash (buffer-substring-no-properties
127 ;; Don't bother w/ CVALUE for now.
130 (setq pinfo (cons pinfo ht))
131 (skip-chars-forward "^\"")
133 (set (make-local-variable 'xpm--gg)
134 (setq gg (xpm--make-gg
137 :origin (point-marker)
138 :y-mult (+ 4 (* cpp w)))))
140 (let ((mod (buffer-modified-p))
141 (inhibit-read-only t))
143 ((suppress (span &rest more)
146 (- p span) p (cl-list*
152 do (progn (forward-char (+ 4 (* w cpp)))
154 (suppress 2 'display "
\a\ e\15\n
\ 6\13\ 6")
155 (push 'intangible-sides (xpm--flags gg)))
156 (set-buffer-modified-p mod)))
157 (when (called-interactively-p 'interactive)
158 (message "%dx%d, %d cpp, %d colors in palette"
159 w h cpp (hash-table-count ht)))))
165 (error "Sorry, xpm confused")))
167 (cl-defmacro xpm--w/gg (names from &body body)
170 ,@(mapcar (lambda (name)
171 `(,name (,(intern (format "xpm--%s" name))
177 (defun xpm-generate-buffer (name width height cpp palette)
178 "Return a new buffer in XPM image format.
179 In this buffer, undo is disabled (see `buffer-enable-undo').
181 NAME is the buffer and XPM name. For best interoperation
182 with other programs, NAME should be a valid C identifier.
183 WIDTH, HEIGHT and CPP are integers that specify the image
184 width, height and characters/pixel, respectively.
186 PALETTE is an alist ((PX . COLOR) ...), where PX is either
187 a character or string of length CPP, and COLOR is a string.
188 If COLOR includes a space, it is included directly,
189 otherwise it is automatically prefixed with \"c \".
191 For example, to produce palette fragment:
194 \"Y s border c green\",
196 you can specify PALETTE as:
199 (?Y . \"s border c green\"))
201 This example presumes CPP is 1."
202 (let ((buf (generate-new-buffer name)))
203 (with-current-buffer buf
204 (buffer-disable-undo)
207 (insert (apply 'format s args) "\n")))
209 (yep "static char * %s[] = {" name)
210 (yep "\"%d %d %d %d\"," width height (length palette) cpp)
212 for (px . color) in palette
217 (if (string-match " " color)
219 (concat "c " color))))
221 with s = (format "%S,\n" (make-string (* cpp width) 32))
229 (defun xpm-put-points (px x y)
230 "Place PX at coordinate(s) (X,Y).
232 If both X and Y are vectors of length N, then place N points
233 using the pairwise vector elements. If one of X or Y is a vector
234 of length N and the other component is an integer, then pair the
235 vector elements with the integer component and place N points.
237 If one of X or Y is a pair (LOW . HIGH), take it to be equivalent
238 to specfiying a vector [LOW ... HIGH]. For example, (3 . 8) is
239 equivalent to [3 4 5 6 7 8]. If one component is a pair, the
240 other must be an integer -- the case where both X and Y are pairs
243 Silently ignore out-of-range coordinates."
244 (xpm--w/gg (w h cpp origin y-mult) (xpm--gate)
245 (when (and (stringp px) (= 1 cpp))
246 (setq px (aref px 0)))
249 (or (> 0 col) (<= w col)
250 (> 0 row) (<= h row)))
252 (goto-char (+ origin (* cpp col) (* y-mult row))))
264 (delete-char (* cpp len)))
266 (unless (out col row)
268 (pcase (cons (type-of x) (type-of y))
269 (`(cons . integer) (let* ((beg (max 0 (car x)))
270 (end (min (1- w) (cdr x)))
271 (len (- end beg -1)))
272 (unless (or (> 1 len)
279 (setq px (aref px 0)))
281 (`(integer . cons) (cl-loop
282 for two from (car y) to (cdr y)
284 (`(vector . integer) (cl-loop
287 (`(integer . vector) (cl-loop
290 (`(vector . vector) (cl-loop
294 (`(integer . integer) (zow x y))
295 (_ (error "Bad coordinates: X %S, Y %S"
298 (defun xpm-raster (form edge &optional fill)
299 "Rasterize FORM with EDGE pixel (character or string).
300 FORM is a list of coordinates that comprise a closed shape.
301 Optional arg FILL specifies a fill pixel, or t to fill with EDGE.
303 If FORM is not closed or has inopportune vertical-facing
304 concavities, filling might give bad results. For those cases,
305 see variable `xpm-raster-inhibit-continuity-optimization'."
308 (xpm--w/gg (h) (xpm--gate)
309 (let* ((v (make-vector h nil))
310 (x-min (caar form)) ; (maybe) todo: xpm--bb
314 (use-in-map (not xpm-raster-inhibit-continuity-optimization))
315 ;; These are bool-vectors to keep track of both internal
316 ;; (filled and its "next" (double-buffering)) and external
317 ;; state, on a line-by-line basis.
322 do (setq x-min (min x-min x)
328 do (push x (aref v y)))
334 (rset (bv start len value)
336 for i from start repeat len
337 do (aset bv i value)))
338 (scan (bv start len yes no)
340 for i from start repeat len
344 (let ((len (span x-min x-max)))
345 (setq int (make-bool-vector len nil)
346 nin (make-bool-vector len nil)
347 ext (make-bool-vector len t)))
352 for y from (1- y-min) to y-max
353 when (setq ls (and (< -1 y)
355 (sort (aref v y) '>)))
357 with acc = (list (car ls))
358 for maybe in (cdr ls)
359 do (let* ((was (car acc))
360 (already (consp was)))
361 (cond ((/= (1- (if already
369 (setcar acc (cons maybe was)))))
372 (let ((was (length in-map))
374 (unless (setq in-map-ok
376 ;; heuristic: Avoid being fooled
377 ;; by simulataneous crossings.
379 (setq in-map (make-bool-vector now nil)))))
382 with (x rangep beg nx end len nb in)
385 do (setq x (pop acc))
386 do (xpm-put-points edge x y)
388 (setq rangep (consp x))
390 (rset ext 0 (norm (if rangep
395 (cl-destructuring-bind (b . e) x
396 (rset ext (norm b) (span b e) nil))
397 (aset ext (norm x) nil))
399 (setq beg (1+ (if rangep
403 end (1- (if (consp nx)
408 in (cond ((and use-in-map in-map-ok)
410 (in (scan int nb len t nil))
411 (t (scan ext nb len nil t))))
413 (aset in-map gap in))
417 (xpm-put-points fill (cons beg end) y))))
418 finally do (when fill
420 (fillarray nin nil)))))))))
422 (defun xpm-as-xpm (&rest props)
423 "Return the XPM image (via `create-image') of the buffer.
424 PROPS are additional image properties to place on
425 the new XPM. See info node `(elisp) XPM Images'."
426 (apply 'create-image (buffer-substring-no-properties
427 (point-min) (point-max))
430 (defun xpm-finish (&rest props)
431 "Like `xpm-as-xpm', but also kill the buffer afterwards."
432 (prog1 (apply 'xpm-as-xpm props)