Changeset 12156 in project for release/4/imlib2/trunk/imlib2.scm

Timestamp:

10/14/08 23:09:27 (13 years ago)

Author:

sjamaan

Message:

Port imlib2 to chicken 4

Location:

release/4/imlib2

Files:

• . (copied) (copied from release/3/imlib2)
• trunk/imlib2.scm (modified) (16 diffs)

release/4/imlib2/trunk/imlib2.scm

@@ -7 +7 @@
 ;;;
 ;
-; Version 0.4
+; Version 0.7
 ;
-; Copyright (c) 2005, 2006 Peter Bex (Peter.Bex@xs4all.nl)
+; Copyright (c) 2005-2008 Peter Bex (Peter.Bex@xs4all.nl)
 ; All rights reserved.
 ; 
@@ -38 +38 @@
 ;; XXX The bools in the C interface are really all chars
 
-(declare
-  (export imlib:create imlib:destroy imlib:clone imlib:load imlib:save
-          imlib:image? imlib:format-set! imlib:format imlib:width imlib:height
-          imlib:filename imlib:alpha? imlib:alpha-set!
-          imlib:track-changes-on-disk
-          imlib:flip-horizontal imlib:flip-horizontal! imlib:flip-vertical
-          imlib:flip-vertical! imlib:flip-diagonal imlib:flip-diagonal!
-          imlib:orientate imlib:orientate! imlib:sharpen imlib:sharpen!
-          imlib:blur imlib:blur! imlib:tile imlib:tile! imlib:tile-horizontal
-          imlib:tile-horizontal! imlib:tile-vertical imlib:tile-vertical!
-          imlib:crop imlib:scale
-          imlib:crop&scale imlib:pixel/rgba imlib:pixel/hsva imlib:pixel/hlsa
-          imlib:pixel/cmya imlib:color/rgba imlib:color/hsva imlib:color/hlsa
-          imlib:color/cmya imlib:color?
-          imlib:draw-pixel imlib:draw-line imlib:draw-rectangle
-          imlib:fill-rectangle))
+(module imlib2
+  (image-create image-destroy image-clone image-load image-save
+   image? image-format-set! image-format image-width image-height
+   image-filename image-alpha? image-alpha-set!
+   image-track-changes-on-disk
+   image-flip-horizontal image-flip-horizontal! image-flip-vertical
+   image-flip-vertical! image-flip-diagonal image-flip-diagonal!
+   image-orientate image-orientate! image-sharpen image-sharpen!
+   image-blur image-blur! image-tile image-tile! image-tile-horizontal
+   image-tile-horizontal! image-tile-vertical image-tile-vertical!
+   image-crop image-scale
+   image-crop&scale image-pixel/rgba image-pixel/hsva image-pixel/hlsa
+   image-pixel/cmya color/rgba color/hsva color/hlsa color/cmya color?
+   image-draw-pixel image-draw-line image-draw-rectangle
+   image-fill-rectangle)
+
+(import chicken scheme foreign)
 
 ; Not needed with the latest Imlib2 (1.2.2)
@@ -62 +63 @@
 (foreign-declare "#include <Imlib2.h>") 
 
-(use syntax-case)
-
-(define-record imlib:image ptr)
-(define-record imlib:color setter one two three alpha)
+(define-record image ptr)
+(define-record color setter one two three alpha)
 
 (define-foreign-type image      c-pointer)
@@ -119 +118 @@
 ;; Internal convenience macros
 (define (assert-image img loc . args)
-  (when (not (imlib:image-ptr img))
+  (when (not (image-ptr img))
     (imlib-err loc "Invalid image parameter" args)))
 
@@ -128 +127 @@
      (define (func img arg ...)
        (assert-image img (quote func) arg ...)
-       (imlib-context-set-image (imlib:image-ptr img))
+       (imlib-context-set-image (image-ptr img))
        body ...))))
 
-(define (imlib:load filename)
+(define (image-load filename)
   (let-location ([err int])  ; int should really be imlib-load-error
     (let* ((load-image (foreign-lambda  image
@@ -139 +138 @@
            (image (load-image filename (location err))))
       (if (= err IMLIB_LOAD_ERROR_NONE)
-          (set-finalizer! (make-imlib:image image) imlib:collect)
+          (set-finalizer! (make-image image) gc-collect)
           (abort 
             (make-composite-condition
               (make-property-condition  'exn 'i/o 'file
-                                        'location 'imlib:load
+                                        'location 'image-load
                                         'message (load-error->message err)
                                         'arguments (list filename))
               (make-property-condition 'imlib)))))))
 
-(define/img (imlib:save img filename)
+(define/img (image-save img filename)
   (let-location ([err int])  ; int should really be imlib-load-error
     ((foreign-lambda  void
@@ -160 +159 @@
           (make-composite-condition
             (make-property-condition 'exn 'i/o 'file
-                                     'location 'imlib:save
+                                     'location 'image-save
                                      'message (load-error->message err)
                                      'arguments (list filename))
@@ -168 +167 @@
 ;; Create a new image, completely transparent.
 ;;
-(define (imlib:create width height)
+(define (image-create width height)
   (if (or (< width 0) (< height 0))
-      (imlib-err 'imlib:create "Width and height must be positive" width height)
-      (let ((img (make-imlib:image ((foreign-lambda image imlib_create_image int int) width height))))
+      (imlib-err 'image-create "Width and height must be positive" width height)
+      (let ((img (make-image ((foreign-lambda image imlib_create_image int int) width height))))
         (if (not img)
-            (imlib-err 'imlib:create "Could not create new image" (list width height))
+            (imlib-err 'image-create "Could not create new image" (list width height))
             (begin
-              (imlib:alpha-set! img #t)
-              (imlib:fill-rectangle img (imlib:color/rgba 0 0 0 0) 0 0 width height)
-              (set-finalizer! img imlib:collect))))))
-
-(define (imlib:collect img)
-  (when (imlib:image-ptr img)
+              (image-alpha-set! img #t)
+              (image-fill-rectangle img (color/rgba 0 0 0 0) 0 0 width height)
+              (set-finalizer! img gc-collect))))))
+
+(define (gc-collect img)
+  (when (image-ptr img)
         (let ((old (imlib-context-get-image)))
-          (imlib-context-set-image (imlib:image-ptr img))
+          (imlib-context-set-image (image-ptr img))
           ((foreign-lambda void imlib_free_image))
           (imlib-context-set-image old))))
 
-(define/img (imlib:destroy img)
+(define/img (image-destroy img)
   ((foreign-lambda void imlib_free_image))
-  (imlib:image-ptr-set! img #f))
-
-(define/img (imlib:format-set! img format)
+  (image-ptr-set! img #f))
+
+(define/img (image-format-set! img format)
   ((foreign-lambda void imlib_image_set_format c-string) format))
 
-(define/img (imlib:format img)
+(define/img (image-format img)
   ((foreign-lambda c-string imlib_image_format)))
 
-(define/img (imlib:width img)
+(define/img (image-width img)
   ((foreign-lambda int imlib_image_get_width)))
 
-(define/img (imlib:height img)
+(define/img (image-height img)
   ((foreign-lambda int imlib_image_get_height)))
 
-(define/img (imlib:filename img)
+(define/img (image-filename img)
   ((foreign-lambda c-string imlib_image_get_filename)))
 
@@ -211 +210 @@
     ((define/clone ?name ?name!)
      (define (?name img . args)
-       (let ((new-img (imlib:clone img)))
+       (let ((new-img (image-clone img)))
          (apply ?name! new-img args)
          new-img)))))
 
-(define/img (imlib:flip-horizontal! img)
+(define/img (image-flip-horizontal! img)
   ((foreign-lambda void imlib_image_flip_horizontal)))
-(define/clone imlib:flip-horizontal imlib:flip-horizontal!)
-
-(define/img (imlib:flip-vertical! img)
+(define/clone image-flip-horizontal image-flip-horizontal!)
+
+(define/img (image-flip-vertical! img)
   ((foreign-lambda void imlib_image_flip_vertical)))
-(define/clone imlib:flip-vertical imlib:flip-horizontal!)
-
-(define/img (imlib:flip-diagonal! img)
+(define/clone image-flip-vertical image-flip-horizontal!)
+
+(define/img (image-flip-diagonal! img)
   ((foreign-lambda void imlib_image_flip_diagonal)))
-(define/clone imlib:flip-diagonal imlib:flip-diagonal!)
-
-(define/img (imlib:orientate! img orientation)
+(define/clone image-flip-diagonal image-flip-diagonal!)
+
+(define/img (image-orientate! img orientation)
   (if (or (< orientation 0) (> orientation 7))
-      (imlib-err 'imlib:orientate
+      (imlib-err 'image-orientate
                  "Orientation must be between 0 and 7 inclusive"
                  (list orientation))
       ((foreign-lambda void imlib_image_orientate int) orientation)))
-(define/clone imlib:orientate imlib:orientate!)
-
-(define/img (imlib:sharpen! img radius) ;; XXX: What does a radius < 0 mean?!
+(define/clone image-orientate image-orientate!)
+
+(define/img (image-sharpen! img radius) ;; XXX: What does a radius < 0 mean?!
   ((foreign-lambda void imlib_image_sharpen int) radius))
-(define/clone imlib:sharpen imlib:sharpen!)
-
-(define/img (imlib:blur! img radius)
+(define/clone image-sharpen image-sharpen!)
+
+(define/img (image-blur! img radius)
   (if (< radius 0)
-      (imlib-err 'imlib:blur "Radius cannot be less than 0" (list radius))
+      (imlib-err 'image-blur "Radius cannot be less than 0" (list radius))
       ((foreign-lambda void imlib_image_blur int) radius)))
-(define/clone imlib:blur imlib:blur!)
-
-(define/img (imlib:tile-horizontal! img)
+(define/clone image-blur image-blur!)
+
+(define/img (image-tile-horizontal! img)
   ((foreign-lambda void imlib_image_tile_horizontal)))
-(define/clone imlib:tile-horizontal imlib:tile-horizontal!)
-
-(define/img (imlib:tile-vertical! img)
+(define/clone image-tile-horizontal image-tile-horizontal!)
+
+(define/img (image-tile-vertical! img)
   ((foreign-lambda void imlib_image_tile_vertical)))
-(define/clone imlib:tile-vertical imlib:tile-vertical!)
-
-(define/img (imlib:tile! img)
+(define/clone image-tile-vertical image-tile-vertical!)
+
+(define/img (image-tile! img)
   ((foreign-lambda void imlib_image_tile)))
-(define/clone imlib:tile imlib:tile!)
+(define/clone image-tile image-tile!)
 
 ;; imlib_image_get_data
@@ -261 +260 @@
 ;; imlib_image_put_back_data
 
-(define/img (imlib:alpha? img)
+(define/img (image-alpha? img)
   ((foreign-lambda bool imlib_image_has_alpha)))
 
-(define/img (imlib:alpha-set! img val)
+(define/img (image-alpha-set! img val)
   ((foreign-lambda void imlib_image_set_has_alpha bool) val))
 
-(define/img (imlib:track-changes-on-disk img)
+(define/img (image-track-changes-on-disk img)
   ((foreign-lambda void imlib_image_set_changes_on_disk)))
 
 
 ;; XXX What does cropping/scaling mean when x/y are out of bounds? It is allowed
-(define/img (imlib:crop img x y width height)
+(define/img (image-crop img x y width height)
   (set-finalizer!
-   (make-imlib:image
+   (make-image
     ((foreign-lambda image imlib_create_cropped_image int int int int)
      x y width height))
-   imlib:collect))
-
-(define/img (imlib:crop&scale img src-x src-y src-width src-height dest-width dest-height)
+   gc-collect))
+
+(define/img (image-crop&scale img src-x src-y src-width src-height dest-width dest-height)
   (set-finalizer!
-   (make-imlib:image
+   (make-image
     ((foreign-lambda image imlib_create_cropped_scaled_image int int int
                      int int int)
      src-x src-y src-width src-height dest-width dest-height))
-   imlib:collect))
-
-(define/img (imlib:scale img width height)
-  (imlib:crop&scale img 0 0 (imlib:width img) (imlib:height img) width height))
-
-(define (imlib:clone img)
-  (set-finalizer! (make-imlib:image (imlib-clone-image img)) imlib:collect))
+   gc-collect))
+
+(define/img (image-scale img width height)
+  (image-crop&scale img 0 0 (image-width img) (image-height img) width height))
+
+(define (image-clone img)
+  (set-finalizer! (make-image (imlib-clone-image img)) gc-collect))
 
 (define/img (imlib-clone-image img)
@@ -298 +297 @@
 
 (define (check-coords loc img x y)
-  (let ((width  (imlib:width img))
-        (height (imlib:height img))
+  (let ((width  (image-width img))
+        (height (image-height img))
         (fail   (lambda (msg)
                   (imlib-err loc msg (list x y)))))
@@ -306 +305 @@
       ((or (>= y height) (< y 0)) (fail "Y coordinate out of range")))))
 
-(define (imlib:pixel/rgba img x y)
-  (check-coords 'imlib:pixel/rgba img x y)
+(define (image-pixel/rgba img x y)
+  (check-coords 'image-pixel/rgba img x y)
   (let ((query-func (foreign-lambda* void ([int x]
                                            [int y]
@@ -324 +323 @@
       (values r g b a))))
 
-(define/img (imlib:pixel/hsva img x y)
-  (check-coords 'imlib:pixel/hsva img x y)
+(define/img (image-pixel/hsva img x y)
+  (check-coords 'image-pixel/hsva img x y)
   (let-location ([h float] [s float] [v float] [a int])
     ((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))
     (values h s v a)))
 
-(define/img (imlib:pixel/hlsa img x y)
-  (check-coords 'imlib:pixel/hlsa img x y)
+(define/img (image-pixel/hlsa img x y)
+  (check-coords 'image-pixel/hlsa img x y)
   (let-location ([h float] [l float] [s float] [a int])
     ((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))
     (values h l s a)))
 
-(define/img (imlib:pixel/cmya img x y)
-  (check-coords 'imlib:pixel/cmya img x y)
+(define/img (image-pixel/cmya img x y)
+  (check-coords 'image-pixel/cmya img x y)
   (let-location ([c int] [m int] [y int] [a int])
     ((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))
@@ -373 +372 @@
       (imlib-err loc "Cyan, Magenta, Yellow and Alpha values must be between 0 and 255" c m y a)))
 
-(define (imlib:color/rgba r g b a)
-  (check-colorvalues/rgba 'imlib:color/rgba r g b a)
-  (make-imlib:color imlib-context-set-color/rgba r g b a))
-
-(define (imlib:color/cmya c m y a)
-  (check-colorvalues/cmya 'imlib:color/cmya c m y a)
-  (make-imlib:color imlib-context-set-color/cmya c m y a))
-
-(define (imlib:color/hlsa h l s a)
-  (check-colorvalues/hlsa 'imlib:color/hlsa h l s a)
-  (make-imlib:color imlib-context-set-color/hlsa h l s a))
-
-(define (imlib:color/hsva h s v a)
-  (check-colorvalues/hsva 'imlib:color/hsva h s v a)
-  (make-imlib:color imlib-context-set-color/hsva h s v a))
+(define (color/rgba r g b a)
+  (check-colorvalues/rgba 'color/rgba r g b a)
+  (make-color imlib-context-set-color/rgba r g b a))
+
+(define (color/cmya c m y a)
+  (check-colorvalues/cmya 'color/cmya c m y a)
+  (make-color imlib-context-set-color/cmya c m y a))
+
+(define (color/hlsa h l s a)
+  (check-colorvalues/hlsa 'color/hlsa h l s a)
+  (make-color imlib-context-set-color/hlsa h l s a))
+
+(define (color/hsva h s v a)
+  (check-colorvalues/hsva 'color/hsva h s v a)
+  (make-color imlib-context-set-color/hsva h s v a))
 
 (define (context-set-color color)
-  ((imlib:color-setter color) (imlib:color-one color)
-                              (imlib:color-two color)
-                              (imlib:color-three color)
-                              (imlib:color-alpha color)))
+  ((color-setter color) (color-one color)
+                        (color-two color)
+                        (color-three color)
+                        (color-alpha color)))
 
 ;;;
@@ -404 +403 @@
 ;;  without having an exception thrown.
 ;;
-(define/img (imlib:draw-pixel img color x y)
+(define/img (image-draw-pixel img color x y)
   (context-set-color color)
-  (check-coords 'imlib:draw-pixel img x y)
+  (check-coords 'image-draw-pixel img x y)
   ((foreign-lambda updates imlib_image_draw_pixel int int bool) x y #f))
 
-(define/img (imlib:draw-line img color x1 y1 x2 y2)
+(define/img (image-draw-line img color x1 y1 x2 y2)
   (context-set-color color)
   ((foreign-lambda updates imlib_image_draw_line int int int int bool) x1 y1 x2 y2 #f))
 
-(define/img (imlib:draw-rectangle img color x y width height)
+(define/img (image-draw-rectangle img color x y width height)
   (context-set-color color)
   ((foreign-lambda void imlib_image_draw_rectangle int int int int) x y width height))
 
-(define/img (imlib:fill-rectangle img color x y width height)
+(define/img (image-fill-rectangle img color x y width height)
   (context-set-color color)
   ((foreign-lambda void imlib_image_fill_rectangle int int int int) x y width height))
@@ -503 +502 @@
 (define (imlib-context-set-color/cmya c m y a)
    ((foreign-lambda void imlib_context_set_color_cmya int int int int) c m y a))
+)