/[cl-gd]/cl-gd/images.lisp
ViewVC logotype

Contents of /cl-gd/images.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Sun Apr 25 20:34:01 2004 UTC (9 years, 11 months ago) by eweitz
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +13 -3 lines
pre-0.3.2 with bugfix for LW bivalent streams
1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*-
2 ;;; $Header: /tiger/var/lib/cvsroots/cl-gd/cl-gd/images.lisp,v 1.3 2004/04/25 20:34:01 eweitz Exp $
3
4 ;;; Copyright (c) 2003, Dr. Edmund Weitz. All rights reserved.
5
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
8 ;;; are met:
9
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
17
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29
30 (in-package :cl-gd)
31
32 (defun create-image (width height &optional true-color)
33 "Allocates and returns a GD image structure with size WIDTH x
34 HEIGHT. Creates a true color image if TRUE-COLOR is true. You are
35 responsible for destroying the image after you're done with it. It is
36 advisable to use WITH-IMAGE instead."
37 (check-type width integer)
38 (check-type height integer)
39 (let ((image-ptr
40 (if true-color
41 (gd-image-create-true-color width height)
42 (gd-image-create width height))))
43 (when (null-pointer-p image-ptr)
44 (error "Could not allocate image of size ~A x ~A" width height))
45 (make-image image-ptr)))
46
47 (defun destroy-image (image)
48 "Destroys \(deallocates) IMAGE which has been created by
49 CREATE-IMAGE, CREATE-IMAGE-FROM-FILE, or CREATE-IMAGE-FROM-GD2-PART."
50 (check-type image image)
51 (gd-image-destroy (img image))
52 nil)
53
54 (defmacro with-default-image ((image) &body body)
55 "Executes BODY with *DEFAULT-IMAGE* bound to IMAGE so that you don't
56 have to provide the IMAGE keyword/optional argument to CL-GD
57 functions."
58 `(let ((*default-image* ,image))
59 ,@body))
60
61 (defmacro with-image ((name width height &optional true-color) &body body)
62 "Creates an image with size WIDTH x HEIGHT, and executes BODY with
63 the image bound to NAME. If TRUE-COLOR is true, creates a true color
64 image. The image is guaranteed to be destroyed before this macro
65 exits."
66 ;; we rebind everything so we have left-to-right evaluation
67 (rebinding (width height true-color)
68 `(let ((,name (create-image ,width ,height ,true-color)))
69 (unwind-protect
70 (progn
71 ,@body)
72 (destroy-image ,name)))))
73
74 (defmacro with-image* ((width height &optional true-color) &body body)
75 "Creates an image with size WIDTH x HEIGHT and executes BODY with
76 the image bound to *DEFAULT-IMAGE*. If TRUE-COLOR is true, creates a
77 true color image. The image is guaranteed to be destroyed before this
78 macro exits."
79 `(with-image (*default-image* ,width, height ,true-color)
80 ,@body))
81
82 (defun create-image-from-file (file-name &optional type)
83 "Creates an image from the file specified by FILE-NAME \(which is
84 either a pathname or a string). The type of the image can be provided
85 as TYPE or otherwise it will be guessed from the PATHNAME-TYPE of
86 FILE-NAME. You are responsible for destroying the image after you're
87 done with it. It is advisable to use WITH-IMAGE-FROM-FILE instead."
88 (check-type file-name (or pathname string))
89 (let* ((pathname-type (pathname-type file-name))
90 (%type (or type
91 (cond ((or (string-equal pathname-type "jpg")
92 (string-equal pathname-type "jpeg"))
93 :jpg)
94 ((string-equal pathname-type "png")
95 :png)
96 ((string-equal pathname-type "gd")
97 :gd)
98 ((string-equal pathname-type "gd2")
99 :gd2)
100 ((string-equal pathname-type "xbm")
101 :xbm)
102 #-:win32
103 ((string-equal pathname-type "xpm")
104 :xpm)
105 #+:cl-gd-gif
106 ((string-equal pathname-type "gif")
107 :gif)))))
108 (unless %type
109 (error "No type provided and it couldn't be guessed from filename"))
110 (unless (probe-file file-name)
111 (error "File ~S could not be found" file-name))
112 (when (pathnamep file-name)
113 (setq file-name (namestring file-name)))
114 (with-foreign-object (err :int)
115 (with-cstring (c-file-name file-name)
116 (let ((image (ecase %type
117 ((:jpg :jpeg)
118 (gd-image-create-from-jpeg-file c-file-name err))
119 ((:png)
120 (gd-image-create-from-png-file c-file-name err))
121 ((:gd)
122 (gd-image-create-from-gd-file c-file-name err))
123 ((:gd2)
124 (gd-image-create-from-gd2-file c-file-name err))
125 ((:xbm)
126 (gd-image-create-from-xbm-file c-file-name err))
127 #-:win32
128 ((:xpm)
129 (gd-image-create-from-xpm c-file-name))
130 #+:cl-gd-gif
131 ((:gif)
132 (gd-image-create-from-gif-file c-file-name err)))))
133 (cond ((null-pointer-p image)
134 (cond ((or (eq %type :xpm)
135 (zerop (deref-pointer err :int)))
136 (error "Could not create image from ~A file ~S"
137 %type file-name))
138 (t
139 (error "Could not create image from ~A file ~S: errno was ~A"
140 %type file-name (deref-pointer err :int)))))
141 (t (make-image image))))))))
142
143 (defmacro with-image-from-file ((name file-name &optional type) &body body)
144 "Creates an image from the file specified by FILE-NAME \(which is
145 either a pathname or a string) and executes BODY with the image bound
146 to NAME. The type of the image can be provied as TYPE or otherwise it
147 will be guessed from the PATHNAME-TYPE of FILE-NAME. The image is
148 guaranteed to be destroyed before this macro exits."
149 ;; we rebind everything so we have left-to-right evaluation
150 (rebinding (file-name type)
151 `(let ((,name (create-image-from-file ,file-name ,type)))
152 (unwind-protect
153 ,@body
154 (when ,name
155 (destroy-image ,name))))))
156
157 (defmacro with-image-from-file* ((file-name &optional type) &body body)
158 "Creates an image from the file specified by FILE-NAME \(which is
159 either a pathname or a string) and executes BODY with the image bound
160 to *DEFAULT-IMAGE*. The type of the image can be provied as TYPE or
161 otherwise it will be guessed from the PATHNAME-TYPE of FILE-NAME. The
162 image is guaranteed to be destroyed before this macro exits."
163 `(with-image-from-file (*default-image* ,file-name ,type)
164 ,@body))
165
166 (defun create-image-from-gd2-part (file-name src-x src-y width height)
167 "Creates an image from the part of the GD2 file FILE-NAME \(which is
168 either a pathname or a string) specified by SRC-X, SRC-Y, WIDTH, and
169 HEIGHT. You are responsible for destroying the image after you're done
170 with it. It is advisable to use WITH-IMAGE-FROM-GD2-PART instead."
171 (check-type file-name (or string pathname))
172 (check-type src-x integer)
173 (check-type src-y integer)
174 (check-type width integer)
175 (check-type height integer)
176 (unless (probe-file file-name)
177 (error "File ~S could not be found" file-name))
178 (when (pathnamep file-name)
179 (setq file-name (namestring file-name)))
180 (with-foreign-object (err :int)
181 (with-cstring (c-file-name file-name)
182 (let ((image (gd-image-create-from-gd2-part-file c-file-name err src-x src-y width height)))
183 (cond ((null-pointer-p image)
184 (error "Could not create GD2 image from file ~S: errno was ~A"
185 file-name (deref-pointer err :int)))
186 (t image))))))
187
188 (defmacro with-image-from-gd2-part ((name file-name src-x src-y width height) &body body)
189 "Creates an image from the part of the GD2 file FILE-NAME \(which is
190 either a pathname or a string) specified SRC-X, SRC-Y, WIDTH, and
191 HEIGHT and executes BODY with the image bound to NAME. The type of the
192 image can be provied as TYPE or otherwise it will be guessed from the
193 PATHNAME-TYPE of FILE-NAME. The image is guaranteed to be destroyed
194 before this macro exits."
195 ;; we rebind everything so we have left-to-right evaluation
196 (rebinding (file-name src-x src-y width height)
197 `(let ((,name (create-image-from-gd2-part ,file-name ,src-x ,src-y ,width ,height)))
198 (unwind-protect
199 ,@body
200 (when ,name
201 (destroy-image ,name))))))
202
203 (defmacro with-image-from-gd2-part* ((file-name src-x src-y width height) &body body)
204 "Creates an image from the part of the GD2 file FILE-NAME \(which is
205 either a pathname or a string) specified SRC-X, SRC-Y, WIDTH, and
206 HEIGHT and executes BODY with the image bound to *DEFAULT-IMAGE*. The
207 type of the image can be provied as TYPE or otherwise it will be
208 guessed from the PATHNAME-TYPE of FILE-NAME. The image is guaranteed
209 to be destroyed before this macro exits."
210 `(with-image-from-gd2-part (*default-image* ,file-name ,src-x ,src-y ,width ,height)
211 ,@body))
212
213 (defmacro make-stream-fn (name signature gd-call type-checks docstring)
214 "Internal macro used to generate WRITE-JPEG-TO-STREAM and friends."
215 `(defun ,name ,signature
216 ,docstring
217 ,@type-checks
218 (cond ((or #+(and :allegro :allegro-version>= (version>= 6 0))
219 (typep stream 'excl:simple-stream)
220 #+:lispworks4.3
221 (subtypep (stream-element-type stream) 'base-char)
222 (subtypep (stream-element-type stream) '(unsigned-byte 8)))
223 (with-foreign-object (size :int)
224 (let ((memory ,gd-call)
225 #+:lispworks4.3 (temp-array (make-array 1 :element-type
226 '(unsigned-byte 8))))
227 (unwind-protect
228 (with-cast-pointer (temp memory :unsigned-byte)
229 (dotimes (i (deref-pointer size :int))
230 ;; LispWorks workaround, WRITE-BYTE won't work - see
231 ;; <http://article.gmane.org/gmane.lisp.lispworks.general/1827>
232 #+:lispworks4.3
233 (setf (aref temp-array 0)
234 (deref-array temp '(:array :unsigned-byte) i))
235 #+:lispworks4.3
236 (write-sequence temp-array stream)
237 #-:lispworks4.3
238 (write-byte (deref-array temp '(:array :unsigned-byte) i)
239 stream))
240 image)
241 (gd-free memory)))))
242 ((subtypep (stream-element-type stream) 'character)
243 (with-foreign-object (size :int)
244 (let ((memory ,gd-call))
245 (unwind-protect
246 (with-cast-pointer (temp memory
247 #+(or :cmu :scl :sbcl) :unsigned-char
248 #-(or :cmu :scl :sbcl) :char)
249 (dotimes (i (deref-pointer size :int))
250 (write-char (ensure-char-character
251 (deref-array temp '(:array :char) i))
252 stream))
253 image)
254 (gd-free memory)))))
255 (t (error "Can't use a stream with element-type ~A"
256 (stream-element-type stream))))))
257
258 (make-stream-fn write-jpeg-to-stream (stream &key (quality -1) (image *default-image*))
259 (gd-image-jpeg-ptr (img image) size quality)
260 ((check-type stream stream)
261 (check-type quality (integer -1 100))
262 (check-type image image))
263 "Writes image IMAGE to stream STREAM as JPEG. If
264 QUALITY is not specified, the default IJG JPEG quality value is
265 used. Otherwise, for practical purposes, quality should be a value in
266 the range 0-95. STREAM must be a character stream or a binary stream
267 of element type \(UNSIGNED-BYTE 8). If STREAM is a character stream,
268 the user of this function has to make sure the external format is
269 yields faithful output of all 8-bit characters.")
270
271 (make-stream-fn write-png-to-stream (stream &key compression-level (image *default-image*))
272 (cond (compression-level
273 (gd-image-png-ptr-ex (img image) size compression-level))
274 (t
275 (gd-image-png-ptr (img image) size)))
276 ((check-type stream stream)
277 (check-type compression-level (or null (integer -1 9)))
278 (check-type image image))
279 "Writes image IMAGE to stream STREAM as PNG. If
280 COMPRESSION-LEVEL is not specified, the default compression level at
281 the time zlib was compiled on your system will be used. Otherwise, a
282 compression level of 0 means 'no compression', a compression level of
283 1 means 'compressed, but as quickly as possible', a compression level
284 of 9 means 'compressed as much as possible to produce the smallest
285 possible file.' STREAM must be a character stream or a binary stream
286 of element type \(UNSIGNED-BYTE 8). If STREAM is a character stream,
287 the user of this function has to make sure the external format yields
288 faithful output of all 8-bit characters.")
289
290 #+:cl-gd-gif
291 (make-stream-fn write-gif-to-stream (stream &key (image *default-image*))
292 (gd-image-gif-ptr (img image) size)
293 ((check-type stream stream)
294 (check-type image image))
295 "Writes image IMAGE to stream STREAM as GIF. STREAM
296 must be a character stream or a binary stream of element type
297 \(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this
298 function has to make sure the external format yields faithful output
299 of all 8-bit characters.")
300
301 (make-stream-fn write-wbmp-to-stream (stream &key foreground (image *default-image*))
302 (gd-image-wbmp-ptr (img image) size foreground)
303 ((check-type stream stream)
304 (check-type foreground integer)
305 (check-type image image))
306 "Writes image IMAGE to stream STREAM as WBMP. STREAM
307 must be a character stream or a binary stream of element type
308 \(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this
309 function has to make sure the external format yields faithful output
310 of all 8-bit characters. WBMP file support is black and white
311 only. The color index specified by the FOREGOUND argument is the
312 \"foreground,\" and only pixels of this color will be set in the WBMP
313 file")
314
315 (make-stream-fn write-gd-to-stream (stream &key (image *default-image*))
316 (gd-image-gd-ptr (img image) size)
317 ((check-type stream stream)
318 (check-type image image))
319 "Writes image IMAGE to stream STREAM as GD. STREAM
320 must be a character stream or a binary stream of element type
321 \(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this
322 function has to make sure the external format yields faithful output
323 of all 8-bit characters.")
324
325 (make-stream-fn write-gd2-to-stream (stream &key (image *default-image*))
326 (gd-image-gd2-ptr (img image) size)
327 ((check-type stream stream)
328 (check-type image image))
329 "Writes image IMAGE to stream STREAM as GD2. STREAM
330 must be a character stream or a binary stream of element type
331 \(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this
332 function has to make sure the external format yields faithful output
333 of all 8-bit characters.")
334
335 (defun write-image-to-stream (stream type &rest rest &key &allow-other-keys)
336 "Writes image to STREAM. The type of the image is determined by TYPE
337 which must be one of :JPG, :JPEG, :PNG, :WBMP, :GD, or :GD2. STREAM
338 must be a character stream or a binary stream of element type
339 \(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this
340 function has to make sure the external format yields faithful output
341 of all 8-bit characters."
342 (apply (ecase type
343 ((:jpg :jpeg)
344 #'write-jpeg-to-stream)
345 ((:png)
346 #'write-png-to-stream)
347 ((:wbmp)
348 #'write-wbmp-to-stream)
349 ((:gd)
350 #'write-gd-to-stream)
351 ((:gd2)
352 #'write-gd2-to-stream)
353 #+:cl-gd-gif
354 ((:gif)
355 #'write-gif-to-stream))
356 stream rest))
357
358 (defun write-image-to-file (file-name &rest rest &key type (if-exists :error) &allow-other-keys)
359 "Writes image to the file specified by FILE-NAME \(a pathname or a
360 string). The TYPE argument is interpreted as in
361 WRITE-IMAGE-TO-STREAM. If it is not provided it is guessed from the
362 PATHNAME-TYPE of FILE-NAME. The IF-EXISTS keyword argument is given to
363 OPEN. Other keyword argument like QUALITY or COMPRESSION-LEVEL can be
364 provided depending on the images's type."
365 (with-open-file (stream file-name :direction :output
366 :if-exists if-exists
367 :element-type '(unsigned-byte 8))
368 (apply #'write-image-to-stream
369 stream
370 (or type
371 (let ((pathname-type (pathname-type (truename file-name))))
372 (cond ((or (string-equal pathname-type "jpg")
373 (string-equal pathname-type "jpeg"))
374 :jpg)
375 ((string-equal pathname-type "png")
376 :png)
377 ((string-equal pathname-type "wbmp")
378 :wbmp)
379 ((string-equal pathname-type "gd")
380 :gd)
381 ((string-equal pathname-type "gd2")
382 :gd2)
383 #+:cl-gd-gif
384 ((string-equal pathname-type "gif")
385 :gif)
386 (t
387 (error "Can't determine the type of the image")))))
388 (sans rest :type :if-exists))))
389
390 (defun image-width (&optional (image *default-image*))
391 "Returns width of IMAGE."
392 (check-type image image)
393 (with-transformed-alternative
394 (((gd-image-get-sx (img image)) w-inv-transformer))
395 (gd-image-get-sx (img image))))
396
397 (defun image-height (&optional (image *default-image*))
398 (check-type image image)
399 "Returns height of IMAGE."
400 (with-transformed-alternative
401 (((gd-image-get-sy (img image)) h-inv-transformer))
402 (gd-image-get-sy (img image))))
403
404 (defun image-size (&optional (image *default-image*))
405 (check-type image image)
406 "Returns width and height of IMAGE as two values."
407 (with-transformed-alternative
408 (((gd-image-get-sx (img image)) w-inv-transformer)
409 ((gd-image-get-sy (img image)) h-inv-transformer))
410 (values (gd-image-get-sx (img image))
411 (gd-image-get-sy (img image)))))

  ViewVC Help
Powered by ViewVC 1.1.5