source: project/release/3/imlib2/trunk/imlib2.scm @ 10055

Last change on this file since 10055 was 10055, checked in by Kon Lovett, 13 years ago

Using canonical directory structure.

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