[elpa] 02/07: add xpm.el

[Thien-Thi Nguyen]

ttn pushed a commit to branch ttn-xpm
in repository elpa.

commit 721816ca867eb0afe8f3290e4d2a8cba4ba49b44
Author: Thien-Thi Nguyen <address@hidden>
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 <address@hidden>
+;; Maintainer: Thien-Thi Nguyen <address@hidden>
+;; 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