[elpa] externals/xpm bef7120 02/37: [xpm] Add Emacs Lisp files.

[Stefan Monnier]

branch: externals/xpm
commit bef7120adcf0586b0ef7a4b431f1960cf8216633
Author: Thien-Thi Nguyen <ttn@gnu.org>
Commit: Thien-Thi Nguyen <ttn@gnu.org>

    [xpm] Add Emacs Lisp files.
    
    * packages/xpm/xpm.el: New file.
    * packages/xpm/xpm-m2z.el: New file.
---
 xpm-m2z.el |  94 ++++++++++++++
 xpm.el     | 419 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 513 insertions(+)

diff --git a/xpm-m2z.el b/xpm-m2z.el
new file mode 100644
index 0000000..73730ad
--- /dev/null
+++ b/xpm-m2z.el
@@ -0,0 +1,94 @@
+;;; xpm-m2z.el --- (% span 2) => 0             -*- lexical-binding: t -*-
+
+;; Copyright (C) 2014  Free Software Foundation, Inc.
+
+;; 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:
+
+;; Although artist.el is wonderful, it doesn't (yet) do subpixel-centered
+;; circles (or ellipses).  Those shapes are always rendered with an odd
+;; "span", i.e., (% (- HI LO -1) 2) => 1, since the origin is *on* an
+;; integral coordinate (i.e., intersection of row and column).
+;;
+;; This file provides funcs `xpm-m2z-ellipse' and `xpm-m2z-circle' to
+;; locally rectify the current situation ("m2z" means "modulo 2 => 0"),
+;; with the hope that eventually a generalization can be worked back
+;; into artist.el, perhaps as a subpixel-center minor mode of some sort.
+
+;;; Code:
+
+(require 'artist)
+(require 'cl-lib)
+
+;;;###autoload
+(defun xpm-m2z-ellipse (cx cy rx ry)
+  "Return an ellipse with center (CX,CY) and radii RX and RY.
+Both CX and CY must be non-integer, preferably
+precisely half-way between integers, e.g., 13/2 => 6.5.
+The ellipse is represented as a list of unique XPM coords,
+with the \"span\", i.e., (- HI LO -1) of the extreme X and Y
+components is equal to twice the rounded (to integer) value
+of RX and RY, respectively.  For example:
+
+ (xpm-m2z-ellipse 1.5 3.5 5.8 4.2)
+ => list of length 20
+
+    min  max  span
+ X   -3    6    10
+ Y    0    7     8
+
+The span is always an even number.  As a special case,
+if RX or RY is less than 1, the value is nil."
+  (assert (not (integerp cx)))
+  (assert (not (integerp cy)))
+  (unless (or (> 1 (abs rx))
+              (> 1 (abs ry)))
+    (cl-flet*
+        ((offset (coord idx)
+                 (- (aref coord idx) 0.5))
+         (normal (coord)
+                 ;; flip axes: artist (ROW,COL) to xpm (X,Y)
+                 (cons
+                  (offset coord 1)      ; 1: COL -> car: X
+                  (offset coord 0)))    ; 0: ROW -> cdr: Y
+         (placed (origin scale n)
+                 (truncate (+ origin (* scale n))))
+         (orient (coords quadrant)
+                 (loop with (sx . sy) = quadrant
+                       for (x . y) in coords
+                       collect (cons (placed cx sx x)
+                                     (placed cy sy y)))))
+      (delete-dups
+       (loop with coords = (mapcar
+                            #'normal
+                            (artist-ellipse-generate-quadrant
+                             ;; Specify row first; artist.el is like that.
+                             ;; (That's why ‘normal’ does what it does...)
+                             ry rx))
+             for quadrant               ; these are in order: I-IV
+             in '(( 1 .  1)             ; todo: "manually" remove single
+                  (-1 .  1)             ;       (border point) overlaps;
+                  (-1 . -1)             ;       avoid ‘delete-dups’
+                  ( 1 . -1))
+             append (orient coords quadrant))))))
+
+;;;###autoload
+(defun xpm-m2z-circle (cx cy radius)
+  "Like `xpm-m2z-ellipse' with a shared radius RADIUS."
+  (xpm-m2z-ellipse cx cy radius radius))
+
+(provide 'xpm-m2z)
+
+;;; xpm-m2z.el ends here
diff --git a/xpm.el b/xpm.el
new file mode 100644
index 0000000..c08ea33
--- /dev/null
+++ b/xpm.el
@@ -0,0 +1,419 @@
+;;; 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
+
+;; 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 on
+;; adding a XPM mode in a future release; see HACKING link below.
+;;
+;; 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).)
+;;
+;;
+;; See Also
+;; - HACKING: 
<http://git.sv.gnu.org/cgit/emacs/elpa.git/tree/packages/xpm/HACKING>
+;; - Tip Jar: <http://www.gnuvola.org/software/xpm/>
+
+;;; Code:
+
+(require 'cl-lib)
+
+(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 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 "^\"")
+      (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))
+
+;;;###autoload
+(defun xpm-generate-buffer (name width height cpp palette)
+  "Return a new buffer in XPM image format.
+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 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)
+        (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 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, then pair its elements with the other integer component
+and place N points.
+
+If one of X or Y is a pair (LOW . HIGH), take it to be equivalent
+t 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)
+                (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 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)
+      (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)
+                 (loop for i from start repeat len
+                       do (aset bv i value)))
+           (scan (bv start len yes no)
+                 (loop for i from start repeat len
+                       when (aref bv i)
+                       return yes
+                       finally return no)))
+        (setq int (make-bool-vector (span x-min x-max) nil)
+              nin (make-bool-vector (span x-min x-max) nil)
+              ext (make-bool-vector (span x-min x-max) t))
+        (loop
+         with (in-map-ok
+               in-map)
+         for y below h
+         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
+             (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
+             (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
+                       (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
+                           (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