my-emacs-d/elpa/xpm-1.0.3/xpm.el
2016-09-26 19:37:47 +02:00

438 lines
16 KiB
EmacsLisp
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; 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