code.delx.au - gnu-emacs-elpa/blob - packages/xpm/xpm.el

   1 ;;; xpm.el --- edit XPM images               -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2014  Free Software Foundation, Inc.
   4
   5 ;; Author: Thien-Thi Nguyen <ttn@gnu.org>
   6 ;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
   7 ;; Version: 1.0.2
   8 ;; Keywords: multimedia, xpm
   9 ;; URL: http://www.gnuvola.org/software/xpm/
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; This package makes editing XPM images easy (and maybe fun).
  27 ;; Editing is done directly on the (textual) image format,
  28 ;; for maximal cohesion w/ the Emacs Way.
  29 ;;
  30 ;; Coordinates have the form (X . Y), with X from 0 to (width-1),
  31 ;; and Y from 0 to (height-1), inclusive, in the 4th quadrant;
  32 ;; i.e., X grows left to right, Y top to bottom, origin top-left.
  33 ;;
  34 ;;   (0,0)        … (width-1,0)
  35 ;;     ⋮                    ⋮
  36 ;;   (0,height-1) … (width-1,height-1)
  37 ;;
  38 ;; In xpm.el (et al), "px" stands for "pixel", a non-empty string
  39 ;; in the external representation of the image.  The px length is
  40 ;; the image's "cpp" (characters per pixel).  The "palette" is a
  41 ;; set of associations between a px and its "color", which is an
  42 ;; alist with symbolic TYPE and and string CVALUE.  TYPE is one of:
  43 ;;
  44 ;;   c  -- color (most common)
  45 ;;   s  -- symbolic
  46 ;;   g  -- grayscale
  47 ;;   g4 -- four-level grayscale
  48 ;;   m  -- monochrome
  49 ;;
  50 ;; and CVALUE is a string, e.g., "blue" or "#0000FF".  Two images
  51 ;; are "congruent" if their width, height and cpp are identical.
  52 ;;
  53 ;; This package was originally conceived for non-interactive use,
  54 ;; so its design is spartan at the core.  However, we plan on
  55 ;; adding a XPM mode in a future release; see HACKING link below.
  56 ;;
  57 ;; For now, the features (w/ correspondingly-named files) are:
  58 ;; - xpm          -- edit XPM images
  59 ;; - xpm-m2z      -- ellipse/circle w/ fractional center
  60 ;;
  61 ;; Some things are autoloaded.  Which ones?  Use the source, Luke!
  62 ;; (Alternatively, just ask on help-gnu-emacs (at gnu dot org).)
  63
  64 ;;; Code:
  65
  66 (require 'cl-lib)
  67 (eval-when-compile (require 'cl))
  68
  69 (autoload 'image-toggle-display "image-mode" t) ; hmm is this TRT?
  70
  71 (defvar xpm-raster-inhibit-continuity-optimization nil
  72   "Non-nil disables a heuristic in `xpm-raster' filling.
  73 Normally, if you pass a well-formed (closed, no edge crossings)
  74 shape to `xpm-raster', then you can ignore this variable.")
  75
  76 (cl-defstruct (xpm--gg                  ; gathered gleanings
  77                (:type vector)           ; no ‘:named’ so no predicate
  78                (:conc-name xpm--)
  79                (:constructor xpm--make-gg)
  80                (:copier xpm--copy-gg))
  81   (w :read-only t) (h :read-only t) (cpp :read-only t)
  82   pinfo                                 ; (MARKER . HASH-TABLE)
  83   (origin :read-only t)
  84   (y-mult :read-only t)
  85   flags)
  86
  87 (defvar xpm--gg nil
  88   "Various bits for xpm.el (et al) internal use.")
  89
  90 ;;;###autoload
  91 (defun xpm-grok (&optional simple)
  92   "Analyze buffer and prepare internal data structures.
  93 When called as a command, display in the echo area a
  94 summary of image dimensions, cpp and palette.
  95 Set buffer-local variable `xpm--gg' and return its value.
  96 Normally, preparation includes making certain parts of
  97 the buffer intangible.  Optional arg SIMPLE inhibits that."
  98   (interactive)
  99   (unless (or
 100            ;; easy
 101            (and (boundp 'image-type)
 102                 (eq 'xpm image-type))
 103            ;; hard
 104            (save-excursion
 105              (goto-char (point-min))
 106              (string= "/* XPM */"
 107                       (buffer-substring-no-properties
 108                        (point) (line-end-position)))))
 109     (error "Buffer not an XPM image"))
 110   (when (eq 'image-mode major-mode)
 111     (image-toggle-display))
 112   (let ((ht (make-hash-table :test 'equal))
 113         pinfo gg)
 114     (save-excursion
 115       (goto-char (point-min))
 116       (search-forward "{")
 117       (skip-chars-forward "^\"")
 118       (destructuring-bind (w h nc cpp &rest rest)
 119           (read (format "(%s)" (read (current-buffer))))
 120         (ignore rest)                   ; for now
 121         (forward-line 1)
 122         (setq pinfo (point-marker))
 123         (loop repeat nc
 124               do (let ((p (1+ (point))))
 125                    (puthash (buffer-substring-no-properties
 126                              p (+ p cpp))
 127                             ;; Don't bother w/ CVALUE for now.
 128                             t ht)
 129                    (forward-line 1)))
 130         (setq pinfo (cons pinfo ht))
 131         (skip-chars-forward "^\"")
 132         (forward-char 1)
 133         (set (make-local-variable 'xpm--gg)
 134              (setq gg (xpm--make-gg
 135                        :w w :h h :cpp cpp
 136                        :pinfo  pinfo
 137                        :origin (point-marker)
 138                        :y-mult (+ 4 (* cpp w)))))
 139         (unless simple
 140           (let ((mod (buffer-modified-p))
 141                 (inhibit-read-only t))
 142             (cl-flet
 143                 ((suppress (span &rest more)
 144                            (let ((p (point)))
 145                              (add-text-properties
 146                               (- p span) p (list* 'intangible t
 147                                                   more)))))
 148               (suppress 1)
 149               (loop repeat h
 150                     do (progn (forward-char (+ 4 (* w cpp)))
 151                               (suppress 4)))
 152               (suppress 2 'display "\a\ e\15\n\ 6\13\ 6")
 153               (push 'intangible-sides (xpm--flags gg)))
 154             (set-buffer-modified-p mod)))
 155         (when (called-interactively-p 'interactive)
 156           (message "%dx%d, %d cpp, %d colors in palette"
 157                    w h cpp (hash-table-count ht)))))
 158     gg))
 159
 160 (defun xpm--gate ()
 161   (or xpm--gg
 162       (xpm-grok)
 163       (error "Sorry, xpm confused")))
 164
 165 (cl-defmacro xpm--w/gg (names from &body body)
 166   (declare (indent 2))
 167   `(let* ((gg ,from)
 168           ,@(mapcar (lambda (name)
 169                       `(,name (,(intern (format "xpm--%s" name))
 170                                gg)))
 171                     `,names))
 172      ,@body))
 173
 174 ;;;###autoload
 175 (defun xpm-generate-buffer (name width height cpp palette)
 176   "Return a new buffer in XPM image format.
 177 NAME is the buffer and XPM name.  For best interoperation
 178 with other programs, NAME should be a valid C identifier.
 179 WIDTH, HEIGHT and CPP are integers that specify the image
 180 width, height and characters/pixel, respectively.
 181
 182 PALETTE is an alist ((PX . COLOR) ...), where PX is either
 183 a character or string of length CPP, and COLOR is a string.
 184 If COLOR includes a space, it is included directly,
 185 otherwise it is automatically prefixed with \"c \".
 186
 187 For example, to produce fragment:
 188
 189  \"X  c blue\",
 190  \"Y  s border c green\",
 191
 192 you can specify PALETTE as:
 193
 194  ((?X . \"blue\") (?Y . \"s border c green\"))
 195
 196 This example presumes CPP is 1."
 197   (let ((buf (generate-new-buffer name)))
 198     (with-current-buffer buf
 199       (buffer-disable-undo)
 200       (cl-flet
 201           ((yep (s &rest args)
 202                 (insert (apply 'format s args) "\n")))
 203         (yep "/* XPM */")
 204         (yep "static char * %s[] = {" name)
 205         (yep "\"%d %d %d %d\"," width height (length palette) cpp)
 206         (loop for (px . color) in palette
 207               do (yep "\"%s  %s\","
 208                       (if (characterp px)
 209                           (string px)
 210                         px)
 211                       (if (string-match " " color)
 212                           color
 213                         (concat "c " color))))
 214         (loop with s = (format "%S,\n" (make-string (* cpp width) 32))
 215               repeat height
 216               do (insert s))
 217         (delete-char -2)
 218         (yep "};")
 219         (xpm-grok t)))
 220     buf))
 221
 222 (defun xpm-put-points (px x y)
 223   "Place PX at coordinate(s) (X,Y).
 224
 225 If both X and Y are vectors of length N, then place N points
 226 using the pairwise vector elements.  If one of X or Y is a vector
 227 of length N, then pair its elements with the other integer component
 228 and place N points.
 229
 230 If one of X or Y is a pair (LOW . HIGH), take it to be equivalent
 231 t specfiying a vector [LOW ... HIGH].  For example, (3 . 8) is
 232 equivalent to [3 4 5 6 7 8].  If one component is a pair, the
 233 other must be an integer -- the case where both X and Y are pairs
 234 is not supported.
 235
 236 Silently ignore out-of-range coordinates."
 237   (xpm--w/gg (w h cpp origin y-mult) (xpm--gate)
 238     (when (and (stringp px) (= 1 cpp))
 239       (setq px (aref px 0)))
 240     (cl-flet*
 241         ((out (col row)
 242               (or (> 0 col) (<= w col)
 243                   (> 0 row) (<= h row)))
 244          (pos (col row)
 245               (goto-char (+ origin (* cpp col) (* y-mult row))))
 246          (jam (col row len)
 247               (pos col row)
 248               (insert-char px len)
 249               (delete-char len))
 250          (rep (col row len)
 251               (pos col row)
 252               (if (= 1 cpp)
 253                   (insert-char px len)
 254                 (loop repeat len do (insert px)))
 255               (delete-char (* cpp len)))
 256          (zow (col row)
 257               (unless (out col row)
 258                 (rep col row 1))))
 259       (pcase (cons (type-of x) (type-of y))
 260         (`(cons . integer)    (let* ((beg (max 0 (car x)))
 261                                      (end (min (1- w) (cdr x)))
 262                                      (len (- end beg -1)))
 263                                 (unless (or (> 1 len)
 264                                             (out beg y))
 265                                   (if (< 1 cpp)
 266                                       ;; general
 267                                       (rep beg y len)
 268                                     ;; fast(er) path
 269                                     (when (stringp px)
 270                                       (setq px (aref px 0)))
 271                                     (jam beg y len)))))
 272         (`(integer . cons)    (loop for two from (car y) to (cdr y)
 273                                     do (zow x two)))
 274         (`(vector . integer)  (loop for one across x
 275                                     do (zow one y)))
 276         (`(integer . vector)  (loop for two across y
 277                                     do (zow x two)))
 278         (`(vector . vector)   (loop for one across x
 279                                     for two across y
 280                                     do (zow one two)))
 281         (`(integer . integer) (zow x y))
 282         (_ (error "Bad coordinates: X %S, Y %S"
 283                   x y))))))
 284
 285 (defun xpm-raster (form edge &optional fill)
 286   "Rasterize FORM with EDGE pixel (character or string).
 287 FORM is a list of coordinates that comprise a closed shape.
 288 Optional arg FILL specifies a fill pixel, or t to fill with EDGE.
 289
 290 If FORM is not closed or has inopportune vertical-facing
 291 concavities, filling might give bad results.  For those cases,
 292 see variable `xpm-raster-inhibit-continuity-optimization'."
 293   (when (eq t fill)
 294     (setq fill edge))
 295   (xpm--w/gg (h) (xpm--gate)
 296     (let* ((v (make-vector h nil))
 297            (x-min (caar form))          ; (maybe) todo: xpm--bb
 298            (x-max x-min)
 299            (y-min (cdar form))
 300            (y-max y-min)
 301            (use-in-map (not xpm-raster-inhibit-continuity-optimization))
 302            ;; These are bool-vectors to keep track of both internal
 303            ;; (filled and its "next" (double-buffering)) and external
 304            ;; state, on a line-by-line basis.
 305            int nin
 306            ext)
 307       (loop for (x . y) in form
 308             do (setq x-min (min x-min x)
 309                      x-max (max x-max x)
 310                      y-min (min y-min y)
 311                      y-max (max y-max y))
 312             unless (or (> 0 y)
 313                        (<= h y))
 314             do (push x (aref v y)))
 315       (cl-flet
 316           ((span (lo hi)
 317                  (- hi lo -1))
 318            (norm (n)
 319                  (- n x-min))
 320            (rset (bv start len value)
 321                  (loop for i from start repeat len
 322                        do (aset bv i value)))
 323            (scan (bv start len yes no)
 324                  (loop for i from start repeat len
 325                        when (aref bv i)
 326                        return yes
 327                        finally return no)))
 328         (let ((len (span x-min x-max)))
 329           (setq int (make-bool-vector len nil)
 330                 nin (make-bool-vector len nil)
 331                 ext (make-bool-vector len t)))
 332         (loop
 333          with (ls
 334                in-map-ok
 335                in-map)
 336          for y from (1- y-min) to y-max
 337          when (setq ls (and (< -1 y)
 338                             (> h y)
 339                             (sort (aref v y) '>)))
 340          do (loop
 341              with acc = (list (car ls))
 342              for maybe in (cdr ls)
 343              do (let* ((was (car acc))
 344                        (already (consp was)))
 345                   (cond ((/= (1- (if already
 346                                      (car was)
 347                                    was))
 348                              maybe)
 349                          (push maybe acc))
 350                         (already
 351                          (setcar was maybe))
 352                         (t
 353                          (setcar acc (cons maybe was)))))
 354              finally do
 355              (when fill
 356                (let ((was (length in-map))
 357                      (now (length acc)))
 358                  (unless (setq in-map-ok
 359                                (and (= was now)
 360                                     ;; heuristic: Avoid being fooled
 361                                     ;; by simulataneous crossings.
 362                                     (cl-evenp was)))
 363                    (setq in-map (make-bool-vector now nil)))))
 364              finally do
 365              (loop
 366               with (x rangep beg nx end len nb in)
 367               for gap from 0
 368               while acc
 369               do (setq x (pop acc))
 370               do (xpm-put-points edge x y)
 371               do (when fill
 372                    (setq rangep (consp x))
 373                    (when (zerop gap)
 374                      (rset ext 0 (norm (if rangep
 375                                            (car x)
 376                                          x))
 377                            t))
 378                    (if rangep
 379                        (destructuring-bind (b . e) x
 380                          (rset ext (norm b) (span b e) nil))
 381                      (aset ext (norm x) nil))
 382                    (when acc
 383                      (setq beg (1+ (if rangep
 384                                        (cdr x)
 385                                      x))
 386                            nx (car acc)
 387                            end (1- (if (consp nx)
 388                                        (car nx)
 389                                      nx))
 390                            len (span beg end)
 391                            nb (norm beg)
 392                            in (cond ((and use-in-map in-map-ok)
 393                                      (aref in-map gap))
 394                                     (in (scan int nb len t nil))
 395                                     (t (scan ext nb len nil t))))
 396                      (unless in-map-ok
 397                        (aset in-map gap in))
 398                      (if (not in)
 399                          (rset ext nb len t)
 400                        (rset nin nb len t)
 401                        (xpm-put-points fill (cons beg end) y))))
 402               finally do (when fill
 403                            (rotatef int nin)
 404                            (fillarray nin nil)))))))))
 405
 406 (defun xpm-as-xpm (&rest props)
 407   "Return the XPM image (via `create-image') of the buffer.
 408 PROPS are additional image properties to place on
 409 the new XPM.  See info node `(elisp) XPM Images'."
 410   (apply 'create-image (buffer-substring-no-properties
 411                         (point-min) (point-max))
 412          'xpm t props))
 413
 414 (defun xpm-finish (&rest props)
 415   "Like `xpm-as-xpm', but also kill the buffer afterwards."
 416   (prog1 (apply 'xpm-as-xpm props)
 417     (kill-buffer nil)))
 418
 419 (provide 'xpm)
 420
 421 ;;; xpm.el ends here