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 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 fragment:
 192
 193  \"X  c blue\",
 194  \"Y  s border c green\",
 195
 196 you can specify PALETTE as:
 197
 198  ((?X . \"blue\") (?Y . \"s border c green\"))
 199
 200 This example presumes CPP is 1."
 201   (let ((buf (generate-new-buffer name)))
 202     (with-current-buffer buf
 203       (buffer-disable-undo)
 204       (cl-flet
 205           ((yep (s &rest args)
 206                 (insert (apply 'format s args) "\n")))
 207         (yep "/* XPM */")
 208         (yep "static char * %s[] = {" name)
 209         (yep "\"%d %d %d %d\"," width height (length palette) cpp)
 210         (cl-loop
 211          for (px . color) in palette
 212          do (yep "\"%s  %s\","
 213                  (if (characterp px)
 214                      (string px)
 215                    px)
 216                  (if (string-match " " color)
 217                      color
 218                    (concat "c " color))))
 219         (cl-loop
 220          with s = (format "%S,\n" (make-string (* cpp width) 32))
 221          repeat height
 222          do (insert s))
 223         (delete-char -2)
 224         (yep "};")
 225         (xpm-grok t)))
 226     buf))
 227
 228 (defun xpm-put-points (px x y)
 229   "Place PX at coordinate(s) (X,Y).
 230
 231 If both X and Y are vectors of length N, then place N points
 232 using the pairwise vector elements.  If one of X or Y is a vector
 233 of length N, then pair its elements with the other integer component
 234 and place N points.
 235
 236 If one of X or Y is a pair (LOW . HIGH), take it to be equivalent
 237 to specfiying a vector [LOW ... HIGH].  For example, (3 . 8) is
 238 equivalent to [3 4 5 6 7 8].  If one component is a pair, the
 239 other must be an integer -- the case where both X and Y are pairs
 240 is not supported.
 241
 242 Silently ignore out-of-range coordinates."
 243   (xpm--w/gg (w h cpp origin y-mult) (xpm--gate)
 244     (when (and (stringp px) (= 1 cpp))
 245       (setq px (aref px 0)))
 246     (cl-flet*
 247         ((out (col row)
 248               (or (> 0 col) (<= w col)
 249                   (> 0 row) (<= h row)))
 250          (pos (col row)
 251               (goto-char (+ origin (* cpp col) (* y-mult row))))
 252          (jam (col row len)
 253               (pos col row)
 254               (insert-char px len)
 255               (delete-char len))
 256          (rep (col row len)
 257               (pos col row)
 258               (if (= 1 cpp)
 259                   (insert-char px len)
 260                 (cl-loop
 261                  repeat len
 262                  do (insert px)))
 263               (delete-char (* cpp len)))
 264          (zow (col row)
 265               (unless (out col row)
 266                 (rep col row 1))))
 267       (pcase (cons (type-of x) (type-of y))
 268         (`(cons . integer)    (let* ((beg (max 0 (car x)))
 269                                      (end (min (1- w) (cdr x)))
 270                                      (len (- end beg -1)))
 271                                 (unless (or (> 1 len)
 272                                             (out beg y))
 273                                   (if (< 1 cpp)
 274                                       ;; general
 275                                       (rep beg y len)
 276                                     ;; fast(er) path
 277                                     (when (stringp px)
 278                                       (setq px (aref px 0)))
 279                                     (jam beg y len)))))
 280         (`(integer . cons)    (cl-loop
 281                                for two from (car y) to (cdr y)
 282                                do (zow x two)))
 283         (`(vector . integer)  (cl-loop
 284                                for one across x
 285                                do (zow one y)))
 286         (`(integer . vector)  (cl-loop
 287                                for two across y
 288                                do (zow x two)))
 289         (`(vector . vector)   (cl-loop
 290                                for one across x
 291                                for two across y
 292                                do (zow one two)))
 293         (`(integer . integer) (zow x y))
 294         (_ (error "Bad coordinates: X %S, Y %S"
 295                   x y))))))
 296
 297 (defun xpm-raster (form edge &optional fill)
 298   "Rasterize FORM with EDGE pixel (character or string).
 299 FORM is a list of coordinates that comprise a closed shape.
 300 Optional arg FILL specifies a fill pixel, or t to fill with EDGE.
 301
 302 If FORM is not closed or has inopportune vertical-facing
 303 concavities, filling might give bad results.  For those cases,
 304 see variable `xpm-raster-inhibit-continuity-optimization'."
 305   (when (eq t fill)
 306     (setq fill edge))
 307   (xpm--w/gg (h) (xpm--gate)
 308     (let* ((v (make-vector h nil))
 309            (x-min (caar form))          ; (maybe) todo: xpm--bb
 310            (x-max x-min)
 311            (y-min (cdar form))
 312            (y-max y-min)
 313            (use-in-map (not xpm-raster-inhibit-continuity-optimization))
 314            ;; These are bool-vectors to keep track of both internal
 315            ;; (filled and its "next" (double-buffering)) and external
 316            ;; state, on a line-by-line basis.
 317            int nin
 318            ext)
 319       (cl-loop
 320        for (x . y) in form
 321        do (setq x-min (min x-min x)
 322                 x-max (max x-max x)
 323                 y-min (min y-min y)
 324                 y-max (max y-max y))
 325        unless (or (> 0 y)
 326                   (<= h y))
 327        do (push x (aref v y)))
 328       (cl-flet
 329           ((span (lo hi)
 330                  (- hi lo -1))
 331            (norm (n)
 332                  (- n x-min))
 333            (rset (bv start len value)
 334                  (cl-loop
 335                   for i from start repeat len
 336                   do (aset bv i value)))
 337            (scan (bv start len yes no)
 338                  (cl-loop
 339                   for i from start repeat len
 340                   when (aref bv i)
 341                   return yes
 342                   finally return no)))
 343         (let ((len (span x-min x-max)))
 344           (setq int (make-bool-vector len nil)
 345                 nin (make-bool-vector len nil)
 346                 ext (make-bool-vector len t)))
 347         (cl-loop
 348          with (ls
 349                in-map-ok
 350                in-map)
 351          for y from (1- y-min) to y-max
 352          when (setq ls (and (< -1 y)
 353                             (> h y)
 354                             (sort (aref v y) '>)))
 355          do (cl-loop
 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               with (x rangep beg nx end len nb in)
 382               for gap from 0
 383               while acc
 384               do (setq x (pop acc))
 385               do (xpm-put-points edge x y)
 386               do (when fill
 387                    (setq rangep (consp x))
 388                    (when (zerop gap)
 389                      (rset ext 0 (norm (if rangep
 390                                            (car x)
 391                                          x))
 392                            t))
 393                    (if rangep
 394                        (destructuring-bind (b . e) x
 395                          (rset ext (norm b) (span b e) nil))
 396                      (aset ext (norm x) nil))
 397                    (when acc
 398                      (setq beg (1+ (if rangep
 399                                        (cdr x)
 400                                      x))
 401                            nx (car acc)
 402                            end (1- (if (consp nx)
 403                                        (car nx)
 404                                      nx))
 405                            len (span beg end)
 406                            nb (norm beg)
 407                            in (cond ((and use-in-map in-map-ok)
 408                                      (aref in-map gap))
 409                                     (in (scan int nb len t nil))
 410                                     (t (scan ext nb len nil t))))
 411                      (unless in-map-ok
 412                        (aset in-map gap in))
 413                      (if (not in)
 414                          (rset ext nb len t)
 415                        (rset nin nb len t)
 416                        (xpm-put-points fill (cons beg end) y))))
 417               finally do (when fill
 418                            (rotatef int nin)
 419                            (fillarray nin nil)))))))))
 420
 421 (defun xpm-as-xpm (&rest props)
 422   "Return the XPM image (via `create-image') of the buffer.
 423 PROPS are additional image properties to place on
 424 the new XPM.  See info node `(elisp) XPM Images'."
 425   (apply 'create-image (buffer-substring-no-properties
 426                         (point-min) (point-max))
 427          'xpm t props))
 428
 429 (defun xpm-finish (&rest props)
 430   "Like `xpm-as-xpm', but also kill the buffer afterwards."
 431   (prog1 (apply 'xpm-as-xpm props)
 432     (kill-buffer nil)))
 433
 434 (provide 'xpm)
 435
 436 ;;; xpm.el ends here