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         (cl-loop
 124          repeat nc
 125          do (let ((p (1+ (point))))
 126               (puthash (buffer-substring-no-properties
 127                         p (+ p cpp))
 128                        ;; Don't bother w/ CVALUE for now.
 129                        t ht)
 130               (forward-line 1)))
 131         (setq pinfo (cons pinfo ht))
 132         (skip-chars-forward "^\"")
 133         (forward-char 1)
 134         (set (make-local-variable 'xpm--gg)
 135              (setq gg (xpm--make-gg
 136                        :w w :h h :cpp cpp
 137                        :pinfo  pinfo
 138                        :origin (point-marker)
 139                        :y-mult (+ 4 (* cpp w)))))
 140         (unless simple
 141           (let ((mod (buffer-modified-p))
 142                 (inhibit-read-only t))
 143             (cl-flet
 144                 ((suppress (span &rest more)
 145                            (let ((p (point)))
 146                              (add-text-properties
 147                               (- p span) p (list* 'intangible t
 148                                                   more)))))
 149               (suppress 1)
 150               (cl-loop
 151                repeat h
 152                do (progn (forward-char (+ 4 (* w cpp)))
 153                          (suppress 4)))
 154               (suppress 2 'display "\a\ e\15\n\ 6\13\ 6")
 155               (push 'intangible-sides (xpm--flags gg)))
 156             (set-buffer-modified-p mod)))
 157         (when (called-interactively-p 'interactive)
 158           (message "%dx%d, %d cpp, %d colors in palette"
 159                    w h cpp (hash-table-count ht)))))
 160     gg))
 161
 162 (defun xpm--gate ()
 163   (or xpm--gg
 164       (xpm-grok)
 165       (error "Sorry, xpm confused")))
 166
 167 (cl-defmacro xpm--w/gg (names from &body body)
 168   (declare (indent 2))
 169   `(let* ((gg ,from)
 170           ,@(mapcar (lambda (name)
 171                       `(,name (,(intern (format "xpm--%s" name))
 172                                gg)))
 173                     `,names))
 174      ,@body))
 175
 176 ;;;###autoload
 177 (defun xpm-generate-buffer (name width height cpp palette)
 178   "Return a new buffer in XPM image format.
 179 NAME is the buffer and XPM name.  For best interoperation
 180 with other programs, NAME should be a valid C identifier.
 181 WIDTH, HEIGHT and CPP are integers that specify the image
 182 width, height and characters/pixel, respectively.
 183
 184 PALETTE is an alist ((PX . COLOR) ...), where PX is either
 185 a character or string of length CPP, and COLOR is a string.
 186 If COLOR includes a space, it is included directly,
 187 otherwise it is automatically prefixed with \"c \".
 188
 189 For example, to produce fragment:
 190
 191  \"X  c blue\",
 192  \"Y  s border c green\",
 193
 194 you can specify PALETTE as:
 195
 196  ((?X . \"blue\") (?Y . \"s border c green\"))
 197
 198 This example presumes CPP is 1."
 199   (let ((buf (generate-new-buffer name)))
 200     (with-current-buffer buf
 201       (buffer-disable-undo)
 202       (cl-flet
 203           ((yep (s &rest args)
 204                 (insert (apply 'format s args) "\n")))
 205         (yep "/* XPM */")
 206         (yep "static char * %s[] = {" name)
 207         (yep "\"%d %d %d %d\"," width height (length palette) cpp)
 208         (cl-loop
 209          for (px . color) in palette
 210          do (yep "\"%s  %s\","
 211                  (if (characterp px)
 212                      (string px)
 213                    px)
 214                  (if (string-match " " color)
 215                      color
 216                    (concat "c " color))))
 217         (cl-loop
 218          with s = (format "%S,\n" (make-string (* cpp width) 32))
 219          repeat height
 220          do (insert s))
 221         (delete-char -2)
 222         (yep "};")
 223         (xpm-grok t)))
 224     buf))
 225
 226 (defun xpm-put-points (px x y)
 227   "Place PX at coordinate(s) (X,Y).
 228
 229 If both X and Y are vectors of length N, then place N points
 230 using the pairwise vector elements.  If one of X or Y is a vector
 231 of length N, then pair its elements with the other integer component
 232 and place N points.
 233
 234 If one of X or Y is a pair (LOW . HIGH), take it to be equivalent
 235 to specfiying a vector [LOW ... HIGH].  For example, (3 . 8) is
 236 equivalent to [3 4 5 6 7 8].  If one component is a pair, the
 237 other must be an integer -- the case where both X and Y are pairs
 238 is not supported.
 239
 240 Silently ignore out-of-range coordinates."
 241   (xpm--w/gg (w h cpp origin y-mult) (xpm--gate)
 242     (when (and (stringp px) (= 1 cpp))
 243       (setq px (aref px 0)))
 244     (cl-flet*
 245         ((out (col row)
 246               (or (> 0 col) (<= w col)
 247                   (> 0 row) (<= h row)))
 248          (pos (col row)
 249               (goto-char (+ origin (* cpp col) (* y-mult row))))
 250          (jam (col row len)
 251               (pos col row)
 252               (insert-char px len)
 253               (delete-char len))
 254          (rep (col row len)
 255               (pos col row)
 256               (if (= 1 cpp)
 257                   (insert-char px len)
 258                 (cl-loop
 259                  repeat len
 260                  do (insert px)))
 261               (delete-char (* cpp len)))
 262          (zow (col row)
 263               (unless (out col row)
 264                 (rep col row 1))))
 265       (pcase (cons (type-of x) (type-of y))
 266         (`(cons . integer)    (let* ((beg (max 0 (car x)))
 267                                      (end (min (1- w) (cdr x)))
 268                                      (len (- end beg -1)))
 269                                 (unless (or (> 1 len)
 270                                             (out beg y))
 271                                   (if (< 1 cpp)
 272                                       ;; general
 273                                       (rep beg y len)
 274                                     ;; fast(er) path
 275                                     (when (stringp px)
 276                                       (setq px (aref px 0)))
 277                                     (jam beg y len)))))
 278         (`(integer . cons)    (cl-loop
 279                                for two from (car y) to (cdr y)
 280                                do (zow x two)))
 281         (`(vector . integer)  (cl-loop
 282                                for one across x
 283                                do (zow one y)))
 284         (`(integer . vector)  (cl-loop
 285                                for two across y
 286                                do (zow x two)))
 287         (`(vector . vector)   (cl-loop
 288                                for one across x
 289                                for two across y
 290                                do (zow one two)))
 291         (`(integer . integer) (zow x y))
 292         (_ (error "Bad coordinates: X %S, Y %S"
 293                   x y))))))
 294
 295 (defun xpm-raster (form edge &optional fill)
 296   "Rasterize FORM with EDGE pixel (character or string).
 297 FORM is a list of coordinates that comprise a closed shape.
 298 Optional arg FILL specifies a fill pixel, or t to fill with EDGE.
 299
 300 If FORM is not closed or has inopportune vertical-facing
 301 concavities, filling might give bad results.  For those cases,
 302 see variable `xpm-raster-inhibit-continuity-optimization'."
 303   (when (eq t fill)
 304     (setq fill edge))
 305   (xpm--w/gg (h) (xpm--gate)
 306     (let* ((v (make-vector h nil))
 307            (x-min (caar form))          ; (maybe) todo: xpm--bb
 308            (x-max x-min)
 309            (y-min (cdar form))
 310            (y-max y-min)
 311            (use-in-map (not xpm-raster-inhibit-continuity-optimization))
 312            ;; These are bool-vectors to keep track of both internal
 313            ;; (filled and its "next" (double-buffering)) and external
 314            ;; state, on a line-by-line basis.
 315            int nin
 316            ext)
 317       (cl-loop
 318        for (x . y) in form
 319        do (setq x-min (min x-min x)
 320                 x-max (max x-max x)
 321                 y-min (min y-min y)
 322                 y-max (max y-max y))
 323        unless (or (> 0 y)
 324                   (<= h y))
 325        do (push x (aref v y)))
 326       (cl-flet
 327           ((span (lo hi)
 328                  (- hi lo -1))
 329            (norm (n)
 330                  (- n x-min))
 331            (rset (bv start len value)
 332                  (cl-loop
 333                   for i from start repeat len
 334                   do (aset bv i value)))
 335            (scan (bv start len yes no)
 336                  (cl-loop
 337                   for i from start repeat len
 338                   when (aref bv i)
 339                   return yes
 340                   finally return no)))
 341         (let ((len (span x-min x-max)))
 342           (setq int (make-bool-vector len nil)
 343                 nin (make-bool-vector len nil)
 344                 ext (make-bool-vector len t)))
 345         (cl-loop
 346
 347          with (ls
 348                in-map-ok
 349                in-map)
 350          for y from (1- y-min) to y-max
 351          when (setq ls (and (< -1 y)
 352                             (> h y)
 353                             (sort (aref v y) '>)))
 354          do (cl-loop
 355
 356              with acc = (list (car ls))
 357              for maybe in (cdr ls)
 358              do (let* ((was (car acc))
 359                        (already (consp was)))
 360                   (cond ((/= (1- (if already
 361                                      (car was)
 362                                    was))
 363                              maybe)
 364                          (push maybe acc))
 365                         (already
 366                          (setcar was maybe))
 367                         (t
 368                          (setcar acc (cons maybe was)))))
 369              finally do
 370              (when fill
 371                (let ((was (length in-map))
 372                      (now (length acc)))
 373                  (unless (setq in-map-ok
 374                                (and (= was now)
 375                                     ;; heuristic: Avoid being fooled
 376                                     ;; by simulataneous crossings.
 377                                     (cl-evenp was)))
 378                    (setq in-map (make-bool-vector now nil)))))
 379              finally do
 380              (cl-loop
 381
 382               with (x rangep beg nx end len nb in)
 383               for gap from 0
 384               while acc
 385               do (setq x (pop acc))
 386               do (xpm-put-points edge x y)
 387               do (when fill
 388                    (setq rangep (consp x))
 389                    (when (zerop gap)
 390                      (rset ext 0 (norm (if rangep
 391                                            (car x)
 392                                          x))
 393                            t))
 394                    (if rangep
 395                        (destructuring-bind (b . e) x
 396                          (rset ext (norm b) (span b e) nil))
 397                      (aset ext (norm x) nil))
 398                    (when acc
 399                      (setq beg (1+ (if rangep
 400                                        (cdr x)
 401                                      x))
 402                            nx (car acc)
 403                            end (1- (if (consp nx)
 404                                        (car nx)
 405                                      nx))
 406                            len (span beg end)
 407                            nb (norm beg)
 408                            in (cond ((and use-in-map in-map-ok)
 409                                      (aref in-map gap))
 410                                     (in (scan int nb len t nil))
 411                                     (t (scan ext nb len nil t))))
 412                      (unless in-map-ok
 413                        (aset in-map gap in))
 414                      (if (not in)
 415                          (rset ext nb len t)
 416                        (rset nin nb len t)
 417                        (xpm-put-points fill (cons beg end) y))))
 418               finally do (when fill
 419                            (rotatef int nin)
 420                            (fillarray nin nil)))))))))
 421
 422 (defun xpm-as-xpm (&rest props)
 423   "Return the XPM image (via `create-image') of the buffer.
 424 PROPS are additional image properties to place on
 425 the new XPM.  See info node `(elisp) XPM Images'."
 426   (apply 'create-image (buffer-substring-no-properties
 427                         (point-min) (point-max))
 428          'xpm t props))
 429
 430 (defun xpm-finish (&rest props)
 431   "Like `xpm-as-xpm', but also kill the buffer afterwards."
 432   (prog1 (apply 'xpm-as-xpm props)
 433     (kill-buffer nil)))
 434
 435 (provide 'xpm)
 436
 437 ;;; xpm.el ends here