;;; xpm.el --- Convert XPM images

;; Copyright (C) 2002 Free Software Foundation, Inc.

;; Author: Oliver Scholz <alkibiades@gmx.de>
;; Keywords: multimedia

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; This package provides functions to deal with XPM-images if Emacs is
;; compiled without XPM-support on the C-level.

;; The main function is `xpm-create-image'.  It returns an image
;; descriptor, similar to `create-image'.

;; This aims to implement XPM version 3.  There might be some issues
;; with earlier versions of the XPM format.  But I could not find a
;; specification for them.

;; Internally this package converts the XPM data to the PPM
;; format.  But this is not the whole story.  The function
;; `xpm-create-image' returns an image descriptor as functions like
;; `insert-image' use it.  This descriptor contains the image data in
;; PPM format as the value for the :data property.  Unlike PPM, XPM
;; allows for a transparent "colour". `xpm-create-image' deals with
;; this by choosing a unoccupied colour for the affected pixels and
;; setting the :mask property in the image descriptor accordingly.

;; Some short and vague notes about the image formats involved:

;; XPM is a textual format.  It was invented to provide icons and
;; images on widgets for the X Windowing System.  The syntax of the
;; format is C-like. (I guess it is possible to cut&paste an XPM file
;; as it is into C-code, but not knowing C I am not sure about
;; this. -- O.S.) In the header section of the XPM colours are
;; assigned to sequences of one or more ascii characters.  The actual
;; pixmap is defined by listing those characters row by row.  This
;; makes XPM potentially human readable, because if the image is small
;; enough and if the characters are well chosen with regard to shades
;; of gray, the XPM source looks like an ascii art graphic of the
;; specified image.  Ignoring syntax, the XPM format consists of three
;; major parts: 1. a declaration of the width, height, number of
;; colours and of the lenght of the sequence of chars used to specify
;; a colour in the pixmap -- all of them in that orders as decimal
;; numbers in a single string. 2. the mapping of characters or
;; character sequences to colours -- in several strings, one for each
;; colour. 3. the pixmap itself -- one string for each row.  Besides
;; being textual and possibly human readable, one main advantage of
;; XPM is that the format allows to assign colours differently to
;; characters or character sequences for colour, grayscale and mono
;; displays.  Thus one single XPM source may provide a colour,
;; grayscale or black&white image.  This package aims to implement
;; this transparently by choosing the right colour assignment for the
;; current display type.

;; PPM is a part of a family of image formats, sometimes altogether
;; called "PNM".  Together with its sister formats it was invented as
;; an _intermediate_ image format for image conversion with command
;; line tools like netpbm or pbmplus.  The main advantage of each of
;; these formats is simplicity.  Each PNM format comes in two versions:
;; a binary one and a textual one.  For completeness here is a table of
;; the PNM formats:

;; Format  Type          Magic Number (Textual)  Magic Number (Binary)
;;
;; PBM     black&white   P1                      P4
;; PGN     grayscale     P2                      P5
;; PPM     colour        P3                      P6

;; This package employs PPM in the binary format (P6).  For simplicity
;; it does so even if it converts the XPM for a mono or grayscale
;; display.  Each PNM file consists of the following parts, each of
;; them is separated by whitespace: the magic number, the width of the
;; image in pixels, the height of the image in pixels, the maximum
;; value per colour component, and the actual pixmap specification
;; itself (depending on the format).  The binary format of PPM
;; specifies the pixmap as a sequence of bytes.  Each three bytes
;; specifiy the red, green and blue value of a pixel's colour
;; respectively.

;;; Code:
(require 'state-m)

;;; When parsing the header of the XPM, we put the colours as RGB
;;; values appropriate for the current display type into a hash table.

(defun xpm-colour-values (colour)
  "Return the RGB-value of COLOUR as a list of three integers.
The integers range from 0 to 255.  COLOUR is a string, either the name
of a colour as used by the X windowing system (\"Firebrick\") or a
HTML-type colour specification \(\"#002f5d\")."
  ;; The function `colour-values' returns a list of RGB values up to
  ;; 65535, resulting in 2.815e+14 possible colours.  It is -- I assume
  ;; -- possible to support that many colours using the ascii format
  ;; for PPM (magic number "P3") rather than the binary format (magic
  ;; number "P6"), as we do in this library.  The binary format uses
  ;; one byte per RGB-colour-value, resulting in 16.777.216 possible
  ;; colours, which should be enough for a fall-back like this
  ;; package.
  (let ((col (mapcar (lambda (c) (truncate (/ c 256))) (color-values colour))))
    ;; We preserve pure black for transparency.  Maybe this is too ugly
    ;; a kludge? The Right Thing (tm) would be to find an unused
    ;; colour in the colour hash to denote transparent pixels.  But
    ;; OTOH this approach is much simpler and I doubt that any human
    ;; being's eyes could see the difference between #000000 and
    ;; #000001.
    (if (equal col '(0 0 0))
	'(0 0 1)
      col)))

(defun xpm-read-string ()
  "Read the next string in the current buffer.
Thereby skipping any leading garbage as well as strings within a
comment or escaped quotation marks."
  (run-state-machine ()
    (start (?\\ nil t skip-next-char-1)
	   (?/ nil t commentary?)
	   (?\" nil t read-string)
	   (t nil t start))
    ;; If the last char was a `\', we simply skip the next char in
    ;; order to deal with escape sequences.  Then we proceed looking
    ;; for a string.
    (skip-next-char-1 (t nil t start))
    ;; If the char before was a `/' we are possibly at the start of a
    ;; commentary.
    (commentary? (?* nil t skip-commentary)
		 (t nil t start))
    ;; Skip a commentary.
    (skip-commentary (?\\ nil t skip-next-char-2)
		     (?* nil t end-of-commentary?)
		     (t nil t skip-commentary))
    ;; Skip an escaped char.
    (skip-next-char-2 (t nil t skip-commentary))
    ;; If the last char was a `*', this could be the end of the
    ;; commentary section.
    (end-of-commentary? (?/ nil t start)
			(?* nil t end-of-commentary?)
			(t nil t skip-commentary))
    ;; Read a string.
    (read-string (?\\ nil t skip-next-char-3)
		 (?\" nil t exit)		; EXIT
		 (t t t read-string))  ; add char to the returned string
    ;; Skip an escaped char.
    (skip-next-char-3 (t t t read-string))))
	       
(defun xpm-parse-spec-string-1 (string)
  "Return XPM colour specification as an alist.
STRING is a string containing a sequence of display-type symbols and
colours.  The elements of the returned alist are cons cells whose car
is the display type symbol and whose cdr is the colour."
  (let (symb list aux1 aux2)
    (with-temp-buffer
      (insert string)
      (goto-char (point-min))
      (skip-syntax-forward "-")
      ;; We get the spec as a string in the form
      ;; SYMBOL COLOUR {SYMBOL COLOUR }
      ;; Where SYMBOL may be either "s", "c", "g" odr "m".  COLOUR
      ;; may be either a HTML-like hex value for the rgb (for
      ;; example "#01cf40") or an X colour name.  Unfortunately the
      ;; latter one may contain whitespace, so we have to be
      ;; careful: When reading COLOUR an s, c, g or m after a
      ;; whitespace character may be either a SYMBOL or the first
      ;; char of the second word of the name of the colour (for
      ;; example in "c dark slategray").
      (run-state-machine (output (push (cons symb output) list))
	;; When the state machine terminates, because it encounters
	;; the end of the buffer, the current value of `output' is the
	;; last COLOUR read.

	;; Get the first symbol.
	(get-symbol ((?c ?g ?m ?s)
		     (lambda (o i)(setq symb i) nil)
		     t get-colour-start)
		    ((?\t ?\ ) nil t get-symbol) ; Skip whitespace.
		    (t (lambda (&rest ignore)
			 (error "Could not parse colour spec: %S" string))))

	;; Start reading COLOUR: skip leading whitespace.
	(get-colour-start ((?\t ?\ ) nil t get-colour-start) ; Skip whitespace.
			  (t t t get-colour))

	;; Read COLOUR until the next whitespace char.
	(get-colour ((?\t ?\ )
		     ;; Maybe the name of the colour is finished.  Set
		     ;; `aux' to the whitespace char.
		     (lambda (o i)
		       (setq aux1 i)
		       o) ; Don't change the value of the output variable.
		     t get-colour-whitespace)
		    (t t t get-colour))

	(get-colour-whitespace ((?\t ?\ ) nil t get-colour-whitespace) ; Skip.
			       ((?c ?g ?m ?s)
				(lambda (o i) (setq aux2 i) o) t symb?)
			       ;; False alert: concatenated `output',
			       ;; aux and the input last read and
			       ;; proceed reading the colour.
			       (t
				(lambda (o i) (concat o aux1 i))
				t get-colour))

	;; The last char was either an s, c, g or m.  If the current
	;; char is a whitespace char, it was a SYMBOL, otherwise it is
	;; part of COLOUR.
	(symb? ((?\t ?\ )
		(lambda (o i)
		  ;; Push a cons cell of SYMBOL and COLOUR to `list'.
		  (push (cons symb o) list)
		  ;; Set `symb' to the new SYMBOL.
		  (setq symb aux2)
		  ;; Set `output' to nil.
		  nil)
		t get-colour-start)
	       ;; False alert: Concatenate the stuff together again
	       ;; and proceed reading COLOUR.
	       (t (lambda (o i)
		    (concat o aux1 aux2 i)) t get-colour))))
    list))

(defun xpm-parse-spec-string (string nchars)
  "Translate an XPM-colour spec to a list.
The return value is a list, whose car is a string indicating the
sequence of chars used to denote a colour in the XPM and whose cdr is
a number of pairs of XPM-keysymbols and colour-names."
  (let ((chars (substring string 0 nchars)))
    (cons chars
	  (xpm-parse-spec-string-1
	   (substring string (1+ nchars))))))

(defun xpm-display-type ()
  "Return a string indicating the current display type."
  (cond ((display-color-p) "c")
	((display-grayscale-p) "g")
	(t "m")))
      
(defun xpm-find-colour (spec &optional colour-symbols)
  "Find the appropriate colour for the current display.

SPEC is the XPM specification for a single colour as a list of strings
as returned by `xpm-parse-spec-string'.

The XPM format allows to assign different colours for different
display types to each character-sequence in the XPM pixmap
specification by using keysymbols. \"c\" stands for \"coloured
display\", \"g\" for \"grayscale\" and \"m\" for \"monochrome
display\".  The keysymbol \"s\" allows a programm to assign a colour at
runtime.

The return value is a cons cell of the string indicating the sequence
of chars used in the XPM to denote a colour and a list of integers
indicating the RGB values of the colour matching the current display
type.

The optional second argument COLOUR-SYMBOLS, if non-nil, is an alist
of symbols/colour-names as required to make use of the special symbol
`s' in the colour data of the XPM.  If SPEC defines `s' for the
colour-char and if the alist COLOUR-SYMBOLS contains a matcher for the
colour symbol following `s', the according colour is used, thus
overriding the defaults for the current display type (if any)."
  ;; First we try if there is the key-char "s" defined in the spec and
  ;; if there is a matching colour in `colour-symbols'.  Then we try
  ;; if there is a colour matching the current display-type (colour,
  ;; grayscale or b&w).  Then we try -- in this order -- "grayscale",
  ;; "colour" and "mono".
  (let* ((symb (cdr (assoc "s" spec)))
	 (colour (cdr (or (and symb (assoc symb
					   colour-symbols))
			  (assoc (xpm-display-type) spec)
			  (assoc "g" spec)
			  (assoc "c" spec)
			  (assoc "m" spec)))))
    (cons (car spec)
	  (if (string-match "None" colour)
	      ;; "None" stands for "transparent colour". 
	      ;; We use '(0 0 0) as "transparent colour".
	      '(0 0 0)
	    (xpm-colour-values colour)))))

(defun xpm-make-colour-hash (colours)
  "Create, initialize and return a hash table containing the colour-specs.
The keys are strings indicating the character-sequence used in the XPM
image to denote a colour.  Each value is a lists of three integers
specifying the RGB values.  The first argument COLOURS should be an
association list of strings/RGB-list used to initialize the hash
table.  The second argument MASK is a list of RGB-values indicating a
colour that is _not_ used in COLOURS."
  (let ((hash (make-hash-table :test 'equal)))
    (dolist (elt colours hash)
      (puthash (car elt) (cdr elt) hash))))

;; To keep things separated we use a structure as an intermediate data
;; structure between the parsing functions and the functions creating
;; an image.

;; `defstruct' generates a bunch of ugly byte-compiler warnings, so we
;; do this manually.
(defun make-xpm-pixmap (&rest keyword-args)
  "Create and return a `xpm-pixmap'.
This is a structure to store image data.  Accepted keyword-args to set
the slots listed together with their accesor functions:

:width -- `xpm-pixmap-width'
The width of the image.

:height -- `xpm-pixmap-height'
The height of the image.

:mask -- `xpm-pixmap-mask'
The colour used in the image to indicate transparency.  This is a list
of the three values for red, green and blue.

:pixmap -- `xpm-pixmap-pixmap'
The actual pixmap-data."
  (let ((keyword-list '((:width . 1) (:height . 2)
			(:mask . 3) (:pixmap . 4)))
	(vect (make-vector 5 nil)))
    (aset vect 0 'xpm-pixmap)
    (while keyword-args
      (aset vect (cdr (assq (pop keyword-args) keyword-list))
	    (pop keyword-args)))
    vect))

(defun xpm-barf-if-not-pixmap (object)
  "Signal an error, if OBJECT is not of the type `xpm-pixmap'."
  (let ((last-func (backtrace-frame 3)))
    (unless (and (vectorp object)
		 (eq (aref object 0) 'xpm-pixmap))
      (error "Function `%s' trying to access a non-xpm-pixmap object."
	     (nth 1 last-func)))))

(defun xpm-pixmap-width (pixmap)
  "Return the width of xpm-pixmap PIXMAP."
  (xpm-barf-if-not-pixmap pixmap)
  (aref pixmap 1))

(defun xpm-pixmap-height (pixmap)
  "Return the height of xpm-pixmap PIXMAP."
  (xpm-barf-if-not-pixmap pixmap)
  (aref pixmap 2))

(defun xpm-pixmap-mask (pixmap)
  "Return the mask of xpm-pixmap PIXMAP."
  (xpm-barf-if-not-pixmap pixmap)
  (aref pixmap 3))

(defun xpm-pixmap-pixmap (pixmap)
  "Return the width of xpm-pixmap PIXMAP."
  (xpm-barf-if-not-pixmap pixmap)
  (aref pixmap 4))

(defun xpm-parse-buffer (buffer &optional colour-symbols)
  "Parse a buffer containing XPM data and return a pixmap object."
  (with-current-buffer buffer
    ;; Get the general information about the XPM.  The line we are
    ;; scanning first has the following format:
    ;; " WIDTH HEIGHT NUMBER-OF-COLOURS CHARS-PER-COLOUR "
    (let* ((header (split-string (xpm-read-string)))
	   (width (string-to-number (car header)))
	   (height (string-to-number (nth 1 header)))
	   (ncolours (string-to-number (nth 2 header)))
	   (nchars (string-to-number (nth 3 header)))
	   (clist nil))
      ;; Parse the colours.
      (dotimes (ignore-me ncolours clist)
	(push (xpm-find-colour
	       (xpm-parse-spec-string (xpm-read-string) nchars)
	       colour-symbols)
	      clist))
      ;; Initialize the colour-hash.
      (let* ((colour-hash (xpm-make-colour-hash clist))
	     ;; Parse the image.
	     (pdata (xpm-parse-pixmap width height nchars colour-hash)))
	(make-xpm-pixmap 
	 :width width 
	 :height height 
	 :pixmap pdata)))))

;; This is the function consuming the most time:

(defun xpm-parse-pixmap (width height nchars colour-hash)
  "Read the section of an XPM string or file defining the pixmap.
Return an array containing integers from 0 to 255.  Each three integers
define the colour of a pixel by specifying the value for red, green
and blue respectively."
  (let ((pdata (make-vector (* width height 3) 0))
	(count-y 0) (count-x 0)	(chars-read 0)
	(pointer 0) colour cstring)
    (while (< count-y height)
      (search-forward "\"")
      (while (< count-x width)
	(while (< chars-read nchars)
	  (setq chars-read (1+ chars-read))
	  (setq cstring (concat cstring
				(char-to-string (char-after))))
	  (forward-char))
	(setq colour (gethash cstring colour-hash))
	(aset pdata pointer (car colour))
	(setq pointer (1+ pointer))
	(aset pdata pointer (car (cdr colour)))
	(setq pointer (1+ pointer))
	(aset pdata pointer (car (cdr (cdr colour))))
	(setq cstring nil
	      pointer (1+ pointer)
	      chars-read 0
	      count-x (1+ count-x)))
      (setq count-x 0
	    count-y (1+ count-y))
      (forward-char))
    pdata))

(defun xpm-pixmap-to-ppm-string (pic)
  "Return a data string for a PPM image in the P6 format.
PIC must be an xpm-pixmap object as returned by `make-xpm-pixmap'."
	 (concat "P6 "
		 (number-to-string (xpm-pixmap-width pic))
		 " "
		 (number-to-string (xpm-pixmap-height pic))
		 " 255 "
		 ;; The pixmap slot contains a vector of integers.  We
		 ;; concatenate it to a string containing binary data.
		 (xpm-pixmap-pixmap pic)))

(defun xpm-pixmap-to-image (pic &rest props)
  "Return an actual image from a pixmap object.
Optional PROPS are additional image attributes to assign to the image,
like, e.g. `:ascent center'."
  ;; If no :mask property was passed to this function, we add it
  ;; ourselves.
  (unless (plist-member props :mask)
    (push '(heuristic (0 0 0)) props)
    (push :mask props))
  (apply 'create-image
	 (xpm-pixmap-to-ppm-string pic)
	 'pbm t
	 props))

(defun xpm-strip-props (props)
  "Strip property list PROPS.
If `xpm-create-image' was called by `find-image' or `create-image' the
property list may contain specifactions for :file, :data or :type,
which have become superfloous."
  (let ((prop-list (copy-sequence props))
	elt
	list)
    (while prop-list
      (setq elt (pop prop-list))
      (if (memq elt '(:file :data :type))
	  ;; Remove the value, too.
	  (pop prop-list)
	(push elt list)))
    (nreverse list)))

;;;###autoload
(defun xpm-create-image (file-or-data &optional data-p &rest props)
  "Create an image from XPM data.
FILE-OR-DATA is an XPM image file name or a string containing XPM
image data.  Optional DATA-P non-nil means FILE-OR-DATA is a string
containing image data.  Optional PROPS are additional image attributes
to assign to the image, like, e.g. `:mask MASK'.  Since this function
deals only with XPM images, the :type attribute is ignored.  Value is
the image created.

Internally this function converts the XPM data to the PPM format.  It
returns an image descriptor with correct :data and :mask property.
The conversion is done with Lisp functions and works even if Emacs was
compiled without proper support for XPM images."
;; Interface and docstring of this function are modeled after
;; `create-image'.
  (with-temp-buffer
    (if data-p
	(insert file-or-data)
      (insert-file-contents-literally
       (if (file-name-directory file-or-data)
	   file-or-data
	 (expand-file-name file-or-data data-directory))))
    (goto-char (point-min))
    (apply 'xpm-pixmap-to-image
	   (xpm-parse-buffer (current-buffer) (plist-get props :color-symbols))
	   (xpm-strip-props props))))

	  
(provide 'xpm)
;;; xpm.el ends here