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.3
   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 to add
  55 ;; a XPM mode in a future release; monitor the homepage for updates.
  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
  68 (autoload 'image-toggle-display "image-mode" t) ; hmm is this TRT?
  69
  70 (defvar xpm-raster-inhibit-continuity-optimization nil
  71   "Non-nil disables a heuristic in `xpm-raster' filling.
  72 Normally, if you pass a well-formed (closed, no edge crossings)
  73 shape to `xpm-raster', then you can ignore this variable.")
  74
  75 (cl-defstruct (xpm--gg                  ; gathered gleanings
  76                (:type vector)           ; no ‘:named’ so no predicate
  77                (:conc-name xpm--)
  78                (:constructor xpm--make-gg)
  79                (:copier xpm--copy-gg))
  80   (w :read-only t) (h :read-only t) (cpp :read-only t)
  81   pinfo                                 ; (MARKER . HASH-TABLE)
  82   (origin :read-only t)
  83   (y-mult :read-only t)
  84   flags)
  85
  86 (defvar xpm--gg nil
  87   "Various bits for xpm.el (et al) internal use.")
  88
  89 ;;;###autoload
  90 (defun xpm-grok (&optional simple)
  91   "Analyze buffer and prepare internal data structures.
  92 When called as a command, display in the echo area a
  93 summary of image dimensions, cpp and palette.
  94 Set buffer-local variable `xpm--gg' and return its value.
  95 Normally, preparation includes making certain parts of the
  96 buffer intangible.  Optional arg SIMPLE non-nil inhibits that."
  97   (interactive)
  98   (unless (or
  99            ;; easy
 100            (and (boundp 'image-type)
 101                 (eq 'xpm image-type))
 102            ;; hard
 103            (save-excursion
 104              (goto-char (point-min))
 105              (string= "/* XPM */"
 106                       (buffer-substring-no-properties
 107                        (point) (line-end-position)))))
 108     (error "Buffer not an XPM image"))
 109   (when (eq 'image-mode major-mode)
 110     (image-toggle-display))
 111   (let ((ht (make-hash-table :test 'equal))
 112         pinfo gg)
 113     (save-excursion
 114       (goto-char (point-min))
 115       (search-forward "{")
 116       (skip-chars-forward "^\"")
 117       (cl-destructuring-bind (w h nc cpp &rest rest)
 118           (read (format "(%s)" (read (current-buffer))))
 119         (ignore rest)                   ; for now
 120         (forward-line 1)
 121         (setq pinfo (point-marker))
 122         (cl-loop
 123          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 (cl-list*
 147                                             '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 In this buffer, undo is disabled (see `buffer-enable-undo').
 180
 181 NAME is the buffer and XPM name.  For best interoperation
 182 with other programs, NAME should be a valid C identifier.
 183 WIDTH, HEIGHT and CPP are integers that specify the image
 184 width, height and characters/pixel, respectively.
 185
 186 PALETTE is an alist ((PX . COLOR) ...), where PX is either
 187 a character or string of length CPP, and COLOR is a string.
 188 If COLOR includes a space, it is included directly,
 189 otherwise it is automatically prefixed with \"c \".
 190
 191 For example, to produce palette fragment:
 192
 193  \"X  c blue\",
 194  \"Y  s border c green\",
 195
 196 you can specify PALETTE as:
 197
 198  ((?X . \"blue\")
 199   (?Y . \"s border c green\"))
 200
 201 This example presumes CPP is 1."
 202   (let ((buf (generate-new-buffer name)))
 203     (with-current-buffer buf
 204       (buffer-disable-undo)
 205       (cl-flet
 206           ((yep (s &rest args)
 207                 (insert (apply 'format s args) "\n")))
 208         (yep "/* XPM */")
 209         (yep "static char * %s[] = {" name)
 210         (yep "\"%d %d %d %d\"," width height (length palette) cpp)
 211         (cl-loop
 212          for (px . color) in palette
 213          do (yep "\"%s  %s\","
 214                  (if (characterp px)
 215                      (string px)
 216                    px)
 217                  (if (string-match " " color)
 218                      color
 219                    (concat "c " color))))
 220         (cl-loop
 221          with s = (format "%S,\n" (make-string (* cpp width) 32))
 222          repeat height
 223          do (insert s))
 224         (delete-char -2)
 225         (yep "};")
 226         (xpm-grok t)))
 227     buf))
 228
 229 (defun xpm-put-points (px x y)
 230   "Place PX at coordinate(s) (X,Y).
 231
 232 If both X and Y are vectors of length N, then place N points
 233 using the pairwise vector elements.  If one of X or Y is a vector
 234 of length N and the other component is an integer, then pair the
 235 vector elements with the integer component and place N points.
 236
 237 If one of X or Y is a pair (LOW . HIGH), take it to be equivalent
 238 to specfiying a vector [LOW ... HIGH].  For example, (3 . 8) is
 239 equivalent to [3 4 5 6 7 8].  If one component is a pair, the
 240 other must be an integer -- the case where both X and Y are pairs
 241 is not supported.
 242
 243 Silently ignore out-of-range coordinates."
 244   (xpm--w/gg (w h cpp origin y-mult) (xpm--gate)
 245     (when (and (stringp px) (= 1 cpp))
 246       (setq px (aref px 0)))
 247     (cl-flet*
 248         ((out (col row)
 249               (or (> 0 col) (<= w col)
 250                   (> 0 row) (<= h row)))
 251          (pos (col row)
 252               (goto-char (+ origin (* cpp col) (* y-mult row))))
 253          (jam (col row len)
 254               (pos col row)
 255               (insert-char px len)
 256               (delete-char len))
 257          (rep (col row len)
 258               (pos col row)
 259               (if (= 1 cpp)
 260                   (insert-char px len)
 261                 (cl-loop
 262                  repeat len
 263                  do (insert px)))
 264               (delete-char (* cpp len)))
 265          (zow (col row)
 266               (unless (out col row)
 267                 (rep col row 1))))
 268       (pcase (cons (type-of x) (type-of y))
 269         (`(cons . integer)    (let* ((beg (max 0 (car x)))
 270                                      (end (min (1- w) (cdr x)))
 271                                      (len (- end beg -1)))
 272                                 (unless (or (> 1 len)
 273                                             (out beg y))
 274                                   (if (< 1 cpp)
 275                                       ;; general
 276                                       (rep beg y len)
 277                                     ;; fast(er) path
 278                                     (when (stringp px)
 279                                       (setq px (aref px 0)))
 280                                     (jam beg y len)))))
 281         (`(integer . cons)    (cl-loop
 282                                for two from (car y) to (cdr y)
 283                                do (zow x two)))
 284         (`(vector . integer)  (cl-loop
 285                                for one across x
 286                                do (zow one y)))
 287         (`(integer . vector)  (cl-loop
 288                                for two across y
 289                                do (zow x two)))
 290         (`(vector . vector)   (cl-loop
 291                                for one across x
 292                                for two across y
 293                                do (zow one two)))
 294         (`(integer . integer) (zow x y))
 295         (_ (error "Bad coordinates: X %S, Y %S"
 296                   x y))))))
 297
 298 (defun xpm-raster (form edge &optional fill)
 299   "Rasterize FORM with EDGE pixel (character or string).
 300 FORM is a list of coordinates that comprise a closed shape.
 301 Optional arg FILL specifies a fill pixel, or t to fill with EDGE.
 302
 303 If FORM is not closed or has inopportune vertical-facing
 304 concavities, filling might give bad results.  For those cases,
 305 see variable `xpm-raster-inhibit-continuity-optimization'."
 306   (when (eq t fill)
 307     (setq fill edge))
 308   (xpm--w/gg (h) (xpm--gate)
 309     (let* ((v (make-vector h nil))
 310            (x-min (caar form))          ; (maybe) todo: xpm--bb
 311            (x-max x-min)
 312            (y-min (cdar form))
 313            (y-max y-min)
 314            (use-in-map (not xpm-raster-inhibit-continuity-optimization))
 315            ;; These are bool-vectors to keep track of both internal
 316            ;; (filled and its "next" (double-buffering)) and external
 317            ;; state, on a line-by-line basis.
 318            int nin
 319            ext)
 320       (cl-loop
 321        for (x . y) in form
 322        do (setq x-min (min x-min x)
 323                 x-max (max x-max x)
 324                 y-min (min y-min y)
 325                 y-max (max y-max y))
 326        unless (or (> 0 y)
 327                   (<= h y))
 328        do (push x (aref v y)))
 329       (cl-flet
 330           ((span (lo hi)
 331                  (- hi lo -1))
 332            (norm (n)
 333                  (- n x-min))
 334            (rset (bv start len value)
 335                  (cl-loop
 336                   for i from start repeat len
 337                   do (aset bv i value)))
 338            (scan (bv start len yes no)
 339                  (cl-loop
 340                   for i from start repeat len
 341                   when (aref bv i)
 342                   return yes
 343                   finally return no)))
 344         (let ((len (span x-min x-max)))
 345           (setq int (make-bool-vector len nil)
 346                 nin (make-bool-vector len nil)
 347                 ext (make-bool-vector len t)))
 348         (cl-loop
 349          with (ls
 350                in-map-ok
 351                in-map)
 352          for y from (1- y-min) to y-max
 353          when (setq ls (and (< -1 y)
 354                             (> h y)
 355                             (sort (aref v y) '>)))
 356          do (cl-loop
 357              with acc = (list (car ls))
 358              for maybe in (cdr ls)
 359              do (let* ((was (car acc))
 360                        (already (consp was)))
 361                   (cond ((/= (1- (if already
 362                                      (car was)
 363                                    was))
 364                              maybe)
 365                          (push maybe acc))
 366                         (already
 367                          (setcar was maybe))
 368                         (t
 369                          (setcar acc (cons maybe was)))))
 370              finally do
 371              (when fill
 372                (let ((was (length in-map))
 373                      (now (length acc)))
 374                  (unless (setq in-map-ok
 375                                (and (= was now)
 376                                     ;; heuristic: Avoid being fooled
 377                                     ;; by simulataneous crossings.
 378                                     (cl-evenp was)))
 379                    (setq in-map (make-bool-vector now nil)))))
 380              finally do
 381              (cl-loop
 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                        (cl-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                            (cl-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