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

   1 ;;; xlib-img.el --- Imaging for Xlib.
   2
   3 ;; Copyright (C) 2003-2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created: Fri Dec 12 11:22:19 MSK 2003
   7 ;; Keywords: xlib, xwem
   8 ;; X-CVS: $Id: xlib-img.el,v 1.5 2005-04-04 19:55:28 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 ;; Introduces new data type X-Image.
  32
  33 ;;; Code:
  34 \f
  35 (require 'xlib-xlib)
  36
  37 (defstruct (X-Image (:predicate X-Image-isimage-p))
  38   width
  39   height
  40   xoffset
  41   format                                ; X-XYPixmap X-XYBitmap or X-ZPixmap
  42   data                                  ; data string
  43   byte-order
  44   bitmap-scanline-unit
  45   bitmap-bit-order
  46   bitmap-scanline-pad
  47   depth                                 ; depth of image
  48   bytes-per-line
  49   bits-per-pixel
  50   (red-mask 0)
  51   (green-mask 0)
  52   (blue-mask 0)
  53
  54   ;; functions
  55   create-image
  56   get-pixel
  57   put-pixel
  58   add-pixel
  59   destroy-image
  60
  61   plist)                                ; user defined plist
  62
  63 ;; Plist ops
  64 (defsubst X-Image-put-prop (ximg prop val)
  65   (setf (X-Image-plist ximg)
  66         (plist-put (X-Image-plist ximg) prop val)))
  67 (put 'X-Image-put-prop 'lisp-indent-function 2)
  68 (defsubst X-Image-get-prop (ximg prop)
  69   (plist-get (X-Image-plist ximg) prop))
  70 (defsubst X-Image-rem-prop (ximg prop)
  71   (setf (X-Image-plist ximg)
  72         (plist-remprop (X-Image-plist ximg) prop)))
  73
  74 (defconst X:X-low-bits-table
  75   (vconcat (mapcar (lambda (el)
  76                      (- (Xmask el) 1))
  77                    '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31))))
  78
  79 \f
  80 ;;; Functions
  81 (defun X:XReverse-bytes (bp n)
  82   )
  83
  84 (defun X:-xynormalizeimagebits (bp img)
  85   ;; TODO:
  86   ;;   * write me
  87   (unless (= (X-Image-byte-order img) (X-Image-bitmap-bit-order img))
  88     (cond ((= (X-Image-bitmap-scanline-unit img) 16)
  89            )
  90
  91           ((= (X-Image-bitmap-scanline-unit img) 32)
  92            )
  93           ))
  94
  95   (when (= (X-Image-bitmap-bit-order img) X-MSBFirst)
  96     (X:XReverse-bytes bp (lsh (X-Image-bitmap-scanline-unit img) -3))))
  97
  98
  99 (defun X:-znormalizeimagebits (bp img)
 100   ;; TODO:
 101   ;;   * write me
 102   (let ((bpp (X-Image-bits-per-pixel img)))
 103     (cond ((= bpp 4)
 104            )
 105           ((= bpp 16)
 106            )
 107           ((= bpp 24)
 108            )
 109           ((= bpp 32)
 110            ))))
 111
 112 (defun X:XImageXYNormalize (bp img)
 113   (when (or (= (X-Image-byte-order img) X-MSBFirst)
 114             (= (X-Image-bitmap-bit-order img) X-MSBFirst))
 115     (X:-xynormalizeimagebits bp img)))
 116
 117 (defun X:XImageZNormalize (bp img)
 118   (when (= (X-Image-byte-order img) X-MSBFirst)
 119     (X:-znormalizeimagebits bp img)))
 120
 121 (defun X:XGetPixel (img x y)
 122   "Return pixel of X-Image IMG at X and Y."
 123   (cond ((= (logior (X-Image-bits-per-pixel img) (X-Image-depth img)) 1)
 124
 125          )))
 126
 127 (defun X:XGetBitsPerPixel (xdpy depth)
 128   "Return bits per pixel value."
 129   (let ((formats (X-Dpy-formats xdpy)))
 130
 131     (while (and formats (not (= (X-ScreenFormat-depth (car formats)) depth)))
 132       (setq formats (cdr formats)))
 133
 134     (if formats
 135         (X-ScreenFormat-bits-per-pixel (car formats))
 136
 137       (cond ((<= depth 4) 4)
 138             ((<= depth 8) 8)
 139             ((<= depth 16) 16)
 140             (t 32)))))
 141
 142 (defun X:XRoundUpBits (nbytes pad)
 143   (/ (+ nbytes (- pad 1)) (* pad (lsh pad -3))))
 144
 145 (defun X:XInitImageFuncs (img)
 146   "Initilize functions for IMG."
 147   (setf (X-Image-create-image img) 'XCreateImage)
 148   (setf (X-Image-destroy-image img) 'XDestroyImage)
 149   (setf (X-Image-add-pixel img) 'X:XAddPixel)
 150
 151   (let ((fmt (X-Image-format img)))
 152     (cond ((and (= fmt X-ZPixmap) (= (X-Image-bits-per-pixel img) 8))
 153            (setf (X-Image-get-pixel img) 'X:XGetPixel8)
 154            (setf (X-Image-put-pixel img) 'X:XPutPixel8))
 155
 156           ((and (= (logior (X-Image-bits-per-pixel img) (X-Image-depth img)) 1)
 157                 (= (X-Image-byte-order img) (X-Image-bitmap-bit-order img)))
 158            (setf (X-Image-get-pixel img) 'X:XGetPixel1)
 159            (setf (X-Image-put-pixel img) 'X:XPutPixel1))
 160
 161           ((and (= fmt X-ZPixmap) (= (X-Image-bits-per-pixel img) 32))
 162            (setf (X-Image-get-pixel img) 'X:XGetPixel32)
 163            (setf (X-Image-put-pixel img) 'X:XPutPixel32))
 164
 165           ((and (= fmt X-ZPixmap) (= (X-Image-bits-per-pixel img) 16))
 166            (setf (X-Image-get-pixel img) 'X:XGetPixel16)
 167            (setf (X-Image-put-pixel img) 'X:XPutPixel16))
 168
 169           (t (setf (X-Image-get-pixel img) 'X:XGetPixel)
 170              (setf (X-Image-put-pixel img) 'X:XPutPixel)))
 171     img))
 172
 173 (defun XCreateImage (xdpy visual depth format offset data width height xpad image-bytes-per-line)
 174   "Create new image."
 175   (let (img)
 176     (if (or (= depth 0)
 177             (> depth 32)
 178             (not (memq format (list X-XYBitmap X-XYPixmap X-ZPixmap)))
 179             (and (= format X-XYBitmap) (not (= depth 1)))
 180             (not (memq xpad '(8 16 32)))
 181             (< offset 0)
 182             (< image-bytes-per-line 0))
 183         nil                             ; invalid parameter
 184
 185       (setq img (make-X-Image :width width :height height
 186                               :format format :byte-order (X-Dpy-byte-order xdpy)
 187                               :bitmap-scanline-unit (X-Dpy-bitmap-scanline-unit xdpy)
 188                               :bitmap-bit-order (X-Dpy-bitmap-bit-order xdpy)
 189                               :bitmap-scanline-pad xpad
 190                               :xoffset offset
 191                               :depth depth
 192                               :data data
 193                               ))
 194
 195       (when (X-Visual-p visual)
 196         (setf (X-Image-red-mask img) (X-Visual-red-mask visual))
 197         (setf (X-Image-green-mask img) (X-Visual-green-mask visual))
 198         (setf (X-Image-blue-mask img) (X-Visual-blue-mask visual)))
 199
 200       (if (= format X-ZPixmap)
 201           (setf (X-Image-bits-per-pixel img) (X:XGetBitsPerPixel xdpy depth))
 202
 203         ;; XXX
 204         (setf (X-Image-bits-per-pixel img) 1))
 205
 206       (if (= image-bytes-per-line 0)
 207           (if (= format X-ZPixmap)
 208               (setf (X-Image-bytes-per-line img)
 209                     (X:XRoundUpBits (* (X-Image-bits-per-pixel img) width) (X-Image-bitmap-scanline-pad img)))
 210             (setf (X-Image-bytes-per-line img)
 211                   (X:XRoundUpBits (+ width offset) (X-Image-bitmap-scanline-pad img))))
 212
 213         (setf (X-Image-bytes-per-line img) image-bytes-per-line))
 214
 215       (X:XInitImageFuncs img)
 216       img)))
 217
 218 (defun XDestroyImage (img)
 219   "Destroy image IMG."
 220   (X-invalidate-cl-struct img))
 221
 222 (defun XImageGet (xdpy d x y width height)
 223   "On display XDPY and drawable D get image with geom +X+Y+WIDTHxHEIGHT."
 224   (let* ((xdata-1 (XGetImage xdpy d x y width height X-AllPlanes X-ZPixmap))
 225          (xdata (and (car xdata-1) (nth 4 xdata-1)))
 226          (tlen (length xdata))
 227          (coff 0)
 228          tline ex-mcc ximg)
 229
 230     ;; Create data for XIMG
 231     (while (< coff tlen)
 232       (setq tline (cons (string2->number (substring xdata coff (+ coff 2))) tline))
 233       (setq coff (+ coff 2))
 234       (when (= (length tline) width)
 235         (setq ex-mcc (cons (nreverse tline) ex-mcc)
 236               tline nil)))
 237     (setq ex-mcc (nreverse ex-mcc))
 238     (setq xdata (mapcar #'(lambda (l)
 239                             (apply 'concat (mapcar 'int->string2 l)))
 240                         ex-mcc))
 241
 242     (setq ximg (XCreateImage xdpy nil (XDefaultDepth xdpy)
 243                              X-ZPixmap 0 xdata width height
 244                              (X-Dpy-bitmap-scanline-pad xdpy) 1))
 245     ;; Save pixels layout
 246     (X-Image-put-prop ximg 'px-layout ex-mcc)
 247     ximg))
 248
 249 ;; Testing (XImageGet (xwem-dpy) (xwem-cl-xwin (xwem-cl-selected)) 40 10 100 100)
 250 ;;         (XImagePut (xwem-dpy) (XDefaultGC (xwem-dpy)) (xwem-frame-xwin (nth 1 xwem-frames-list)) 30 40 ximg)
 251
 252 (defun XImagePut (xdpy gc d x y ximg)
 253   "On display XDPY and drawable D at X Y put an XIMG."
 254   (let (data left-pad)
 255     (unless (stringp (X-Image-data ximg))
 256       (setq data (mapconcat 'identity (X-Image-data ximg) "")))
 257
 258     (if (or (= (X-Image-bits-per-pixel ximg) 1)
 259             (not (= (X-Image-format ximg) X-ZPixmap)))
 260         (setq left-pad (% (X-Image-width ximg) 8))
 261       (setq left-pad 0))
 262
 263     (XPutImage xdpy d gc (X-Image-depth ximg)
 264                (X-Image-width ximg) (X-Image-height ximg) x y left-pad
 265                (X-Image-format ximg) data)))
 266
 267 \f
 268 (provide 'xlib-img)
 269
 270 ;;; xlib-img.el ends here