;;; xlib-xpm.el --- XPM library for Xlib.

;; Copyright (C) 2003-2005 by XWEM Org.

;; Author: Zajcev Evgeny <zevlg@yandex.ru>
;; Created: Fri Nov 28 01:28:18 MSK 2003
;; Keywords: xlib, xwem
;; X-CVS: $Id: xlib-xpm.el,v 1.7 2005-04-04 19:55:30 lg Exp $

;; This file is part of XWEM.

;; XWEM 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.

;; XWEM 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 XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:

;; Almost everything is hack here.

;;; TODO:
;;
;;   * Rewrite.

;;; Code:

(require 'xlib-img)

(defvar X:xpm-color-symbols nil
  "Same as `xpm-color-symbols', but for xlib.")


(defun X:xpm-num-colors ()
  "Return number of colors in xpm."
  (save-excursion
    (goto-char (point-min))
    (if (re-search-forward 
	 "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
	 (point-max) t)
	(string-to-int (match-string 3))
      (error "Unable to parse xpm information"))))

(defun X:xpm-goto-color-def (def)
  "Move to color DEF in the xpm header."
  (goto-char (point-min))
  (re-search-forward "[ \t]*\"")
  (forward-line 1)
  (re-search-forward "[ \t]*\"")
  (forward-line def))

(defun X:xpm-goto-body-line (line &optional num-colors)
  "Move to LINE lines down from the start of the body of an xpm."
  (X:xpm-goto-color-def (or num-colors (X:xpm-num-colors)))
  (forward-line line))

(defun X:xpm-chars-per-pixel ()
  "Return number of chars per pixel."
  (save-excursion
    (goto-char (point-min))
    (if (re-search-forward 
         "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
         (point-max) t)
        (string-to-int (match-string 4))
      (error "Unable to parse xpm."))))

(defun X:xpm-get-symcolor (symc-name &optional tag-set)
  "Get SYMC-NAME color from `X:xpm-color-symbols' list.
TAGS-SET is a list of tags, directly passed to `specifier-spec-list'."
  (let ((xcs X:xpm-color-symbols))
    (while (and xcs (not (string= (caar xcs) symc-name)))
      (setq xcs (cdr xcs)))
    (when xcs
      (setq xcs (cadr xcs))
      (cond ((stringp xcs) xcs)
            ((specifierp xcs)
             (let ((sspec (specifier-spec-list xcs nil tag-set t)))
               (cdr (car (cdr (car sspec))))))
            (t (error "Invalid element in `X:xpm-color-symbols'"))))))

(defun X:xpm-parse-color (chars-per-pixel &optional tag-set)
  "Parse xpm color string from current line and set the color.
CHARS-PER-PIXEL specifies color depth.
TAG-SET specifies tag-set to use in order to resolve symbolic color name."
  (save-excursion
    (beginning-of-line)
    (if (re-search-forward
         ;; Generate a regexp on the fly
         (concat "\"\\(" (make-string chars-per-pixel ?.) "\\)" ; chars
                 "\\(\\s-+[sm]\\s-+\\(\\S-*\\)\\)*" ; s and m classes
                 "\\s-+\\([c]\\)"       ; c class
                 "\\s-+\\([^ \t\"]+\\)")
         (point-at-eol) t)
        (list (match-string 1)
              (or (and (match-string 3) (X:xpm-get-symcolor (match-string 3) tag-set))
                  (match-string 5)))
      (error "Unable to parse color"))))

;;; Shapes
(defun X:xpm-extract-shape-colors (xdpy &optional tag-set)
  "Extract colors which marked as None."
  (let ((xpm-chars-per-pixel (X:xpm-chars-per-pixel))
        (xpm-num-colors (X:xpm-num-colors))
        (co 0)
	pco nonecols)

    ;; extract colors which need to mask
    (X:xpm-goto-color-def 0)
    (while (< co xpm-num-colors)
      (setq pco (X:xpm-parse-color xpm-chars-per-pixel tag-set))
      (when (string= "none" (downcase (cadr pco)))
	(setq nonecols (cons (car pco) nonecols)))

      (setq co (1+ co))
      (forward-line 1))
    nonecols))
  
(defun X:xpm-bit-vector-to-string (bitv)
  "Convert bit-vector BITV to string."
  (let ((off 0)
	(coff 0)
	(idx 0)
	(str (make-string (+ (/ (length bitv) 8)
			     (if (not (zerop (% (length bitv) 8))) 1 0)) 0)))

    (setq idx 0)
    (while (< idx (length bitv))
      (setq off (/ idx 8)
	    coff (% idx 8))
      (aset str off
	    (logior (aref str off) (lsh (* (aref bitv idx) #x80) (- coff))))

      (setq idx (1+ idx)))
    str))

(defun X:xpm-parse-shape-body-line (nonec width left-pad xpad)
  "Parse current line to extract bits using None colors list NONEC."
  (let ((bitv (make-vector (+ width (- xpad (% width xpad))) 0))
	(bidx 0)
	pix col)

    (forward-char)
    ;; XXX
    (flet ((xpm-calc-off (idx)		; XXX offset in BITV calculator
			 (1- (if (< idx (- 8 left-pad))
				 (- (- 8 left-pad) idx)

			       (setq idx (+ idx left-pad))
			       (+ (* 8 (/ idx 8)) (- 8 (% idx 8)))))))

      (while (< bidx width)
	(setq pix (buffer-substring (point) (+ (point) 1))
	      col (member pix nonec))
	(aset bitv (xpm-calc-off bidx) (if col 0 1))
	(forward-char)
	(setq bidx (1+ bidx))))

    (X:xpm-bit-vector-to-string bitv)))

(defun X:xpm-make-shape (xdpy &optional tag-set)
  "Extract shape bits.
Return data for `X-XYPixmap' format."
  (let ((togo 0)
	ximg shape shape-index nonec height width
	left-pad)
    (goto-char (point-min))
    (save-excursion
      (when (re-search-forward "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
			       (point-max) t)
	(setq width (string-to-int (match-string 1)))
	(setq height (string-to-int (match-string 2)))))

    (setq left-pad (% width 8))

    (save-excursion 
      (setq nonec (X:xpm-extract-shape-colors xdpy)))

    (X:xpm-goto-body-line 0)
    ;; XXX Check for addition comment line
    (when (looking-at "^/\\*")
      (setq togo 1))

    (setq shape (make-vector height nil))
    (setq shape-index 0)

    (while (< shape-index height)
      (X:xpm-goto-body-line (+ shape-index togo))
      (aset shape shape-index
	    (X:xpm-parse-shape-body-line nonec width left-pad (X-Dpy-bitmap-scanline-pad xdpy)))

      (setq shape-index (1+ shape-index)))

    ;; XXX
    (setq ximg (XCreateImage xdpy nil 1 X-XYBitmap left-pad shape
			     width height (X-Dpy-bitmap-scanline-pad xdpy) 1))
    ximg))


;;; Icons
(defun X:xpm-extract-colors (xdpy &optional tag-set)
  "Return color list."
  (let ((cmap (XDefaultColormap xdpy))
        (xpm-num-colors (X:xpm-num-colors))
        (xpm-chars-per-pixel (X:xpm-chars-per-pixel))
	(co 0)
	pco prgb
	colors)

    (X:xpm-goto-color-def 0)
    (while (< co xpm-num-colors)
      (setq pco (X:xpm-parse-color xpm-chars-per-pixel tag-set))
      (setq prgb (color-instance-rgb-components
		  (make-color-instance (if (string= "none" (downcase (cadr pco)))
					   "white"
					 (cadr pco)))))
      (setq colors (cons
		    (cons (car pco)
			  (XAllocColor xdpy cmap
				       (make-X-Color :dpy xdpy :id (X-Dpy-get-id xdpy)
						     :red (nth 0 prgb)
						     :green (nth 1 prgb)
						     :blue (nth 2 prgb))))
		    colors))
      (setq co (1+ co))
      (forward-line 1))
    colors))

(defun X:xpm-parse-body-line (cols)
  (let (pix col rlst)
    (while (not (eolp))
      (setq pix (buffer-substring (point) (+ (point) 1))
	    col (assoc pix cols))
      (when (X-Color-p (cdr col))
	(setq rlst (cons (X-Color-id (cdr col)) rlst)))
      (forward-char 1))
    (vconcat (nreverse rlst))))

(defun X:xpm-make-img (xdpy &optional tag-set)
  "Create X-Image using current buffer."
  (let ((depth (XDefaultDepth xdpy))
        (xpm-num-colors (X:xpm-num-colors))
	(togo 0)
	xpm xpm-index height width cols
	data ximg)
    (goto-char (point-min))
    (save-excursion
      (when (re-search-forward "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
			       (point-max) t)
	(setq width (string-to-int (match-string 1)))
	(setq height (string-to-int (match-string 2)))))

    (save-excursion 
      (setq cols (X:xpm-extract-colors xdpy tag-set)))

    (X:xpm-goto-body-line 0 xpm-num-colors)
    ;; Check for additional comment
    (when (looking-at "^/\\*")
      (setq togo 1))

    (setq xpm (make-vector height nil))
    (setq xpm-index 0)

    (while (< xpm-index height)
      (X:xpm-goto-body-line (+ xpm-index togo) xpm-num-colors)
      (aset xpm xpm-index
	    (X:xpm-parse-body-line cols))

      (setq xpm-index (1+ xpm-index)))

    (setq data (mapvector #'(lambda (row)
                              (X-formatpad xdpy depth
                                           (apply 'concat
                                                  (mapcar #'(lambda (col)
                                                              (X-formatint xdpy depth col))
                                                          row))))
			  xpm))
    ;; XXX
    (setq ximg (XCreateImage xdpy nil depth X-ZPixmap 0 data
			     width height (X-Dpy-bitmap-scanline-pad xdpy) 1))
    ximg))
  
(defun X:xpm-img-from-data (xdpy data &optional shape tag-set)
  (with-temp-buffer
    (insert data)
    (if shape
	(X:xpm-make-shape xdpy tag-set)
      (X:xpm-make-img xdpy tag-set))))

(defun X:xpm-img-from-file (xdpy file &optional shape tag-set)
  (with-temp-buffer
    (insert-file-contents-literally file)
    (if shape
	(X:xpm-make-shape xdpy tag-set)
      (X:xpm-make-img xdpy tag-set))))

;; Pixmap manipulations
(defun X:xpm-make-pixmap-from-ximg (xdpy d ximg)
  "On display XDPY and drawable D, create X-Pixmap using X-Image XIMG."
  (let (pixmap gc)
    (setq pixmap (XCreatePixmap xdpy (make-X-Pixmap :dpy xdpy :id (X-Dpy-get-id xdpy))
				d (X-Image-depth ximg) (X-Image-width ximg) (X-Image-height ximg)))

    (setq gc (XCreateGC xdpy pixmap
			(make-X-Gc :dpy xdpy :id (X-Dpy-get-id xdpy)
				   :foreground 1.0
				   :background 0.0)))

    (XImagePut xdpy gc pixmap 0 0 ximg)
    (XFreeGC xdpy gc)

    ;; Store initial X-Image XIMG in pixmap's properties list
    (X-Pixmap-put-prop pixmap 'ximg ximg)
    pixmap))

(defun X:xpm-pixmap-from-data (xdpy d data &optional shape tag-set)
  "On display XDPY and drawable D create X-Pixmap from DATA."
  (X:xpm-make-pixmap-from-ximg xdpy d (X:xpm-img-from-data xdpy data shape tag-set)))
  
(defun X:xpm-pixmap-from-file (xdpy d file &optional shape tag-set)
  "On display XDPY and drawable D create X-Pixmap from FILE."
  (X:xpm-make-pixmap-from-ximg xdpy d (X:xpm-img-from-file xdpy file shape tag-set)))


;;; Scaling:
;;
;; * bicubic interpolation
(defsubst X:xpm-func-P (x)
  (if (> x 0) (float x) 0.0))

(defsubst X:xpm-func-R (x)
  (/ (+ (X:xpm-func-P (expt (+ x 2) 3)) (- (* 4  (X:xpm-func-P (expt (+ x 1) 3))))
	(* 6.0 (X:xpm-func-P (expt x 3))) (- (* 4 (X:xpm-func-P (expt (- x 1) 3)))))
     6))

(defun X:xpm-get-color-component-at (xdpy img x y component)
  (when (< x 0)
    (setq x 0))
  (when (< y 0)
    (setq y 0))
  (when (>= y (length img))
    (setq y (1- (length img))))
  (when (>= x (length (nth 0 img)))
    (setq x (1- (length (nth 0 img)))))

  (let ((col (aref (nth y img) x)))
    (nth (cond ((eq component 'red) 0)
	       ((eq component 'green) 1)
	       ((eq component 'blue) 2)
	       (t 0))
	 (caar (last (XQueryColors xdpy (XDefaultColormap xdpy) (list col)))))))

(defun X:xpm-func-F (xdpy img factors i j)
  ;; TODO: calculate dx, dy
  (let* ((x (* i (car factors)))
	 (y (* j (cdr factors)))
	 (dx (- x i))
	 (dy (- y i)))

    (vconcat (mapcar (lambda (comp)
		       (round (apply '+
				     (mapcar (lambda (m)
					       (apply '+
						      (mapcar (lambda (n)
								(* (X:xpm-get-color-component-at xdpy img (+ i m) (+ j n) comp)
								   (X:xpm-func-R (- dx m))
								   (X:xpm-func-R (- dy n))))
							      '(-1 0 1 2))))
					     '(-1 0 1 2)))))
		     '(red green blue)))
    ))
     

(provide 'xlib-xpm)

;;; xlib-xpm.el ends here