;;; xpm-fulmination.el
;;;
;;; Copyright (C) 2004, 2007, 2008 Thien-Thi Nguyen
;;;
;;; This file is part of ttn's personal elisp library, released under
;;; the terms of the GNU General Public License as published by the
;;; Free Software Foundation; either version 3, or (at your option) any
;;; later version.  There is NO WARRANTY.  See file COPYING for details.

;;; Description: Utilities to algorithmically create XPMs.

;;; Commentary:

;; The XPMs are restricted to one-character per color.
;; Coordinate `(X . Y)' actually means buffer position "ROW,COL",
;; where ROW is the line number minus one.  Coords are zero-based.
;;
;; This code is experimental; the interface will likely change
;; if/when two-character color specs are to be supported.

;;; Code:

;;;###autoload
(defun xpmfulm-buffer (name width height colors &optional buffer)
  "Return a buffer prepared for further fulmination.
Name is the name of the XPM, a string.  WIDTH and HEIGHT are integers.
COLORS is a list of pairs, each in the form (CHAR . \"COLOR\").
Optional arg BUFFER specifies a buffer to use for the initial contents
instead of the default (HEIGHT rows of WIDTH space characters).  The
visible contents (narrowing respected) are cropped and/or padded (right
and bottom) to fit within the specified WIDTH and HEIGHT."
  (let ((buf (generate-new-buffer "*XPM Fulmination*")))
    (with-current-buffer buf
      (erase-buffer)
      (let ((s (concat (make-string width 32) "\n"))
            (line 0)
            p q)
        (when buffer
          (with-current-buffer buffer
            (save-excursion
              (goto-char (point-min))
              (while (and (< line height) (< (point) (point-max)))
                (setq p (point)
                      q (progn (end-of-line) (min (point) (+ p width))))
                (with-current-buffer buf
                  (insert-buffer-substring-no-properties buffer p q)
                  (insert (substring s (- q p))))
                (beginning-of-line 2)
                (setq line (1+ line))))))
        (while (< line height)
          (insert s)
          (setq line (1+ line))))
      (insert (propertize ""
                          'read-only t
                          'intangible t
                          :xpmfulm-name name
                          :xpmfulm-width width
                          :xpmfulm-height height
                          :xpmfulm-colors colors)))
    buf))

(defun xpmfulm-add-color (buf color)
  "In fulmination BUF, add COLOR to list of colors.
As for `xpmfulm-buffer', COLOR is a pair in the form (CHAR . \"COLOR\")."
  (with-current-buffer buf
    (let* ((cookie (- (point-max) 3))
           (colors (get-text-property cookie :xpmfulm-colors)))
      (unless colors
        (error "Buffer %S corrupted!" (buffer-name buf)))
      (let ((inhibit-read-only t))
        (put-text-property cookie (point-max) :xpmfulm-colors
                           (cons color colors))))))

(defun xpmfulm-point (buf x y color)
  "In fulmination BUF, set point at coord X,Y to have COLOR.
Out-of-range coordinates are silently ignored."
  (unless (or (> 0 x) (> 0 y))
    (with-current-buffer buf
      (let* ((cookie (- (point-max) 3))
             (height (get-text-property cookie :xpmfulm-height))
             (width  (get-text-property cookie :xpmfulm-width)))
        (unless (or (<= height x) (<= width y))
          (goto-char (+ 1 (* x (1+ width)) y))
          (insert-char color 1)
          (delete-char 1))))))

(defun xpmfulm-raster (buf form edge &optional fill)
  "In fulmination BUF, rasterize FORM with EDGE color, a character.
FORM is a list of coordinates that comprise a closed shape.  Optional
arg FILL, a character, specifies a fill color (default value: space).
If FILL is t, it is taken to be the same as EDGE.

NOTE: Presently this function produces strange results when FORM has
      a vertically-facing concavity.  (Patches welcome.)"
  (setq fill (cond ((eq t fill) edge)
                   ((not fill) 32)
                   (t fill))
        form (sort form (lambda (a b)
                          (or (< (car a) (car b))
                              (and (= (car a) (car b))
                                   (< (cdr a) (cdr b)))))))
  (with-current-buffer buf
    (goto-char (point-min))
    (let ((line 0) cut n)
      (while (setq n 1 cut form)
        (while (and (cdr cut) (= (car (cadr cut)) (car (car form))))
          (setq cut (cdr cut)
                n (1+ n)))
        (forward-line (- (caar form) line))
        (forward-char (cdar form))
        (apply 'insert
               (make-string 1 edge)
               (mapcar (lambda (idx)
                         (let ((j (cdr (nth (1- idx) form)))
                               (k (cdr (nth idx form))))
                           (concat (make-string (- k j 1) fill)
                                   (make-string 1 edge))))
                       (number-sequence 1 (1- n))))
        (delete-char (1+ (- (cdar cut) (cdar form))))
        (setq line (caar form)
              form (cdr cut))))))

(defun xpmfulm-as-xpm (buf &rest props)
  "Return fulmination BUF converted to an image of type `xpm'.
Kill BUF in the process.  PROPS are additional image properties
to place on the new XPM."
  (with-current-buffer buf
    (let* ((cookie (- (point-max) 3))
           (name (get-text-property cookie :xpmfulm-name))
           (height (get-text-property cookie :xpmfulm-height))
           (width (get-text-property cookie :xpmfulm-width))
           (colors (get-text-property cookie :xpmfulm-colors)))
      (unless (and (string= "" (buffer-substring cookie (point-max)))
                   name height width colors)
        (error "Buffer %S corrupted!" (buffer-name buf)))
      (let ((inhibit-read-only t))
        (delete-region cookie (point-max)))
      (goto-char (point-min))
      (insert "/* XPM */\n"
              "static char * " name "_xpm[] = {\n"
              (format "\"%d %d %d 1\",\n" width height (length colors)))
      (dolist (color colors)
        (insert (format "\"%c c %s\",\n" (car color) (cdr color))))
      (while (looking-at ".+")
        (replace-match "\"\\&\",")
        (forward-line 1))
      (delete-char -2)
      (insert "};"))
    (prog1 (apply 'create-image
                  (buffer-substring (point-min) (point-max))
                  'xpm t
                  props)
      (kill-buffer nil))))

(provide 'xpm-fulmination)

;;; xpm-fulmination.el ends here