438 lines
16 KiB
EmacsLisp
438 lines
16 KiB
EmacsLisp
|
;;; xpm.el --- edit XPM images -*- lexical-binding: t -*-
|
|||
|
|
|
|||
|
|
;; Copyright (C) 2014 Free Software Foundation, Inc.
|
|||
|
|
|
|||
|
|
;; Author: Thien-Thi Nguyen <ttn@gnu.org>
|
|||
|
|
;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
|
|||
|
|
;; Version: 1.0.3
|
|||
|
|
;; Keywords: multimedia, xpm
|
|||
|
|
;; URL: http://www.gnuvola.org/software/xpm/
|
|||
|
|
|
|||
|
|
;; This program 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 3 of the License, or
|
|||
|
|
;; (at your option) any later version.
|
|||
|
|
|
|||
|
|
;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
|
|||
|
|
|
|||
|
|
;;; Commentary:
|
|||
|
|
|
|||
|
|
;; This package makes editing XPM images easy (and maybe fun).
|
|||
|
|
;; Editing is done directly on the (textual) image format,
|
|||
|
|
;; for maximal cohesion w/ the Emacs Way.
|
|||
|
|
;;
|
|||
|
|
;; Coordinates have the form (X . Y), with X from 0 to (width-1),
|
|||
|
|
;; and Y from 0 to (height-1), inclusive, in the 4th quadrant;
|
|||
|
|
;; i.e., X grows left to right, Y top to bottom, origin top-left.
|
|||
|
|
;;
|
|||
|
|
;; (0,0) … (width-1,0)
|
|||
|
|
;; ⋮ ⋮
|
|||
|
|
;; (0,height-1) … (width-1,height-1)
|
|||
|
|
;;
|
|||
|
|
;; In xpm.el (et al), "px" stands for "pixel", a non-empty string
|
|||
|
|
;; in the external representation of the image. The px length is
|
|||
|
|
;; the image's "cpp" (characters per pixel). The "palette" is a
|
|||
|
|
;; set of associations between a px and its "color", which is an
|
|||
|
|
;; alist with symbolic TYPE and and string CVALUE. TYPE is one of:
|
|||
|
|
;;
|
|||
|
|
;; c -- color (most common)
|
|||
|
|
;; s -- symbolic
|
|||
|
|
;; g -- grayscale
|
|||
|
|
;; g4 -- four-level grayscale
|
|||
|
|
;; m -- monochrome
|
|||
|
|
;;
|
|||
|
|
;; and CVALUE is a string, e.g., "blue" or "#0000FF". Two images
|
|||
|
|
;; are "congruent" if their width, height and cpp are identical.
|
|||
|
|
;;
|
|||
|
|
;; This package was originally conceived for non-interactive use,
|
|||
|
|
;; so its design is spartan at the core. However, we plan to add
|
|||
|
|
;; a XPM mode in a future release; monitor the homepage for updates.
|
|||
|
|
;;
|
|||
|
|
;; For now, the features (w/ correspondingly-named files) are:
|
|||
|
|
;; - xpm -- edit XPM images
|
|||
|
|
;; - xpm-m2z -- ellipse/circle w/ fractional center
|
|||
|
|
;;
|
|||
|
|
;; Some things are autoloaded. Which ones? Use the source, Luke!
|
|||
|
|
;; (Alternatively, just ask on help-gnu-emacs (at gnu dot org).)
|
|||
|
|
|
|||
|
|
;;; Code:
|
|||
|
|
|
|||
|
|
(require 'cl-lib)
|
|||
|
|
|
|||
|
|
(autoload 'image-toggle-display "image-mode" t) ; hmm is this TRT?
|
|||
|
|
|
|||
|
|
(defvar xpm-raster-inhibit-continuity-optimization nil
|
|||
|
|
"Non-nil disables a heuristic in `xpm-raster' filling.
|
|||
|
|
Normally, if you pass a well-formed (closed, no edge crossings)
|
|||
|
|
shape to `xpm-raster', then you can ignore this variable.")
|
|||
|
|
|
|||
|
|
(cl-defstruct (xpm--gg ; gathered gleanings
|
|||
|
|
(:type vector) ; no ‘:named’ so no predicate
|
|||
|
|
(:conc-name xpm--)
|
|||
|
|
(:constructor xpm--make-gg)
|
|||
|
|
(:copier xpm--copy-gg))
|
|||
|
|
(w :read-only t) (h :read-only t) (cpp :read-only t)
|
|||
|
|
pinfo ; (MARKER . HASH-TABLE)
|
|||
|
|
(origin :read-only t)
|
|||
|
|
(y-mult :read-only t)
|
|||
|
|
flags)
|
|||
|
|
|
|||
|
|
(defvar xpm--gg nil
|
|||
|
|
"Various bits for xpm.el (et al) internal use.")
|
|||
|
|
|
|||
|
|
;;;###autoload
|
|||
|
|
(defun xpm-grok (&optional simple)
|
|||
|
|
"Analyze buffer and prepare internal data structures.
|
|||
|
|
When called as a command, display in the echo area a
|
|||
|
|
summary of image dimensions, cpp and palette.
|
|||
|
|
Set buffer-local variable `xpm--gg' and return its value.
|
|||
|
|
Normally, preparation includes making certain parts of the
|
|||
|
|
buffer intangible. Optional arg SIMPLE non-nil inhibits that."
|
|||
|
|
(interactive)
|
|||
|
|
(unless (or
|
|||
|
|
;; easy
|
|||
|
|
(and (boundp 'image-type)
|
|||
|
|
(eq 'xpm image-type))
|
|||
|
|
;; hard
|
|||
|
|
(save-excursion
|
|||
|
|
(goto-char (point-min))
|
|||
|
|
(string= "/* XPM */"
|
|||
|
|
(buffer-substring-no-properties
|
|||
|
|
(point) (line-end-position)))))
|
|||
|
|
(error "Buffer not an XPM image"))
|
|||
|
|
(when (eq 'image-mode major-mode)
|
|||
|
|
(image-toggle-display))
|
|||
|
|
(let ((ht (make-hash-table :test 'equal))
|
|||
|
|
pinfo gg)
|
|||
|
|
(save-excursion
|
|||
|
|
(goto-char (point-min))
|
|||
|
|
(search-forward "{")
|
|||
|
|
(skip-chars-forward "^\"")
|
|||
|
|
(cl-destructuring-bind (w h nc cpp &rest rest)
|
|||
|
|
(read (format "(%s)" (read (current-buffer))))
|
|||
|
|
(ignore rest) ; for now
|
|||
|
|
(forward-line 1)
|
|||
|
|
(setq pinfo (point-marker))
|
|||
|
|
(cl-loop
|
|||
|
|
repeat nc
|
|||
|
|
do (let ((p (1+ (point))))
|
|||
|
|
(puthash (buffer-substring-no-properties
|
|||
|
|
p (+ p cpp))
|
|||
|
|
;; Don't bother w/ CVALUE for now.
|
|||
|
|
t ht)
|
|||
|
|
(forward-line 1)))
|
|||
|
|
(setq pinfo (cons pinfo ht))
|
|||
|
|
(skip-chars-forward "^\"")
|
|||
|
|
(forward-char 1)
|
|||
|
|
(set (make-local-variable 'xpm--gg)
|
|||
|
|
(setq gg (xpm--make-gg
|
|||
|
|
:w w :h h :cpp cpp
|
|||
|
|
:pinfo pinfo
|
|||
|
|
:origin (point-marker)
|
|||
|
|
:y-mult (+ 4 (* cpp w)))))
|
|||
|
|
(unless simple
|
|||
|
|
(let ((mod (buffer-modified-p))
|
|||
|
|
(inhibit-read-only t))
|
|||
|
|
(cl-flet
|
|||
|
|
((suppress (span &rest more)
|
|||
|
|
(let ((p (point)))
|
|||
|
|
(add-text-properties
|
|||
|
|
(- p span) p (cl-list*
|
|||
|
|
'intangible t
|
|||
|
|
more)))))
|
|||
|
|
(suppress 1)
|
|||
|
|
(cl-loop
|
|||
|
|
repeat h
|
|||
|
|
do (progn (forward-char (+ 4 (* w cpp)))
|
|||
|
|
(suppress 4)))
|
|||
|
|
(suppress 2 'display "\n")
|
|||
|
|
(push 'intangible-sides (xpm--flags gg)))
|
|||
|
|
(set-buffer-modified-p mod)))
|
|||
|
|
(when (called-interactively-p 'interactive)
|
|||
|
|
(message "%dx%d, %d cpp, %d colors in palette"
|
|||
|
|
w h cpp (hash-table-count ht)))))
|
|||
|
|
gg))
|
|||
|
|
|
|||
|
|
(defun xpm--gate ()
|
|||
|
|
(or xpm--gg
|
|||
|
|
(xpm-grok)
|
|||
|
|
(error "Sorry, xpm confused")))
|
|||
|
|
|
|||
|
|
(cl-defmacro xpm--w/gg (names from &body body)
|
|||
|
|
(declare (indent 2))
|
|||
|
|
`(let* ((gg ,from)
|
|||
|
|
,@(mapcar (lambda (name)
|
|||
|
|
`(,name (,(intern (format "xpm--%s" name))
|
|||
|
|
gg)))
|
|||
|
|
`,names))
|
|||
|
|
,@body))
|
|||
|
|
|
|||
|
|
;;;###autoload
|
|||
|
|
(defun xpm-generate-buffer (name width height cpp palette)
|
|||
|
|
"Return a new buffer in XPM image format.
|
|||
|
|
In this buffer, undo is disabled (see `buffer-enable-undo').
|
|||
|
|
|
|||
|
|
NAME is the buffer and XPM name. For best interoperation
|
|||
|
|
with other programs, NAME should be a valid C identifier.
|
|||
|
|
WIDTH, HEIGHT and CPP are integers that specify the image
|
|||
|
|
width, height and characters/pixel, respectively.
|
|||
|
|
|
|||
|
|
PALETTE is an alist ((PX . COLOR) ...), where PX is either
|
|||
|
|
a character or string of length CPP, and COLOR is a string.
|
|||
|
|
If COLOR includes a space, it is included directly,
|
|||
|
|
otherwise it is automatically prefixed with \"c \".
|
|||
|
|
|
|||
|
|
For example, to produce palette fragment:
|
|||
|
|
|
|||
|
|
\"X c blue\",
|
|||
|
|
\"Y s border c green\",
|
|||
|
|
|
|||
|
|
you can specify PALETTE as:
|
|||
|
|
|
|||
|
|
((?X . \"blue\")
|
|||
|
|
(?Y . \"s border c green\"))
|
|||
|
|
|
|||
|
|
This example presumes CPP is 1."
|
|||
|
|
(let ((buf (generate-new-buffer name)))
|
|||
|
|
(with-current-buffer buf
|
|||
|
|
(buffer-disable-undo)
|
|||
|
|
(cl-flet
|
|||
|
|
((yep (s &rest args)
|
|||
|
|
(insert (apply 'format s args) "\n")))
|
|||
|
|
(yep "/* XPM */")
|
|||
|
|
(yep "static char * %s[] = {" name)
|
|||
|
|
(yep "\"%d %d %d %d\"," width height (length palette) cpp)
|
|||
|
|
(cl-loop
|
|||
|
|
for (px . color) in palette
|
|||
|
|
do (yep "\"%s %s\","
|
|||
|
|
(if (characterp px)
|
|||
|
|
(string px)
|
|||
|
|
px)
|
|||
|
|
(if (string-match " " color)
|
|||
|
|
color
|
|||
|
|
(concat "c " color))))
|
|||
|
|
(cl-loop
|
|||
|
|
with s = (format "%S,\n" (make-string (* cpp width) 32))
|
|||
|
|
repeat height
|
|||
|
|
do (insert s))
|
|||
|
|
(delete-char -2)
|
|||
|
|
(yep "};")
|
|||
|
|
(xpm-grok t)))
|
|||
|
|
buf))
|
|||
|
|
|
|||
|
|
(defun xpm-put-points (px x y)
|
|||
|
|
"Place PX at coordinate(s) (X,Y).
|
|||
|
|
|
|||
|
|
If both X and Y are vectors of length N, then place N points
|
|||
|
|
using the pairwise vector elements. If one of X or Y is a vector
|
|||
|
|
of length N and the other component is an integer, then pair the
|
|||
|
|
vector elements with the integer component and place N points.
|
|||
|
|
|
|||
|
|
If one of X or Y is a pair (LOW . HIGH), take it to be equivalent
|
|||
|
|
to specfiying a vector [LOW ... HIGH]. For example, (3 . 8) is
|
|||
|
|
equivalent to [3 4 5 6 7 8]. If one component is a pair, the
|
|||
|
|
other must be an integer -- the case where both X and Y are pairs
|
|||
|
|
is not supported.
|
|||
|
|
|
|||
|
|
Silently ignore out-of-range coordinates."
|
|||
|
|
(xpm--w/gg (w h cpp origin y-mult) (xpm--gate)
|
|||
|
|
(when (and (stringp px) (= 1 cpp))
|
|||
|
|
(setq px (aref px 0)))
|
|||
|
|
(cl-flet*
|
|||
|
|
((out (col row)
|
|||
|
|
(or (> 0 col) (<= w col)
|
|||
|
|
(> 0 row) (<= h row)))
|
|||
|
|
(pos (col row)
|
|||
|
|
(goto-char (+ origin (* cpp col) (* y-mult row))))
|
|||
|
|
(jam (col row len)
|
|||
|
|
(pos col row)
|
|||
|
|
(insert-char px len)
|
|||
|
|
(delete-char len))
|
|||
|
|
(rep (col row len)
|
|||
|
|
(pos col row)
|
|||
|
|
(if (= 1 cpp)
|
|||
|
|
(insert-char px len)
|
|||
|
|
(cl-loop
|
|||
|
|
repeat len
|
|||
|
|
do (insert px)))
|
|||
|
|
(delete-char (* cpp len)))
|
|||
|
|
(zow (col row)
|
|||
|
|
(unless (out col row)
|
|||
|
|
(rep col row 1))))
|
|||
|
|
(pcase (cons (type-of x) (type-of y))
|
|||
|
|
(`(cons . integer) (let* ((beg (max 0 (car x)))
|
|||
|
|
(end (min (1- w) (cdr x)))
|
|||
|
|
(len (- end beg -1)))
|
|||
|
|
(unless (or (> 1 len)
|
|||
|
|
(out beg y))
|
|||
|
|
(if (< 1 cpp)
|
|||
|
|
;; general
|
|||
|
|
(rep beg y len)
|
|||
|
|
;; fast(er) path
|
|||
|
|
(when (stringp px)
|
|||
|
|
(setq px (aref px 0)))
|
|||
|
|
(jam beg y len)))))
|
|||
|
|
(`(integer . cons) (cl-loop
|
|||
|
|
for two from (car y) to (cdr y)
|
|||
|
|
do (zow x two)))
|
|||
|
|
(`(vector . integer) (cl-loop
|
|||
|
|
for one across x
|
|||
|
|
do (zow one y)))
|
|||
|
|
(`(integer . vector) (cl-loop
|
|||
|
|
for two across y
|
|||
|
|
do (zow x two)))
|
|||
|
|
(`(vector . vector) (cl-loop
|
|||
|
|
for one across x
|
|||
|
|
for two across y
|
|||
|
|
do (zow one two)))
|
|||
|
|
(`(integer . integer) (zow x y))
|
|||
|
|
(_ (error "Bad coordinates: X %S, Y %S"
|
|||
|
|
x y))))))
|
|||
|
|
|
|||
|
|
(defun xpm-raster (form edge &optional fill)
|
|||
|
|
"Rasterize FORM with EDGE pixel (character or string).
|
|||
|
|
FORM is a list of coordinates that comprise a closed shape.
|
|||
|
|
Optional arg FILL specifies a fill pixel, or t to fill with EDGE.
|
|||
|
|
|
|||
|
|
If FORM is not closed or has inopportune vertical-facing
|
|||
|
|
concavities, filling might give bad results. For those cases,
|
|||
|
|
see variable `xpm-raster-inhibit-continuity-optimization'."
|
|||
|
|
(when (eq t fill)
|
|||
|
|
(setq fill edge))
|
|||
|
|
(xpm--w/gg (h) (xpm--gate)
|
|||
|
|
(let* ((v (make-vector h nil))
|
|||
|
|
(x-min (caar form)) ; (maybe) todo: xpm--bb
|
|||
|
|
(x-max x-min)
|
|||
|
|
(y-min (cdar form))
|
|||
|
|
(y-max y-min)
|
|||
|
|
(use-in-map (not xpm-raster-inhibit-continuity-optimization))
|
|||
|
|
;; These are bool-vectors to keep track of both internal
|
|||
|
|
;; (filled and its "next" (double-buffering)) and external
|
|||
|
|
;; state, on a line-by-line basis.
|
|||
|
|
int nin
|
|||
|
|
ext)
|
|||
|
|
(cl-loop
|
|||
|
|
for (x . y) in form
|
|||
|
|
do (setq x-min (min x-min x)
|
|||
|
|
x-max (max x-max x)
|
|||
|
|
y-min (min y-min y)
|
|||
|
|
y-max (max y-max y))
|
|||
|
|
unless (or (> 0 y)
|
|||
|
|
(<= h y))
|
|||
|
|
do (push x (aref v y)))
|
|||
|
|
(cl-flet
|
|||
|
|
((span (lo hi)
|
|||
|
|
(- hi lo -1))
|
|||
|
|
(norm (n)
|
|||
|
|
(- n x-min))
|
|||
|
|
(rset (bv start len value)
|
|||
|
|
(cl-loop
|
|||
|
|
for i from start repeat len
|
|||
|
|
do (aset bv i value)))
|
|||
|
|
(scan (bv start len yes no)
|
|||
|
|
(cl-loop
|
|||
|
|
for i from start repeat len
|
|||
|
|
when (aref bv i)
|
|||
|
|
return yes
|
|||
|
|
finally return no)))
|
|||
|
|
(let ((len (span x-min x-max)))
|
|||
|
|
(setq int (make-bool-vector len nil)
|
|||
|
|
nin (make-bool-vector len nil)
|
|||
|
|
ext (make-bool-vector len t)))
|
|||
|
|
(cl-loop
|
|||
|
|
with (ls
|
|||
|
|
in-map-ok
|
|||
|
|
in-map)
|
|||
|
|
for y from (1- y-min) to y-max
|
|||
|
|
when (setq ls (and (< -1 y)
|
|||
|
|
(> h y)
|
|||
|
|
(sort (aref v y) '>)))
|
|||
|
|
do (cl-loop
|
|||
|
|
with acc = (list (car ls))
|
|||
|
|
for maybe in (cdr ls)
|
|||
|
|
do (let* ((was (car acc))
|
|||
|
|
(already (consp was)))
|
|||
|
|
(cond ((/= (1- (if already
|
|||
|
|
(car was)
|
|||
|
|
was))
|
|||
|
|
maybe)
|
|||
|
|
(push maybe acc))
|
|||
|
|
(already
|
|||
|
|
(setcar was maybe))
|
|||
|
|
(t
|
|||
|
|
(setcar acc (cons maybe was)))))
|
|||
|
|
finally do
|
|||
|
|
(when fill
|
|||
|
|
(let ((was (length in-map))
|
|||
|
|
(now (length acc)))
|
|||
|
|
(unless (setq in-map-ok
|
|||
|
|
(and (= was now)
|
|||
|
|
;; heuristic: Avoid being fooled
|
|||
|
|
;; by simulataneous crossings.
|
|||
|
|
(cl-evenp was)))
|
|||
|
|
(setq in-map (make-bool-vector now nil)))))
|
|||
|
|
finally do
|
|||
|
|
(cl-loop
|
|||
|
|
with (x rangep beg nx end len nb in)
|
|||
|
|
for gap from 0
|
|||
|
|
while acc
|
|||
|
|
do (setq x (pop acc))
|
|||
|
|
do (xpm-put-points edge x y)
|
|||
|
|
do (when fill
|
|||
|
|
(setq rangep (consp x))
|
|||
|
|
(when (zerop gap)
|
|||
|
|
(rset ext 0 (norm (if rangep
|
|||
|
|
(car x)
|
|||
|
|
x))
|
|||
|
|
t))
|
|||
|
|
(if rangep
|
|||
|
|
(cl-destructuring-bind (b . e) x
|
|||
|
|
(rset ext (norm b) (span b e) nil))
|
|||
|
|
(aset ext (norm x) nil))
|
|||
|
|
(when acc
|
|||
|
|
(setq beg (1+ (if rangep
|
|||
|
|
(cdr x)
|
|||
|
|
x))
|
|||
|
|
nx (car acc)
|
|||
|
|
end (1- (if (consp nx)
|
|||
|
|
(car nx)
|
|||
|
|
nx))
|
|||
|
|
len (span beg end)
|
|||
|
|
nb (norm beg)
|
|||
|
|
in (cond ((and use-in-map in-map-ok)
|
|||
|
|
(aref in-map gap))
|
|||
|
|
(in (scan int nb len t nil))
|
|||
|
|
(t (scan ext nb len nil t))))
|
|||
|
|
(unless in-map-ok
|
|||
|
|
(aset in-map gap in))
|
|||
|
|
(if (not in)
|
|||
|
|
(rset ext nb len t)
|
|||
|
|
(rset nin nb len t)
|
|||
|
|
(xpm-put-points fill (cons beg end) y))))
|
|||
|
|
finally do (when fill
|
|||
|
|
(cl-rotatef int nin)
|
|||
|
|
(fillarray nin nil)))))))))
|
|||
|
|
|
|||
|
|
(defun xpm-as-xpm (&rest props)
|
|||
|
|
"Return the XPM image (via `create-image') of the buffer.
|
|||
|
|
PROPS are additional image properties to place on
|
|||
|
|
the new XPM. See info node `(elisp) XPM Images'."
|
|||
|
|
(apply 'create-image (buffer-substring-no-properties
|
|||
|
|
(point-min) (point-max))
|
|||
|
|
'xpm t props))
|
|||
|
|
|
|||
|
|
(defun xpm-finish (&rest props)
|
|||
|
|
"Like `xpm-as-xpm', but also kill the buffer afterwards."
|
|||
|
|
(prog1 (apply 'xpm-as-xpm props)
|
|||
|
|
(kill-buffer nil)))
|
|||
|
|
|
|||
|
|
(provide 'xpm)
|
|||
|
|
|
|||
|
|
;;; xpm.el ends here
|