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

;;; imlib2.scm
;
;;; XXX: For some odd reason, imlib2_conv axe.png axe.gif won't work (with
;;; libungif)!  So of course we don't convert it either.
;;;
;;; XXX TODO: Color_Modifier functions
;;;
;
; Version 0.7
;
; Copyright (c) 2005-2008 Peter Bex (Peter.Bex@xs4all.nl)
; All rights reserved.
; 
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
; 1. Redistributions of source code must retain the above copyright
;    notice, this list of conditions and the following disclaimer.
; 2. Redistributions in binary form must reproduce the above copyright
;    notice, this list of conditions and the following disclaimer in the
;    documentation and/or other materials provided with the distribution.
; 3. Neither the name of Peter Bex nor the names of any contributors may
;    be used to endorse or promote products derived from this software
;    without specific prior written permission.
; 
; THIS SOFTWARE IS PROVIDED BY PETER BEX AND CONTRIBUTORS ``AS IS'' AND ANY
; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
; DISCLAIMED.  IN NO EVENT SHALL THE FOUNDATION OR CONTRIBUTORS BE LIABLE
; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
; SUCH DAMAGE.
;
;; XXX The bools in the C interface are really all chars

(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)
(cond-expand (with-x
              (foreign-declare "#include <X11/Xlib.h>"))
             (else))

(foreign-declare "#include <Imlib2.h>") 

(define-record image ptr)
(define-record color setter one two three alpha)

(define-foreign-type image      c-pointer)
(define-foreign-type updates    c-pointer)
(define-foreign-type context    c-pointer)
(cond-expand (with-x
              (define-foreign-type visual       (c-pointer "Visual")))
             (else))

(define-syntax define-foreign-enum&string
  (syntax-rules ()
    ((define-foreign-enum&string alist-name (name string) ...)
       (begin
         (define-foreign-variable name int) ...
         (define alist-name `((,name . string) ...))))))

(define-foreign-type imlib-load-error (enum "_imlib_load_error"))
(define-foreign-enum&string load-errors
  (IMLIB_LOAD_ERROR_NONE "No error!  Guess imlib was wrong :)")
  (IMLIB_LOAD_ERROR_FILE_DOES_NOT_EXIST "File does not exist")
  (IMLIB_LOAD_ERROR_FILE_IS_DIRECTORY "File is a directory")
  (IMLIB_LOAD_ERROR_PERMISSION_DENIED_TO_READ "No read permissions")
  (IMLIB_LOAD_ERROR_NO_LOADER_FOR_FILE_FORMAT "No loader for format")
  (IMLIB_LOAD_ERROR_PATH_TOO_LONG "Path too long")
  (IMLIB_LOAD_ERROR_PATH_COMPONENT_NON_EXISTANT "Path component nonexistent")
  (IMLIB_LOAD_ERROR_PATH_COMPONENT_NOT_DIRECTORY "Path component is not a directory")
  (IMLIB_LOAD_ERROR_PATH_POINTS_OUTSIDE_ADDRESS_SPACE "Path points outside address space (pointer error!)")
  (IMLIB_LOAD_ERROR_TOO_MANY_SYMBOLIC_LINKS "Too many symbolic links")
  (IMLIB_LOAD_ERROR_OUT_OF_MEMORY "Out of memory")
  (IMLIB_LOAD_ERROR_OUT_OF_FILE_DESCRIPTORS "Out of file descriptors")
  (IMLIB_LOAD_ERROR_PERMISSION_DENIED_TO_WRITE "No permission to write")
  (IMLIB_LOAD_ERROR_OUT_OF_DISK_SPACE "Out of diskspace")
  (IMLIB_LOAD_ERROR_UNKNOWN "Unknown error"))

(define (load-error->message err)
  (let ((match (assoc err load-errors)))        ; assoc, assq or assv?
    (if match
        (cdr match)
        "Unknown API error! (this is seriously FUBAR)")))

(define (imlib-err loc msg . args)
  (abort (make-composite-condition
           (make-property-condition 'exn
                                    'location loc
                                    'message msg
                                    'arguments args)
           (make-property-condition 'imlib))))

;;;
;;; Image functions
;;;

;; Internal convenience macros
(define (assert-image img loc . args)
  (when (not (image-ptr img))
    (imlib-err loc "Invalid image parameter" args)))

(define-syntax define/img
  (syntax-rules ()
    ((define/img (func img arg ...)
       body ...)
     (define (func img arg ...)
       (assert-image img (quote func) arg ...)
       (imlib-context-set-image (image-ptr img))
       body ...))))

(define (image-load filename)
  (let-location ([err int])  ; int should really be imlib-load-error
    (let* ((load-image (foreign-lambda  image
                                        imlib_load_image_with_error_return
                                        c-string
                                        (c-pointer imlib-load-error)))
           (image (load-image filename (location err))))
      (if (= err IMLIB_LOAD_ERROR_NONE)
          (set-finalizer! (make-image image) gc-collect)
          (abort 
            (make-composite-condition
              (make-property-condition  'exn 'i/o 'file
                                        'location 'image-load
                                        'message (load-error->message err)
                                        'arguments (list filename))
              (make-property-condition 'imlib)))))))

(define/img (image-save img filename)
  (let-location ([err int])  ; int should really be imlib-load-error
    ((foreign-lambda  void
                     imlib_save_image_with_error_return
                     c-string
                     ; Yes, LOAD error...
                     (c-pointer imlib-load-error)) filename (location err))
    (if (= err IMLIB_LOAD_ERROR_NONE)
        img  ; That's more convenient than (void)
        (abort 
          (make-composite-condition
            (make-property-condition 'exn 'i/o 'file
                                     'location 'image-save
                                     'message (load-error->message err)
                                     'arguments (list filename))
            (make-property-condition 'imlib))))))

;;
;; Create a new image, completely transparent.
;;
(define (image-create width height)
  (if (or (< width 0) (< height 0))
      (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 'image-create "Could not create new image" (list width height))
            (begin
              (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 (image-ptr img))
          ((foreign-lambda void imlib_free_image))
          (imlib-context-set-image old))))

(define/img (image-destroy img)
  ((foreign-lambda void imlib_free_image))
  (image-ptr-set! img #f))

(define/img (image-format-set! img format)
  ((foreign-lambda void imlib_image_set_format c-string) format))

(define/img (image-format img)
  ((foreign-lambda c-string imlib_image_format)))

(define/img (image-width img)
  ((foreign-lambda int imlib_image_get_width)))

(define/img (image-height img)
  ((foreign-lambda int imlib_image_get_height)))

(define/img (image-filename img)
  ((foreign-lambda c-string imlib_image_get_filename)))

; We could define this to automatically append the bang, but this makes
; the code even less easy to read.
(define-syntax define/clone
  (syntax-rules ()
    ((define/clone ?name ?name!)
     (define (?name img . args)
       (let ((new-img (image-clone img)))
         (apply ?name! new-img args)
         new-img)))))

(define/img (image-flip-horizontal! img)
  ((foreign-lambda void imlib_image_flip_horizontal)))
(define/clone image-flip-horizontal image-flip-horizontal!)

(define/img (image-flip-vertical! img)
  ((foreign-lambda void imlib_image_flip_vertical)))
(define/clone image-flip-vertical image-flip-horizontal!)

(define/img (image-flip-diagonal! img)
  ((foreign-lambda void imlib_image_flip_diagonal)))
(define/clone image-flip-diagonal image-flip-diagonal!)

(define/img (image-orientate! img orientation)
  (if (or (< orientation 0) (> orientation 7))
      (imlib-err 'image-orientate
                 "Orientation must be between 0 and 7 inclusive"
                 (list orientation))
      ((foreign-lambda void imlib_image_orientate int) orientation)))
(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 image-sharpen image-sharpen!)

(define/img (image-blur! img radius)
  (if (< radius 0)
      (imlib-err 'image-blur "Radius cannot be less than 0" (list radius))
      ((foreign-lambda void imlib_image_blur int) radius)))
(define/clone image-blur image-blur!)

(define/img (image-tile-horizontal! img)
  ((foreign-lambda void imlib_image_tile_horizontal)))
(define/clone image-tile-horizontal image-tile-horizontal!)

(define/img (image-tile-vertical! img)
  ((foreign-lambda void imlib_image_tile_vertical)))
(define/clone image-tile-vertical image-tile-vertical!)

(define/img (image-tile! img)
  ((foreign-lambda void imlib_image_tile)))
(define/clone image-tile image-tile!)

;; imlib_image_get_data
;; imlib_image_get_data_for_reading_only
;; imlib_image_put_back_data

(define/img (image-alpha? img)
  ((foreign-lambda bool imlib_image_has_alpha)))

(define/img (image-alpha-set! img val)
  ((foreign-lambda void imlib_image_set_has_alpha bool) val))

(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 (image-crop img x y width height)
  (set-finalizer!
   (make-image
    ((foreign-lambda image imlib_create_cropped_image int int int int)
     x y width height))
   gc-collect))

(define/img (image-crop&scale img src-x src-y src-width src-height dest-width dest-height)
  (set-finalizer!
   (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))
   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)
  (or ((foreign-lambda image imlib_clone_image))
      (imlib-err 'imlib-clone-image "Could not clone image")))

(define (check-coords loc img x y)
  (let ((width  (image-width img))
        (height (image-height img))
        (fail   (lambda (msg)
                  (imlib-err loc msg (list x y)))))
    (cond
      ((or (>= x width)  (< x 0)) (fail "X coordinate out of range"))
      ((or (>= y height) (< y 0)) (fail "Y coordinate out of range")))))

(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]
                                           [(pointer int) r]
                                           [(pointer int) g]
                                           [(pointer int) b]
                                           [(pointer int) a])
                      "Imlib_Color col;
                       imlib_image_query_pixel(x, y, &col);
                       *r = col.red;
                       *g = col.green;
                       *b = col.blue;
                       *a = col.alpha;")))
    (let-location ([r int] [g int] [b int] [a int])
      (query-func x y (location r) (location g) (location b) (location a))
      (values r g b a))))

(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 (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 (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))
    (values c m y a)))

;;;
;;; Color functions
;;;
(define (check-colorvalues/rgba loc r g b a)
  (if (or (< r 0) (> r 255)
          (< g 0) (> g 255)
          (< b 0) (> b 255)
          (< a 0) (> a 255))
      (imlib-err loc "Red, Green, Blue and Alpha values must be between 0 and 255" r g b a)))

(define (check-colorvalues/hsva loc h s v a)
  (cond
    ((or (< h 0) (> h 360)) (imlib-err loc "Hue must be between 0 and 360" h s v a))
    ((or (< s 0) (> s 1))   (imlib-err loc "Saturation must be between 0 and 1" h s v a))
    ((or (< v 0) (> v 1))   (imlib-err "Value must be between 0 and 1" h s v a))
    ((or (< a 0) (> a 255)) (imlib-err "Alpha must be between 0 and 255" h s v a))))

(define (check-colorvalues/hlsa loc h l s a)
  (cond
    ((or (< h 0) (> h 360)) (imlib-err loc "Hue must be between 0 and 360" h l s a))
    ((or (< l 0) (> l 1))   (imlib-err loc "Lightness must be between 0 and 1" h l s a))
    ((or (< s 0) (> s 1))   (imlib-err loc "Saturation must be between 0 and 1" h l s a))
    ((or (< a 0) (> a 255)) (imlib-err loc "Alpha must be between 0 and 255" h l s a))))

(define (check-colorvalues/cmya loc c m y a)
  (if (or (< c 0) (> c 255)
          (< m 0) (> m 255)
          (< y 0) (> y 255)
          (< a 0) (> a 255))
      (imlib-err loc "Cyan, Magenta, Yellow and Alpha values must be between 0 and 255" c m y 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)
  ((color-setter color) (color-one color)
                        (color-two color)
                        (color-three color)
                        (color-alpha color)))

;;;
;;; Drawing functions
;;;

;;
;; No bounds checking on most of these functions.  You should be able to
;;  draw a rectangle or ellipse that has a small part outside the image,
;;  without having an exception thrown.
;;
(define/img (image-draw-pixel img color x y)
  (context-set-color color)
  (check-coords 'image-draw-pixel img x y)
  ((foreign-lambda updates imlib_image_draw_pixel int int bool) x y #f))

(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 (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 (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))

; XXX: TODO: imlib_clip_line, imlib_image_copy_alpha_(rectangle_)to_image
;            imlib_image_scroll_rect, imlib_image_copy_rect,
;            imlib_image_draw_ellipse, imlib_image_fill_ellipse
;
; Polygon drawing functions

;;;
;;; Lame context functions.  Not all are used, this will give warnings.
;;; I just played around with them for a bit.  Eventually they'll all either
;;; be used or removed.
;;;
(define imlib-context-pop
  (foreign-lambda void imlib_context_pop))

(define imlib-context-push
  (foreign-lambda void imlib_context_push context))

;;
;; XXX: Imlib2 doesn't do any check on the context-stack's underlying context.
;;  If it is NULL, this will segfault.
;;
(define imlib-context-free
  (foreign-lambda void imlib_context_free context))

;;
;; XXX: Imlib2 doesn't do any error checking on malloc in this function,
;;  and dereferences the resulting pointer.  There's currently nothing we
;;  can do to prevent a segfault in an out of memory situation.
;;
(define imlib-context-new
  (foreign-lambda context imlib_context_new))

(define imlib-context-set-image
  (foreign-lambda void imlib_context_set_image image))

(define imlib-context-get-image
  (foreign-lambda image imlib_context_get_image))

(cond-expand (with-x
              (define imlib-context-set-visual
                (foreign-lambda void imlib_context_set_visual visual)))
             (else))

(define imlib-context-set-cliprect
  (foreign-lambda void imlib_context_set_cliprect int int int int))

(define imlib-context-set-dither-mask
  (foreign-lambda void imlib_context_set_dither_mask bool))

(define imlib-context-get-dither-mask
  (foreign-lambda bool imlib_context_get_dither_mask))

(define imlib-context-set-dither
  (foreign-lambda void imlib_context_set_dither bool))

(define imlib-context-get-dither
  (foreign-lambda bool imlib_context_get_dither))

(define imlib-context-set-anti-alias
  (foreign-lambda void imlib_context_set_anti_alias bool))

(define imlib-context-get-anti-alias
  (foreign-lambda bool imlib_context_get_anti_alias))

(define imlib-context-set-blend
  (foreign-lambda void imlib_context_set_blend bool))

(define imlib-context-get-blend
  (foreign-lambda bool imlib_context_get_blend))

(define (imlib-context-set-color/rgba r g b a)
  ((foreign-lambda void imlib_context_set_color int int int int) r g b a))

(define (imlib-context-set-color/hsva h s v a)
  ((foreign-lambda void imlib_context_set_color_hsva float float float int)
     h s v a))

(define (imlib-context-set-color/hlsa h l s a)
  ((foreign-lambda void imlib_context_set_color_hlsa float float float int) h l s a))

(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))
)