source: project/release/4/imlib2/trunk/imlib2.scm @ 12156

Last change on this file since 12156 was 12156, checked in by sjamaan, 13 years ago

Port imlib2 to chicken 4

File size: 18.2 KB
Line 
1;;; imlib2.scm
2;
3;;; XXX: For some odd reason, imlib2_conv axe.png axe.gif won't work (with
4;;; libungif)!  So of course we don't convert it either.
5;;;
6;;; XXX TODO: Color_Modifier functions
7;;;
8;
9; Version 0.7
10;
11; Copyright (c) 2005-2008 Peter Bex (Peter.Bex@xs4all.nl)
12; All rights reserved.
13;
14; Redistribution and use in source and binary forms, with or without
15; modification, are permitted provided that the following conditions
16; are met:
17; 1. Redistributions of source code must retain the above copyright
18;    notice, this list of conditions and the following disclaimer.
19; 2. Redistributions in binary form must reproduce the above copyright
20;    notice, this list of conditions and the following disclaimer in the
21;    documentation and/or other materials provided with the distribution.
22; 3. Neither the name of Peter Bex nor the names of any contributors may
23;    be used to endorse or promote products derived from this software
24;    without specific prior written permission.
25;
26; THIS SOFTWARE IS PROVIDED BY PETER BEX AND CONTRIBUTORS ``AS IS'' AND ANY
27; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
28; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
29; DISCLAIMED.  IN NO EVENT SHALL THE FOUNDATION OR CONTRIBUTORS BE LIABLE
30; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
31; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
32; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
33; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
34; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
35; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
36; SUCH DAMAGE.
37;
38;; XXX The bools in the C interface are really all chars
39
40(module imlib2
41  (image-create image-destroy image-clone image-load image-save
42   image? image-format-set! image-format image-width image-height
43   image-filename image-alpha? image-alpha-set!
44   image-track-changes-on-disk
45   image-flip-horizontal image-flip-horizontal! image-flip-vertical
46   image-flip-vertical! image-flip-diagonal image-flip-diagonal!
47   image-orientate image-orientate! image-sharpen image-sharpen!
48   image-blur image-blur! image-tile image-tile! image-tile-horizontal
49   image-tile-horizontal! image-tile-vertical image-tile-vertical!
50   image-crop image-scale
51   image-crop&scale image-pixel/rgba image-pixel/hsva image-pixel/hlsa
52   image-pixel/cmya color/rgba color/hsva color/hlsa color/cmya color?
53   image-draw-pixel image-draw-line image-draw-rectangle
54   image-fill-rectangle)
55
56(import chicken scheme foreign)
57
58; Not needed with the latest Imlib2 (1.2.2)
59(cond-expand (with-x
60              (foreign-declare "#include <X11/Xlib.h>"))
61             (else))
62
63(foreign-declare "#include <Imlib2.h>") 
64
65(define-record image ptr)
66(define-record color setter one two three alpha)
67
68(define-foreign-type image      c-pointer)
69(define-foreign-type updates    c-pointer)
70(define-foreign-type context    c-pointer)
71(cond-expand (with-x
72              (define-foreign-type visual       (c-pointer "Visual")))
73             (else))
74
75(define-syntax define-foreign-enum&string
76  (syntax-rules ()
77    ((define-foreign-enum&string alist-name (name string) ...)
78       (begin
79         (define-foreign-variable name int) ...
80         (define alist-name `((,name . string) ...))))))
81
82(define-foreign-type imlib-load-error (enum "_imlib_load_error"))
83(define-foreign-enum&string load-errors
84  (IMLIB_LOAD_ERROR_NONE "No error!  Guess imlib was wrong :)")
85  (IMLIB_LOAD_ERROR_FILE_DOES_NOT_EXIST "File does not exist")
86  (IMLIB_LOAD_ERROR_FILE_IS_DIRECTORY "File is a directory")
87  (IMLIB_LOAD_ERROR_PERMISSION_DENIED_TO_READ "No read permissions")
88  (IMLIB_LOAD_ERROR_NO_LOADER_FOR_FILE_FORMAT "No loader for format")
89  (IMLIB_LOAD_ERROR_PATH_TOO_LONG "Path too long")
90  (IMLIB_LOAD_ERROR_PATH_COMPONENT_NON_EXISTANT "Path component nonexistent")
91  (IMLIB_LOAD_ERROR_PATH_COMPONENT_NOT_DIRECTORY "Path component is not a directory")
92  (IMLIB_LOAD_ERROR_PATH_POINTS_OUTSIDE_ADDRESS_SPACE "Path points outside address space (pointer error!)")
93  (IMLIB_LOAD_ERROR_TOO_MANY_SYMBOLIC_LINKS "Too many symbolic links")
94  (IMLIB_LOAD_ERROR_OUT_OF_MEMORY "Out of memory")
95  (IMLIB_LOAD_ERROR_OUT_OF_FILE_DESCRIPTORS "Out of file descriptors")
96  (IMLIB_LOAD_ERROR_PERMISSION_DENIED_TO_WRITE "No permission to write")
97  (IMLIB_LOAD_ERROR_OUT_OF_DISK_SPACE "Out of diskspace")
98  (IMLIB_LOAD_ERROR_UNKNOWN "Unknown error"))
99
100(define (load-error->message err)
101  (let ((match (assoc err load-errors)))        ; assoc, assq or assv?
102    (if match
103        (cdr match)
104        "Unknown API error! (this is seriously FUBAR)")))
105
106(define (imlib-err loc msg . args)
107  (abort (make-composite-condition
108           (make-property-condition 'exn
109                                    'location loc
110                                    'message msg
111                                    'arguments args)
112           (make-property-condition 'imlib))))
113
114;;;
115;;; Image functions
116;;;
117
118;; Internal convenience macros
119(define (assert-image img loc . args)
120  (when (not (image-ptr img))
121    (imlib-err loc "Invalid image parameter" args)))
122
123(define-syntax define/img
124  (syntax-rules ()
125    ((define/img (func img arg ...)
126       body ...)
127     (define (func img arg ...)
128       (assert-image img (quote func) arg ...)
129       (imlib-context-set-image (image-ptr img))
130       body ...))))
131
132(define (image-load filename)
133  (let-location ([err int])  ; int should really be imlib-load-error
134    (let* ((load-image (foreign-lambda  image
135                                        imlib_load_image_with_error_return
136                                        c-string
137                                        (c-pointer imlib-load-error)))
138           (image (load-image filename (location err))))
139      (if (= err IMLIB_LOAD_ERROR_NONE)
140          (set-finalizer! (make-image image) gc-collect)
141          (abort 
142            (make-composite-condition
143              (make-property-condition  'exn 'i/o 'file
144                                        'location 'image-load
145                                        'message (load-error->message err)
146                                        'arguments (list filename))
147              (make-property-condition 'imlib)))))))
148
149(define/img (image-save img filename)
150  (let-location ([err int])  ; int should really be imlib-load-error
151    ((foreign-lambda  void
152                     imlib_save_image_with_error_return
153                     c-string
154                     ; Yes, LOAD error...
155                     (c-pointer imlib-load-error)) filename (location err))
156    (if (= err IMLIB_LOAD_ERROR_NONE)
157        img  ; That's more convenient than (void)
158        (abort 
159          (make-composite-condition
160            (make-property-condition 'exn 'i/o 'file
161                                     'location 'image-save
162                                     'message (load-error->message err)
163                                     'arguments (list filename))
164            (make-property-condition 'imlib))))))
165
166;;
167;; Create a new image, completely transparent.
168;;
169(define (image-create width height)
170  (if (or (< width 0) (< height 0))
171      (imlib-err 'image-create "Width and height must be positive" width height)
172      (let ((img (make-image ((foreign-lambda image imlib_create_image int int) width height))))
173        (if (not img)
174            (imlib-err 'image-create "Could not create new image" (list width height))
175            (begin
176              (image-alpha-set! img #t)
177              (image-fill-rectangle img (color/rgba 0 0 0 0) 0 0 width height)
178              (set-finalizer! img gc-collect))))))
179
180(define (gc-collect img)
181  (when (image-ptr img)
182        (let ((old (imlib-context-get-image)))
183          (imlib-context-set-image (image-ptr img))
184          ((foreign-lambda void imlib_free_image))
185          (imlib-context-set-image old))))
186
187(define/img (image-destroy img)
188  ((foreign-lambda void imlib_free_image))
189  (image-ptr-set! img #f))
190
191(define/img (image-format-set! img format)
192  ((foreign-lambda void imlib_image_set_format c-string) format))
193
194(define/img (image-format img)
195  ((foreign-lambda c-string imlib_image_format)))
196
197(define/img (image-width img)
198  ((foreign-lambda int imlib_image_get_width)))
199
200(define/img (image-height img)
201  ((foreign-lambda int imlib_image_get_height)))
202
203(define/img (image-filename img)
204  ((foreign-lambda c-string imlib_image_get_filename)))
205
206; We could define this to automatically append the bang, but this makes
207; the code even less easy to read.
208(define-syntax define/clone
209  (syntax-rules ()
210    ((define/clone ?name ?name!)
211     (define (?name img . args)
212       (let ((new-img (image-clone img)))
213         (apply ?name! new-img args)
214         new-img)))))
215
216(define/img (image-flip-horizontal! img)
217  ((foreign-lambda void imlib_image_flip_horizontal)))
218(define/clone image-flip-horizontal image-flip-horizontal!)
219
220(define/img (image-flip-vertical! img)
221  ((foreign-lambda void imlib_image_flip_vertical)))
222(define/clone image-flip-vertical image-flip-horizontal!)
223
224(define/img (image-flip-diagonal! img)
225  ((foreign-lambda void imlib_image_flip_diagonal)))
226(define/clone image-flip-diagonal image-flip-diagonal!)
227
228(define/img (image-orientate! img orientation)
229  (if (or (< orientation 0) (> orientation 7))
230      (imlib-err 'image-orientate
231                 "Orientation must be between 0 and 7 inclusive"
232                 (list orientation))
233      ((foreign-lambda void imlib_image_orientate int) orientation)))
234(define/clone image-orientate image-orientate!)
235
236(define/img (image-sharpen! img radius) ;; XXX: What does a radius < 0 mean?!
237  ((foreign-lambda void imlib_image_sharpen int) radius))
238(define/clone image-sharpen image-sharpen!)
239
240(define/img (image-blur! img radius)
241  (if (< radius 0)
242      (imlib-err 'image-blur "Radius cannot be less than 0" (list radius))
243      ((foreign-lambda void imlib_image_blur int) radius)))
244(define/clone image-blur image-blur!)
245
246(define/img (image-tile-horizontal! img)
247  ((foreign-lambda void imlib_image_tile_horizontal)))
248(define/clone image-tile-horizontal image-tile-horizontal!)
249
250(define/img (image-tile-vertical! img)
251  ((foreign-lambda void imlib_image_tile_vertical)))
252(define/clone image-tile-vertical image-tile-vertical!)
253
254(define/img (image-tile! img)
255  ((foreign-lambda void imlib_image_tile)))
256(define/clone image-tile image-tile!)
257
258;; imlib_image_get_data
259;; imlib_image_get_data_for_reading_only
260;; imlib_image_put_back_data
261
262(define/img (image-alpha? img)
263  ((foreign-lambda bool imlib_image_has_alpha)))
264
265(define/img (image-alpha-set! img val)
266  ((foreign-lambda void imlib_image_set_has_alpha bool) val))
267
268(define/img (image-track-changes-on-disk img)
269  ((foreign-lambda void imlib_image_set_changes_on_disk)))
270
271
272;; XXX What does cropping/scaling mean when x/y are out of bounds? It is allowed
273(define/img (image-crop img x y width height)
274  (set-finalizer!
275   (make-image
276    ((foreign-lambda image imlib_create_cropped_image int int int int)
277     x y width height))
278   gc-collect))
279
280(define/img (image-crop&scale img src-x src-y src-width src-height dest-width dest-height)
281  (set-finalizer!
282   (make-image
283    ((foreign-lambda image imlib_create_cropped_scaled_image int int int
284                     int int int)
285     src-x src-y src-width src-height dest-width dest-height))
286   gc-collect))
287
288(define/img (image-scale img width height)
289  (image-crop&scale img 0 0 (image-width img) (image-height img) width height))
290
291(define (image-clone img)
292  (set-finalizer! (make-image (imlib-clone-image img)) gc-collect))
293
294(define/img (imlib-clone-image img)
295  (or ((foreign-lambda image imlib_clone_image))
296      (imlib-err 'imlib-clone-image "Could not clone image")))
297
298(define (check-coords loc img x y)
299  (let ((width  (image-width img))
300        (height (image-height img))
301        (fail   (lambda (msg)
302                  (imlib-err loc msg (list x y)))))
303    (cond
304      ((or (>= x width)  (< x 0)) (fail "X coordinate out of range"))
305      ((or (>= y height) (< y 0)) (fail "Y coordinate out of range")))))
306
307(define (image-pixel/rgba img x y)
308  (check-coords 'image-pixel/rgba img x y)
309  (let ((query-func (foreign-lambda* void ([int x]
310                                           [int y]
311                                           [(pointer int) r]
312                                           [(pointer int) g]
313                                           [(pointer int) b]
314                                           [(pointer int) a])
315                      "Imlib_Color col;
316                       imlib_image_query_pixel(x, y, &col);
317                       *r = col.red;
318                       *g = col.green;
319                       *b = col.blue;
320                       *a = col.alpha;")))
321    (let-location ([r int] [g int] [b int] [a int])
322      (query-func x y (location r) (location g) (location b) (location a))
323      (values r g b a))))
324
325(define/img (image-pixel/hsva img x y)
326  (check-coords 'image-pixel/hsva img x y)
327  (let-location ([h float] [s float] [v float] [a int])
328    ((foreign-lambda void imlib_image_query_pixel_hsva int int (c-pointer float) (c-pointer float) (c-pointer float) (c-pointer int)) x y (location h) (location s) (location v) (location a))
329    (values h s v a)))
330
331(define/img (image-pixel/hlsa img x y)
332  (check-coords 'image-pixel/hlsa img x y)
333  (let-location ([h float] [l float] [s float] [a int])
334    ((foreign-lambda void imlib_image_query_pixel_hlsa int int (c-pointer float) (c-pointer float) (c-pointer float) (c-pointer int)) x y (location h) (location l) (location s) (location a))
335    (values h l s a)))
336
337(define/img (image-pixel/cmya img x y)
338  (check-coords 'image-pixel/cmya img x y)
339  (let-location ([c int] [m int] [y int] [a int])
340    ((foreign-lambda void imlib_image_query_pixel_cmya int int (c-pointer int) (c-pointer int) (c-pointer int) (c-pointer int)) x y (location c) (location m) (location y) (location a))
341    (values c m y a)))
342
343;;;
344;;; Color functions
345;;;
346(define (check-colorvalues/rgba loc r g b a)
347  (if (or (< r 0) (> r 255)
348          (< g 0) (> g 255)
349          (< b 0) (> b 255)
350          (< a 0) (> a 255))
351      (imlib-err loc "Red, Green, Blue and Alpha values must be between 0 and 255" r g b a)))
352
353(define (check-colorvalues/hsva loc h s v a)
354  (cond
355    ((or (< h 0) (> h 360)) (imlib-err loc "Hue must be between 0 and 360" h s v a))
356    ((or (< s 0) (> s 1))   (imlib-err loc "Saturation must be between 0 and 1" h s v a))
357    ((or (< v 0) (> v 1))   (imlib-err "Value must be between 0 and 1" h s v a))
358    ((or (< a 0) (> a 255)) (imlib-err "Alpha must be between 0 and 255" h s v a))))
359
360(define (check-colorvalues/hlsa loc h l s a)
361  (cond
362    ((or (< h 0) (> h 360)) (imlib-err loc "Hue must be between 0 and 360" h l s a))
363    ((or (< l 0) (> l 1))   (imlib-err loc "Lightness must be between 0 and 1" h l s a))
364    ((or (< s 0) (> s 1))   (imlib-err loc "Saturation must be between 0 and 1" h l s a))
365    ((or (< a 0) (> a 255)) (imlib-err loc "Alpha must be between 0 and 255" h l s a))))
366
367(define (check-colorvalues/cmya loc c m y a)
368  (if (or (< c 0) (> c 255)
369          (< m 0) (> m 255)
370          (< y 0) (> y 255)
371          (< a 0) (> a 255))
372      (imlib-err loc "Cyan, Magenta, Yellow and Alpha values must be between 0 and 255" c m y a)))
373
374(define (color/rgba r g b a)
375  (check-colorvalues/rgba 'color/rgba r g b a)
376  (make-color imlib-context-set-color/rgba r g b a))
377
378(define (color/cmya c m y a)
379  (check-colorvalues/cmya 'color/cmya c m y a)
380  (make-color imlib-context-set-color/cmya c m y a))
381
382(define (color/hlsa h l s a)
383  (check-colorvalues/hlsa 'color/hlsa h l s a)
384  (make-color imlib-context-set-color/hlsa h l s a))
385
386(define (color/hsva h s v a)
387  (check-colorvalues/hsva 'color/hsva h s v a)
388  (make-color imlib-context-set-color/hsva h s v a))
389
390(define (context-set-color color)
391  ((color-setter color) (color-one color)
392                        (color-two color)
393                        (color-three color)
394                        (color-alpha color)))
395
396;;;
397;;; Drawing functions
398;;;
399
400;;
401;; No bounds checking on most of these functions.  You should be able to
402;;  draw a rectangle or ellipse that has a small part outside the image,
403;;  without having an exception thrown.
404;;
405(define/img (image-draw-pixel img color x y)
406  (context-set-color color)
407  (check-coords 'image-draw-pixel img x y)
408  ((foreign-lambda updates imlib_image_draw_pixel int int bool) x y #f))
409
410(define/img (image-draw-line img color x1 y1 x2 y2)
411  (context-set-color color)
412  ((foreign-lambda updates imlib_image_draw_line int int int int bool) x1 y1 x2 y2 #f))
413
414(define/img (image-draw-rectangle img color x y width height)
415  (context-set-color color)
416  ((foreign-lambda void imlib_image_draw_rectangle int int int int) x y width height))
417
418(define/img (image-fill-rectangle img color x y width height)
419  (context-set-color color)
420  ((foreign-lambda void imlib_image_fill_rectangle int int int int) x y width height))
421
422; XXX: TODO: imlib_clip_line, imlib_image_copy_alpha_(rectangle_)to_image
423;            imlib_image_scroll_rect, imlib_image_copy_rect,
424;            imlib_image_draw_ellipse, imlib_image_fill_ellipse
425;
426; Polygon drawing functions
427
428;;;
429;;; Lame context functions.  Not all are used, this will give warnings.
430;;; I just played around with them for a bit.  Eventually they'll all either
431;;; be used or removed.
432;;;
433(define imlib-context-pop
434  (foreign-lambda void imlib_context_pop))
435
436(define imlib-context-push
437  (foreign-lambda void imlib_context_push context))
438
439;;
440;; XXX: Imlib2 doesn't do any check on the context-stack's underlying context.
441;;  If it is NULL, this will segfault.
442;;
443(define imlib-context-free
444  (foreign-lambda void imlib_context_free context))
445
446;;
447;; XXX: Imlib2 doesn't do any error checking on malloc in this function,
448;;  and dereferences the resulting pointer.  There's currently nothing we
449;;  can do to prevent a segfault in an out of memory situation.
450;;
451(define imlib-context-new
452  (foreign-lambda context imlib_context_new))
453
454(define imlib-context-set-image
455  (foreign-lambda void imlib_context_set_image image))
456
457(define imlib-context-get-image
458  (foreign-lambda image imlib_context_get_image))
459
460(cond-expand (with-x
461              (define imlib-context-set-visual
462                (foreign-lambda void imlib_context_set_visual visual)))
463             (else))
464
465(define imlib-context-set-cliprect
466  (foreign-lambda void imlib_context_set_cliprect int int int int))
467
468(define imlib-context-set-dither-mask
469  (foreign-lambda void imlib_context_set_dither_mask bool))
470
471(define imlib-context-get-dither-mask
472  (foreign-lambda bool imlib_context_get_dither_mask))
473
474(define imlib-context-set-dither
475  (foreign-lambda void imlib_context_set_dither bool))
476
477(define imlib-context-get-dither
478  (foreign-lambda bool imlib_context_get_dither))
479
480(define imlib-context-set-anti-alias
481  (foreign-lambda void imlib_context_set_anti_alias bool))
482
483(define imlib-context-get-anti-alias
484  (foreign-lambda bool imlib_context_get_anti_alias))
485
486(define imlib-context-set-blend
487  (foreign-lambda void imlib_context_set_blend bool))
488
489(define imlib-context-get-blend
490  (foreign-lambda bool imlib_context_get_blend))
491
492(define (imlib-context-set-color/rgba r g b a)
493  ((foreign-lambda void imlib_context_set_color int int int int) r g b a))
494
495(define (imlib-context-set-color/hsva h s v a)
496  ((foreign-lambda void imlib_context_set_color_hsva float float float int)
497     h s v a))
498
499(define (imlib-context-set-color/hlsa h l s a)
500  ((foreign-lambda void imlib_context_set_color_hlsa float float float int) h l s a))
501
502(define (imlib-context-set-color/cmya c m y a)
503   ((foreign-lambda void imlib_context_set_color_cmya int int int int) c m y a))
504)
Note: See TracBrowser for help on using the repository browser.