ttn pushed a commit to branch ttn-xpm
in repository elpa.
commit 721816ca867eb0afe8f3290e4d2a8cba4ba49b44
Author: Thien-Thi Nguyen <t...@gnu.org>
Date: Tue May 13 12:40:14 2014 +0200
add xpm.el
---
packages/xpm/xpm.el | 315 +++++++++++++++++++++++++++++++++++++++++++++++++++
1 files changed, 315 insertions(+), 0 deletions(-)
diff --git a/packages/xpm/xpm.el b/packages/xpm/xpm.el
new file mode 100644
index 0000000..250ab84
--- /dev/null
+++ b/packages/xpm/xpm.el
@@ -0,0 +1,315 @@
+;;; xpm.el --- edit XPM images -*- lexical-binding: t -*-
+
+;; Copyright (C) 2014 Free Software Foundation, Inc.
+
+;; Author: Thien-Thi Nguyen <t...@gnu.org>
+;; Maintainer: Thien-Thi Nguyen <t...@gnu.org>
+;; Version: -1
+
+;; 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, [weasel words]...
+;;
+;; ??? list other *.el files / xpm-foo features
+;; ??? autoloads
+;; ??? mention API slack (char px) -OR- kill that noise
+
+;;; Code:
+
+(require 'cl-lib)
+
+(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.")
+
+(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.
+Optional arg SIMPLE [TODO...]."
+ (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 "^\"")
+ (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))
+ (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 (list* 'intangible t
+ more)))))
+ (suppress 1)
+ (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))
+
+(defun xpm-buffer (name width height cpp palette)
+ "Return a new buffer prepared for further editing.
+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 a list of pairs, each in the form (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 \"."
+ (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)
+ (loop for (px . color) in palette
+ do (yep "\"%s %s\","
+ (if (characterp px)
+ (string px)
+ px)
+ (if (string-match " " color)
+ color
+ (concat "c " color))))
+ (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 coord(s) X,Y.
+Either X or Y can also be a vector or a pair (LOW . HIGH),
+which means all the values in the range LOW to HIGH, inclusive.
+For example, (3 . 8) is equivalent to [3 4 5 6 7 8].
+If either X or Y is a pair, the other coordinate
+component must be a scalar.
+
+Silently ignore out-of-range coordinates."
+ (xpm--w/gg (w h cpp origin y-mult) (xpm--gate)
+ (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)
+ (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) (loop for two from (car y) to (cdr y)
+ do (zow x two)))
+ (`(vector . integer) (loop for one across x
+ do (zow one y)))
+ (`(integer . vector) (loop for two across y
+ do (zow x two)))
+ (`(vector . vector) (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, a character, specifies a fill px.
+If FILL is t, use EDGE to fill.
+
+NOTE: Presently this function produces strange results when FORM has
+ a vertically-facing concavity. (Patches welcome.)"
+ (when (eq t fill)
+ (setq fill edge))
+ (let* ((height (xpm--h (xpm--gate)))
+ (v (make-vector height nil)))
+ (loop for (x . y) in form
+ unless (or (> 0 y)
+ (<= height y))
+ do (push x (aref v y)))
+ (loop for y below height
+ for unsorted across v
+ when unsorted
+ do (loop with ls = (sort unsorted '>)
+ 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
+ (loop with (x in beg nx end)
+ while acc
+ do (setq x (pop acc))
+ do (xpm-put-points edge x y)
+ do (when (and (setq in (not in))
+ fill acc)
+ (setq beg (1+ (if (consp x)
+ (cdr x)
+ x))
+ nx (car acc)
+ end (1- (if (consp nx)
+ (car nx)
+ nx)))
+ (xpm-put-points
+ fill (cons beg end) y)))))))
+
+(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
