chiark - git - mdw - clg/blob - gdk/pixbuf.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2004-2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: pixbuf.lisp,v 1.9 2008-12-10 03:01:34 espen Exp $
  24
  25
  26 (in-package "GDK")
  27
  28 (defbinding %pixbuf-new () pointer
  29   colorspace
  30   (has-alpha boolean)
  31   (bits-per-sample int)
  32   (width int)
  33   (height int))
  34
  35 (defbinding %pixbuf-new-from-data () pointer
  36   (data pointer)
  37   colorspace
  38   (has-alpha boolean)
  39   (bits-per-sample int)
  40   (width int)
  41   (height int)
  42   (rowstride int)
  43   (nil null)
  44   (nil null))
  45
  46 (defbinding %pixbuf-new-from-xpm-data () pointer
  47   (data (vector string)))
  48
  49 (defbinding %pixbuf-new-from-file () pointer
  50   (filename pathname)
  51   (nil (or null gerror) :out))
  52
  53 (defbinding %pixbuf-new-from-file-at-size () pointer
  54   (filename pathname)
  55   (width int)
  56   (height int)
  57   (nil (or null gerror) :out))
  58
  59 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
  60 (defbinding %pixbuf-new-from-file-at-scale () pointer
  61   (filename pathname)
  62   (width int)
  63   (height int)
  64   (preserve-aspect-ratio boolean)
  65   (nil (or null gerror) :out))
  66
  67 (defun %pixbuf-load (filename width height preserve-aspect-p)
  68   (multiple-value-bind (location gerror)
  69       (cond
  70         ((and width height)
  71          (%pixbuf-new-from-file-at-size filename width height))
  72         ((or width height)
  73          #?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
  74          (error "Both :width and :height must be specified")
  75          #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
  76          (%pixbuf-new-from-file-at-scale filename
  77           (or width -1) (or height -1) preserve-aspect-p))
  78         (t (%pixbuf-new-from-file filename)))
  79     (if gerror
  80         (signal-gerror gerror)
  81       location)))
  82
  83 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.14.0")
  84 (progn
  85   (defbinding %pixbuf-new-from-stream () pointer
  86     gio:input-stream-designator
  87     (nil (or null gio:cancellable))
  88     (nil (or null gerror) :out))
  89
  90   (defbinding %pixbuf-new-from-stream-at-scale () pointer
  91     gio:input-stream-designator
  92     (width int)
  93     (height int)
  94     (preserve-aspect-ratio boolean)
  95     (nil (or null gio:cancellable))
  96     (nil (or null gerror) :out))
  97
  98   (defun %load-from-stream (stream width height preserve-aspect-p)
  99     (multiple-value-bind (location gerror)
 100         (cond
 101           ((or width height)
 102            (%pixbuf-new-from-stream-at-scale stream
 103             (or width -1) (or height -1) preserve-aspect-p))
 104           (t (%pixbuf-new-from-stream stream)))
 105       (if gerror
 106           (signal-gerror gerror)
 107         location))))
 108
 109 (defmethod allocate-foreign ((pixbuf pixbuf) &key source (bits-per-sample 8)
 110                              (colorspace :rgb) (has-alpha t) width height
 111                              (preserve-aspect-ratio t) destroy stride)
 112   (cond
 113    ((not source)
 114     (%pixbuf-new colorspace has-alpha bits-per-sample width height))
 115    ((typep source 'pointer)
 116     ;; TODO: destory
 117     (%pixbuf-new-from-data source colorspace has-alpha bits-per-sample width height (or stride (* width (if has-alpha 4 3)))))
 118    ((and (vectorp source) (stringp (aref source 0)))
 119     (%pixbuf-new-from-xpm-data source))
 120    ((typep source 'vector)
 121
 122     )
 123    ((or (pathnamep source) (stringp source))
 124     #?-(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
 125     (unless preserve-aspect-ratio
 126       (warn ":preserve-aspect-ratio not supported with this version of Gtk"))
 127     (%pixbuf-load source width height preserve-aspect-ratio))
 128    #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.14.0")
 129    ((typep source 'gio:input-stream-designator)
 130     (%load-from-stream source width height preserve-aspect-ratio))
 131    ((call-next-method))))
 132
 133
 134 (defbinding (pixbuf-subpixbuf "gdk_pixbuf_new_subpixbuf") ()
 135     (or null (referenced pixbuf))
 136   pixbuf (src-x int) (src-y int) (width int) (height int))
 137
 138 (defbinding pixbuf-copy () (or null (referenced pixbuf))
 139   pixbuf)
 140
 141
 142 (defbinding pixbuf-get-option () (copy-of string)
 143   (pixbuf pixbuf)
 144   (key string))
 145
 146 (defun pixbuf-load (filename &key width height size (preserve-aspect-ratio t))
 147   (make-instance 'pixbuf :source filename
 148    :width (or size width) :height (or size height)
 149    :preserve-aspect-ratio preserve-aspect-ratio))
 150
 151
 152 ;; (defbinding pixbuf-get-file-info () (copy-of pixbuf-format)
 153 ;;   (filename pathname)
 154 ;;   (width int :out)
 155 ;;   (height int :out))
 156
 157 (defbinding %pixbuf-savev () boolean
 158   (pixbuf pixbuf)
 159   (filename pathname)
 160   (type string)
 161   (keys strings)
 162   (values strings)
 163   (nil (or null gerror) :out))
 164
 165 (defun %pixbuf-save-options (options)
 166   (let ((keys (make-array 0 :adjustable t :fill-pointer t))
 167         (values (make-array 0 :adjustable t :fill-pointer t)))
 168     (loop
 169      for (key value) on options by #'cddr
 170      do (vector-push-extend (string-downcase key) keys)
 171         (vector-push-extend
 172          (etypecase value
 173            (string value)
 174            (symbol (string-downcase value))
 175            (number (format nil "~A" value)))
 176          values))
 177     (values keys values)))
 178
 179 (defgeneric pixbuf-save (pixbuf dest type &rest options))
 180
 181 (defmethod pixbuf-save (pixbuf (filename string) type &rest options)
 182   (multiple-value-bind (ok-p gerror)
 183       (multiple-value-call #'%pixbuf-savev
 184        pixbuf filename (string-downcase type)
 185        (%pixbuf-save-options options))
 186     (unless ok-p
 187       (signal-gerror gerror))))
 188
 189 (defmethod pixbuf-save (pixbuf (pathname pathname) type &rest options)
 190   (apply #'pixbuf-save pixbuf (namestring (translate-logical-pathname pathname))
 191    type options))
 192
 193 (define-callback stream-write-func boolean
 194     ((data pointer) (length gsize) (gerror pointer) (stream-id pointer-data))
 195   (block stream-write
 196     (handler-case
 197         (let ((stream (find-user-data stream-id)))
 198           (write-sequence
 199            (map-c-vector 'vector 'identity data '(unsigned-byte 8) length)
 200            stream))
 201       (serious-condition (condition)
 202         (gerror-set-in-callback gerror (file-error-domain)
 203          (enum-int :failed 'file-error-enum) (princ-to-string condition))
 204         (return-from stream-write nil)))
 205     t))
 206
 207 (defbinding %pixbuf-save-to-callbackv (pixbuf stream type keys values) boolean
 208   (pixbuf pixbuf)
 209   (stream-write-func callback)
 210   (stream pointer-data)
 211   (type string)
 212   (keys strings)
 213   (values strings)
 214   (nil (or null gerror) :out))
 215
 216 (defmethod pixbuf-save (pixbuf (stream stream) type &rest options)
 217   (let ((stream-id (register-user-data stream)))
 218     (unwind-protect
 219          (multiple-value-bind (ok-p gerror)
 220              (multiple-value-call #'%pixbuf-save-to-callbackv
 221                pixbuf stream-id (string-downcase type)
 222                (%pixbuf-save-options options))
 223            (unless ok-p
 224              (signal-gerror gerror)))
 225       (destroy-user-data stream-id))))
 226
 227
 228 ;; (defbinding pixbuf-new-from-xpm-data () (referenced pixbuf)
 229 ;;   (data (vector string)))
 230
 231 (defbinding %pixbuf-new-subpixbuf () pixbuf ;; or (referenced pixbuf)?
 232   (pixbuf pixbuf)
 233   (x int) (y int) (width int) (height int))
 234
 235 (defbinding %pixbuf-copy () (referenced pixbuf)
 236   (pixbuf pixbuf))
 237
 238 (defun copy-pixbuf (pixbuf &optional x y width height)
 239   (if (and (not x) (not y) (not width) (not height))
 240       (%pixbuf-copy pixbuf)
 241     (%pixbuf-new-subpixbuf pixbuf x y width height)))
 242
 243 (defbinding %pixbuf-get-from-drawable () (or null (referenced pixbuf))
 244   (dest (or null pixbuf))
 245   (drawable drawable)
 246   (colormap (or null colormap))
 247   (src-x int)
 248   (src-y int)
 249   (dest-x int)
 250   (dest-y int)
 251   (width int)
 252   (height int))
 253
 254 (defun pixbuf-get-from-drawable (drawable &key (src-x 0) (src-y 0) (dest-x 0) (dest-y 0) width height colormap dest)
 255   (unless (or (and width height) (not (typep drawable 'window)))
 256     (error "Width and height must be specified for windows"))
 257   (or
 258    (%pixbuf-get-from-drawable dest drawable
 259     (cond
 260      (colormap)
 261      ((slot-boundp drawable 'colormap) nil)
 262      ((colormap-get-system)))
 263     src-x src-y dest-x dest-y (or width -1) (or height -1))
 264    (error "Couldn't get pixbuf from drawable")))
 265
 266
 267 ;;; Pixbuf Loader
 268
 269 (defbinding %pixbuf-loader-new-with-type () pointer
 270   (type string)
 271   (nil gerror-signal :out))
 272
 273 (defbinding %pixbuf-loader-new-with-mime-type () pointer
 274   (mime-type string)
 275   (nil gerror-signal :out))
 276
 277 (defmethod allocate-foreign ((loader pixbuf-loader) &key type mime-type)
 278   (cond
 279    ((and type mime-type)
 280     (error "Only one of the keyword arguments :TYPE and :MIME-TYPE can be specified"))
 281    (type (%pixbuf-loader-new-with-type type))
 282    (mime-type (%pixbuf-loader-new-with-mime-type mime-type))
 283    ((call-next-method))))
 284
 285 (defbinding pixbuf-loader-write (loader buffer &optional (length (length buffer))) boolean
 286   (loader pixbuf-loader)
 287   (buffer (unboxed-vector (unsigned-byte 8)))
 288   (length integer)
 289   (nil gerror-signal :out))
 290
 291 (defbinding pixbuf-loader-close () boolean
 292   (loader pixbuf-loader)
 293   (nil gerror-signal :out))
 294
 295 (defbinding pixbuf-loader-get-pixbuf () (or null pixbuf)
 296   (loader pixbuf-loader))
 297
 298 (defbinding pixbuf-loader-get-animation () (or null pixbuf-animation)
 299   (loader pixbuf-loader))
 300
 301 (defbinding pixbuf-loader-set-size () nil
 302   (loader pixbuf-loader)
 303   (width integer)
 304   (height integer))
 305
 306
 307 ;;; Utilities
 308
 309 (defbinding pixbuf-add-alpha
 310     (pixbuf &optional substitute-color (red 255) (green 255) (blue 255))
 311     (referenced pixbuf)
 312   (pixbuf pixbuf)
 313   (substitute-color boolean)
 314   (red (unsigned 8))
 315   (green (unsigned 8))
 316   (blue (unsigned 8)))
 317
 318 ;; The purpose of this function is to be able to share pixel data
 319 ;; between GdkPixbufs and Cairo image surfaces.
 320 #+nil
 321 (defun pixbuf-swap-rgb (pixbuf)
 322   (assert (= (pixbuf-bits-per-sample pixbuf) 8))
 323   (assert (= (pixbuf-n-channels pixbuf) 4))
 324   (assert (pixbuf-has-alpha-p pixbuf))
 325   (let ((pixels (pixbuf-pixels pixbuf))
 326         (stride (pixbuf-rowstride pixbuf))
 327         (n-channels (pixbuf-n-channels pixbuf)))
 328     (loop for y from 0 below (pixbuf-height pixbuf) do
 329      (let ((row-offset (* y stride)))
 330        (loop for x from 0 below (pixbuf-width pixbuf) do
 331         (let* ((offset (+ row-offset (* n-channels x)))
 332                (p0 (ref-uint-8 pixels offset))
 333                (p2 (ref-uint-8 pixels (+ offset 2))))
 334           (setf (ref-uint-8 pixels offset) p2)
 335           (setf (ref-uint-8 pixels (+ offset 2)) p0)))))))
 336
 337 (defbinding (pixbuf-swap-rgb "clg_gdk_pixbuf_swap_rgb") () nil
 338   pixbuf)