cgit.sxemacs.org Git - packages/blob - xemacs-packages/xlib/lisp/xlib-xpm.el

   1 ;;; xlib-xpm.el --- XPM library for Xlib.
   2
   3 ;; Copyright (C) 2003-2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created: Fri Nov 28 01:28:18 MSK 2003
   7 ;; Keywords: xlib, xwem
   8 ;; X-CVS: $Id: xlib-xpm.el,v 1.7 2005-04-04 19:55:30 lg Exp $
   9
  10 ;; This file is part of XWEM.
  11
  12 ;; XWEM is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  18 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  19 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  20 ;; License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  25 ;; 02111-1307, USA.
  26
  27 ;;; Synched up with: Not in FSF
  28
  29 ;;; Commentary:
  30
  31 ;; Almost everything is hack here.
  32
  33 ;;; TODO:
  34 ;;
  35 ;;   * Rewrite.
  36
  37 ;;; Code:
  38 \f
  39 (require 'xlib-img)
  40
  41 (defvar X:xpm-color-symbols nil
  42   "Same as `xpm-color-symbols', but for xlib.")
  43
  44 \f
  45 (defun X:xpm-num-colors ()
  46   "Return number of colors in xpm."
  47   (save-excursion
  48     (goto-char (point-min))
  49     (if (re-search-forward
  50          "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
  51          (point-max) t)
  52         (string-to-int (match-string 3))
  53       (error "Unable to parse xpm information"))))
  54
  55 (defun X:xpm-goto-color-def (def)
  56   "Move to color DEF in the xpm header."
  57   (goto-char (point-min))
  58   (re-search-forward "[ \t]*\"")
  59   (forward-line 1)
  60   (re-search-forward "[ \t]*\"")
  61   (forward-line def))
  62
  63 (defun X:xpm-goto-body-line (line &optional num-colors)
  64   "Move to LINE lines down from the start of the body of an xpm."
  65   (X:xpm-goto-color-def (or num-colors (X:xpm-num-colors)))
  66   (forward-line line))
  67
  68 (defun X:xpm-chars-per-pixel ()
  69   "Return number of chars per pixel."
  70   (save-excursion
  71     (goto-char (point-min))
  72     (if (re-search-forward
  73          "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
  74          (point-max) t)
  75         (string-to-int (match-string 4))
  76       (error "Unable to parse xpm."))))
  77
  78 (defun X:xpm-get-symcolor (symc-name &optional tag-set)
  79   "Get SYMC-NAME color from `X:xpm-color-symbols' list.
  80 TAGS-SET is a list of tags, directly passed to `specifier-spec-list'."
  81   (let ((xcs X:xpm-color-symbols))
  82     (while (and xcs (not (string= (caar xcs) symc-name)))
  83       (setq xcs (cdr xcs)))
  84     (when xcs
  85       (setq xcs (cadr xcs))
  86       (cond ((stringp xcs) xcs)
  87             ((specifierp xcs)
  88              (let ((sspec (specifier-spec-list xcs nil tag-set t)))
  89                (cdr (car (cdr (car sspec))))))
  90             (t (error "Invalid element in `X:xpm-color-symbols'"))))))
  91
  92 (defun X:xpm-parse-color (chars-per-pixel &optional tag-set)
  93   "Parse xpm color string from current line and set the color.
  94 CHARS-PER-PIXEL specifies color depth.
  95 TAG-SET specifies tag-set to use in order to resolve symbolic color name."
  96   (save-excursion
  97     (beginning-of-line)
  98     (if (re-search-forward
  99          ;; Generate a regexp on the fly
 100          (concat "\"\\(" (make-string chars-per-pixel ?.) "\\)" ; chars
 101                  "\\(\\s-+[sm]\\s-+\\(\\S-*\\)\\)*" ; s and m classes
 102                  "\\s-+\\([c]\\)"       ; c class
 103                  "\\s-+\\([^ \t\"]+\\)")
 104          (point-at-eol) t)
 105         (list (match-string 1)
 106               (or (and (match-string 3) (X:xpm-get-symcolor (match-string 3) tag-set))
 107                   (match-string 5)))
 108       (error "Unable to parse color"))))
 109
 110 ;;; Shapes
 111 (defun X:xpm-extract-shape-colors (xdpy &optional tag-set)
 112   "Extract colors which marked as None."
 113   (let ((xpm-chars-per-pixel (X:xpm-chars-per-pixel))
 114         (xpm-num-colors (X:xpm-num-colors))
 115         (co 0)
 116         pco nonecols)
 117
 118     ;; extract colors which need to mask
 119     (X:xpm-goto-color-def 0)
 120     (while (< co xpm-num-colors)
 121       (setq pco (X:xpm-parse-color xpm-chars-per-pixel tag-set))
 122       (when (string= "none" (downcase (cadr pco)))
 123         (setq nonecols (cons (car pco) nonecols)))
 124
 125       (setq co (1+ co))
 126       (forward-line 1))
 127     nonecols))
 128
 129 (defun X:xpm-bit-vector-to-string (bitv)
 130   "Convert bit-vector BITV to string."
 131   (let ((off 0)
 132         (coff 0)
 133         (idx 0)
 134         (str (make-string (+ (/ (length bitv) 8)
 135                              (if (not (zerop (% (length bitv) 8))) 1 0)) 0)))
 136
 137     (setq idx 0)
 138     (while (< idx (length bitv))
 139       (setq off (/ idx 8)
 140             coff (% idx 8))
 141       (aset str off
 142             (logior (aref str off) (lsh (* (aref bitv idx) #x80) (- coff))))
 143
 144       (setq idx (1+ idx)))
 145     str))
 146
 147 (defun X:xpm-parse-shape-body-line (nonec width left-pad xpad)
 148   "Parse current line to extract bits using None colors list NONEC."
 149   (let ((bitv (make-vector (+ width (- xpad (% width xpad))) 0))
 150         (bidx 0)
 151         pix col)
 152
 153     (forward-char)
 154     ;; XXX
 155     (flet ((xpm-calc-off (idx)          ; XXX offset in BITV calculator
 156                          (1- (if (< idx (- 8 left-pad))
 157                                  (- (- 8 left-pad) idx)
 158
 159                                (setq idx (+ idx left-pad))
 160                                (+ (* 8 (/ idx 8)) (- 8 (% idx 8)))))))
 161
 162       (while (< bidx width)
 163         (setq pix (buffer-substring (point) (+ (point) 1))
 164               col (member pix nonec))
 165         (aset bitv (xpm-calc-off bidx) (if col 0 1))
 166         (forward-char)
 167         (setq bidx (1+ bidx))))
 168
 169     (X:xpm-bit-vector-to-string bitv)))
 170
 171 (defun X:xpm-make-shape (xdpy &optional tag-set)
 172   "Extract shape bits.
 173 Return data for `X-XYPixmap' format."
 174   (let ((togo 0)
 175         ximg shape shape-index nonec height width
 176         left-pad)
 177     (goto-char (point-min))
 178     (save-excursion
 179       (when (re-search-forward "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
 180                                (point-max) t)
 181         (setq width (string-to-int (match-string 1)))
 182         (setq height (string-to-int (match-string 2)))))
 183
 184     (setq left-pad (% width 8))
 185
 186     (save-excursion
 187       (setq nonec (X:xpm-extract-shape-colors xdpy)))
 188
 189     (X:xpm-goto-body-line 0)
 190     ;; XXX Check for addition comment line
 191     (when (looking-at "^/\\*")
 192       (setq togo 1))
 193
 194     (setq shape (make-vector height nil))
 195     (setq shape-index 0)
 196
 197     (while (< shape-index height)
 198       (X:xpm-goto-body-line (+ shape-index togo))
 199       (aset shape shape-index
 200             (X:xpm-parse-shape-body-line nonec width left-pad (X-Dpy-bitmap-scanline-pad xdpy)))
 201
 202       (setq shape-index (1+ shape-index)))
 203
 204     ;; XXX
 205     (setq ximg (XCreateImage xdpy nil 1 X-XYBitmap left-pad shape
 206                              width height (X-Dpy-bitmap-scanline-pad xdpy) 1))
 207     ximg))
 208
 209 \f
 210 ;;; Icons
 211 (defun X:xpm-extract-colors (xdpy &optional tag-set)
 212   "Return color list."
 213   (let ((cmap (XDefaultColormap xdpy))
 214         (xpm-num-colors (X:xpm-num-colors))
 215         (xpm-chars-per-pixel (X:xpm-chars-per-pixel))
 216         (co 0)
 217         pco prgb
 218         colors)
 219
 220     (X:xpm-goto-color-def 0)
 221     (while (< co xpm-num-colors)
 222       (setq pco (X:xpm-parse-color xpm-chars-per-pixel tag-set))
 223       (setq prgb (color-instance-rgb-components
 224                   (make-color-instance (if (string= "none" (downcase (cadr pco)))
 225                                            "white"
 226                                          (cadr pco)))))
 227       (setq colors (cons
 228                     (cons (car pco)
 229                           (XAllocColor xdpy cmap
 230                                        (make-X-Color :dpy xdpy :id (X-Dpy-get-id xdpy)
 231                                                      :red (nth 0 prgb)
 232                                                      :green (nth 1 prgb)
 233                                                      :blue (nth 2 prgb))))
 234                     colors))
 235       (setq co (1+ co))
 236       (forward-line 1))
 237     colors))
 238
 239 (defun X:xpm-parse-body-line (cols)
 240   (let (pix col rlst)
 241     (while (not (eolp))
 242       (setq pix (buffer-substring (point) (+ (point) 1))
 243             col (assoc pix cols))
 244       (when (X-Color-p (cdr col))
 245         (setq rlst (cons (X-Color-id (cdr col)) rlst)))
 246       (forward-char 1))
 247     (vconcat (nreverse rlst))))
 248
 249 (defun X:xpm-make-img (xdpy &optional tag-set)
 250   "Create X-Image using current buffer."
 251   (let ((depth (XDefaultDepth xdpy))
 252         (xpm-num-colors (X:xpm-num-colors))
 253         (togo 0)
 254         xpm xpm-index height width cols
 255         data ximg)
 256     (goto-char (point-min))
 257     (save-excursion
 258       (when (re-search-forward "\"\\s-*\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-+\\([0-9]+\\)\\s-*"
 259                                (point-max) t)
 260         (setq width (string-to-int (match-string 1)))
 261         (setq height (string-to-int (match-string 2)))))
 262
 263     (save-excursion
 264       (setq cols (X:xpm-extract-colors xdpy tag-set)))
 265
 266     (X:xpm-goto-body-line 0 xpm-num-colors)
 267     ;; Check for additional comment
 268     (when (looking-at "^/\\*")
 269       (setq togo 1))
 270
 271     (setq xpm (make-vector height nil))
 272     (setq xpm-index 0)
 273
 274     (while (< xpm-index height)
 275       (X:xpm-goto-body-line (+ xpm-index togo) xpm-num-colors)
 276       (aset xpm xpm-index
 277             (X:xpm-parse-body-line cols))
 278
 279       (setq xpm-index (1+ xpm-index)))
 280
 281     (setq data (mapvector #'(lambda (row)
 282                               (X-formatpad xdpy depth
 283                                            (apply 'concat
 284                                                   (mapcar #'(lambda (col)
 285                                                               (X-formatint xdpy depth col))
 286                                                           row))))
 287                           xpm))
 288     ;; XXX
 289     (setq ximg (XCreateImage xdpy nil depth X-ZPixmap 0 data
 290                              width height (X-Dpy-bitmap-scanline-pad xdpy) 1))
 291     ximg))
 292
 293 (defun X:xpm-img-from-data (xdpy data &optional shape tag-set)
 294   (with-temp-buffer
 295     (insert data)
 296     (if shape
 297         (X:xpm-make-shape xdpy tag-set)
 298       (X:xpm-make-img xdpy tag-set))))
 299
 300 (defun X:xpm-img-from-file (xdpy file &optional shape tag-set)
 301   (with-temp-buffer
 302     (insert-file-contents-literally file)
 303     (if shape
 304         (X:xpm-make-shape xdpy tag-set)
 305       (X:xpm-make-img xdpy tag-set))))
 306
 307 ;; Pixmap manipulations
 308 (defun X:xpm-make-pixmap-from-ximg (xdpy d ximg)
 309   "On display XDPY and drawable D, create X-Pixmap using X-Image XIMG."
 310   (let (pixmap gc)
 311     (setq pixmap (XCreatePixmap xdpy (make-X-Pixmap :dpy xdpy :id (X-Dpy-get-id xdpy))
 312                                 d (X-Image-depth ximg) (X-Image-width ximg) (X-Image-height ximg)))
 313
 314     (setq gc (XCreateGC xdpy pixmap
 315                         (make-X-Gc :dpy xdpy :id (X-Dpy-get-id xdpy)
 316                                    :foreground 1.0
 317                                    :background 0.0)))
 318
 319     (XImagePut xdpy gc pixmap 0 0 ximg)
 320     (XFreeGC xdpy gc)
 321
 322     ;; Store initial X-Image XIMG in pixmap's properties list
 323     (X-Pixmap-put-prop pixmap 'ximg ximg)
 324     pixmap))
 325
 326 (defun X:xpm-pixmap-from-data (xdpy d data &optional shape tag-set)
 327   "On display XDPY and drawable D create X-Pixmap from DATA."
 328   (X:xpm-make-pixmap-from-ximg xdpy d (X:xpm-img-from-data xdpy data shape tag-set)))
 329
 330 (defun X:xpm-pixmap-from-file (xdpy d file &optional shape tag-set)
 331   "On display XDPY and drawable D create X-Pixmap from FILE."
 332   (X:xpm-make-pixmap-from-ximg xdpy d (X:xpm-img-from-file xdpy file shape tag-set)))
 333
 334
 335 ;;; Scaling:
 336 ;;
 337 ;; * bicubic interpolation
 338 (defsubst X:xpm-func-P (x)
 339   (if (> x 0) (float x) 0.0))
 340
 341 (defsubst X:xpm-func-R (x)
 342   (/ (+ (X:xpm-func-P (expt (+ x 2) 3)) (- (* 4  (X:xpm-func-P (expt (+ x 1) 3))))
 343         (* 6.0 (X:xpm-func-P (expt x 3))) (- (* 4 (X:xpm-func-P (expt (- x 1) 3)))))
 344      6))
 345
 346 (defun X:xpm-get-color-component-at (xdpy img x y component)
 347   (when (< x 0)
 348     (setq x 0))
 349   (when (< y 0)
 350     (setq y 0))
 351   (when (>= y (length img))
 352     (setq y (1- (length img))))
 353   (when (>= x (length (nth 0 img)))
 354     (setq x (1- (length (nth 0 img)))))
 355
 356   (let ((col (aref (nth y img) x)))
 357     (nth (cond ((eq component 'red) 0)
 358                ((eq component 'green) 1)
 359                ((eq component 'blue) 2)
 360                (t 0))
 361          (caar (last (XQueryColors xdpy (XDefaultColormap xdpy) (list col)))))))
 362
 363 (defun X:xpm-func-F (xdpy img factors i j)
 364   ;; TODO: calculate dx, dy
 365   (let* ((x (* i (car factors)))
 366          (y (* j (cdr factors)))
 367          (dx (- x i))
 368          (dy (- y i)))
 369
 370     (vconcat (mapcar (lambda (comp)
 371                        (round (apply '+
 372                                      (mapcar (lambda (m)
 373                                                (apply '+
 374                                                       (mapcar (lambda (n)
 375                                                                 (* (X:xpm-get-color-component-at xdpy img (+ i m) (+ j n) comp)
 376                                                                    (X:xpm-func-R (- dx m))
 377                                                                    (X:xpm-func-R (- dy n))))
 378                                                               '(-1 0 1 2))))
 379                                              '(-1 0 1 2)))))
 380                      '(red green blue)))
 381     ))
 382
 383 \f
 384 (provide 'xlib-xpm)
 385
 386 ;;; xlib-xpm.el ends here