chiark / gitweb /
Hopefully allow (require :glib) again.
[clg] / gdk / pixbuf.lisp
CommitLineData
112ac1d3 1;; Common Lisp bindings for GTK+ v2.x
2;; Copyright 2004-2005 Espen S. Johnsen <espen@users.sf.net>
43e8a182 3;;
112ac1d3 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:
43e8a182 11;;
112ac1d3 12;; The above copyright notice and this permission notice shall be
13;; included in all copies or substantial portions of the Software.
43e8a182 14;;
112ac1d3 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
eb20960b 23;; $Id: pixbuf.lisp,v 1.9 2008-12-10 03:01:34 espen Exp $
43e8a182 24
25
26(in-package "GDK")
27
eb20960b 28(defbinding %pixbuf-new () pointer
29 colorspace
30 (has-alpha boolean)
31 (bits-per-sample int)
32 (width int)
33 (height int))
43e8a182 34
eb20960b 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
43e8a182 50 (filename pathname)
73326d92 51 (nil (or null gerror) :out))
43e8a182 52
eb20960b 53(defbinding %pixbuf-new-from-file-at-size () pointer
43e8a182 54 (filename pathname)
55 (width int)
56 (height int)
73326d92 57 (nil (or null gerror) :out))
43e8a182 58
90c5d56b 59#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
eb20960b 60(defbinding %pixbuf-new-from-file-at-scale () pointer
43e8a182 61 (filename pathname)
62 (width int)
63 (height int)
64 (preserve-aspect-ratio boolean)
73326d92 65 (nil (or null gerror) :out))
43e8a182 66
eb20960b 67(defun %pixbuf-load (filename width height preserve-aspect-p)
68 (multiple-value-bind (location gerror)
ed794f57 69 (cond
eb20960b 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)))
ed794f57 79 (if gerror
80 (signal-gerror gerror)
eb20960b 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))
43e8a182 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)
ed794f57 161 (keys strings)
fd092148 162 (values strings)
73326d92 163 (nil (or null gerror) :out))
43e8a182 164
eb20960b 165(defun %pixbuf-save-options (options)
43e8a182 166 (let ((keys (make-array 0 :adjustable t :fill-pointer t))
167 (values (make-array 0 :adjustable t :fill-pointer t)))
168 (loop
eb20960b 169 for (key value) on options by #'cddr
43e8a182 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))
eb20960b 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))))
43e8a182 226
eb20960b 227
228;; (defbinding pixbuf-new-from-xpm-data () (referenced pixbuf)
229;; (data (vector string)))
43e8a182 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
73326d92 243(defbinding %pixbuf-get-from-drawable () (or null (referenced pixbuf))
c379590e 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
43e8a182 266
98d09247 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
43e8a182 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)))
eb20960b 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)