;;; 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
;;;
;
; Copyright (c) 2005-2011 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-get-data-for-reading-only image-alpha? image-alpha-set!
   image-track-changes-on-disk image-create-using-copied-data
   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-blend image-blend!
   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-draw-text
   image-fill-rectangle image-draw-ellipse image-fill-ellipse
   font-load make-image image-ptr gc-collect-image)

(import scheme)
(import (chicken base))
(import (chicken foreign))
(import (chicken format))
(import (chicken condition))
(import (chicken gc))
(import foreigners)

(declare (disable-interrupts))

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

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

(define-foreign-type image	c-pointer)
(define-foreign-type updates	c-pointer)
(define-foreign-type context	c-pointer)
(define-foreign-type font       c-pointer)

(define-foreign-enum-type (text-direction int)
  (text-direction->int int->text-direction)
  ((to-right text-direction/to-right) IMLIB_TEXT_TO_RIGHT)
  ((to-left text-direction/to-left)   IMLIB_TEXT_TO_LEFT)
  ((to-down text-direction/to-down )  IMLIB_TEXT_TO_DOWN)
  ((to-up text-direction/to-up)       IMLIB_TEXT_TO_UP)
  ((to-angle text-direction/to-angle) IMLIB_TEXT_TO_ANGLE))

(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-image)
	  (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)
              ((foreign-lambda* void ((image img) (int width) (int height))
                 "imlib_context_set_image(img);\n"
                 "DATA32* data = imlib_image_get_data();\n"
                 "memset(data, 0, 4 * width * height);\n"
                 "imlib_image_put_back_data(data);\n")
               (image-ptr img) width height)
	      (set-finalizer! img gc-collect-image))))))

(define (gc-collect-image 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!)

(define (image-blend! img src-img #!key 
		      (merge-alpha #t)
		      (src-x 0)
		      (src-y 0)
		      (src-width (image-width src-img))
		      (src-height (image-height src-img))
		      (dest-x 0)
		      (dest-y 0)
		      (dest-width (image-width src-img))
		      (dest-height (image-height src-img)))
  
  (for-each (cut assert-image <> 'image-blend merge-alpha
		 src-x src-y src-width src-height 
		 dest-x dest-y dest-width dest-height)
	    (list img src-img))

  (imlib-context-set-image (image-ptr img))

  ((foreign-lambda void imlib_blend_image_onto_image image bool int int int int int int int int)
   (image-ptr src-img) merge-alpha src-x src-y
   src-width src-height dest-x
   dest-y dest-width dest-height))

(define/clone image-blend image-blend!)

;; imlib_image_get_data
;; imlib_image_put_back_data

(define/img (image-get-data-for-reading-only img)
  ((foreign-lambda c-pointer imlib_image_get_data_for_reading_only)))

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

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

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

(define (image-create-using-copied-data width height ptr)
  (set-finalizer! (make-image
                   ((foreign-lambda image imlib_create_image_using_copied_data int int c-pointer)
                    width height ptr))
                  gc-collect-image))

(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]
					   [(c-pointer int) r]
					   [(c-pointer int) g]
					   [(c-pointer int) b]
					   [(c-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)))

;;;
;;; Font functions
;;;

(define (font-load filename size)
  (set-finalizer!
   (make-font ((foreign-lambda font imlib_load_font c-string) (format "~A/~A" filename size)))
   (lambda (font)
     (let ((old-font (imlib-context-get-font)))
       (imlib-context-set-font (font-ptr font))
       ((foreign-lambda void imlib_free_font))
       (and old-font (imlib-context-set-font old-font))))))


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

(define/img (image-draw-ellipse img color xc yc a b)
  (context-set-color color)
  ((foreign-lambda void imlib_image_draw_ellipse int int int int) xc yc a b))

(define/img (image-fill-ellipse img color xc yc a b)
  (context-set-color color)
  ((foreign-lambda void imlib_image_fill_ellipse int int int int) xc yc a b))

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


; Text drawing functions

(define (context-set-font font)
  (imlib-context-set-font (font-ptr font)))


;; we can't use define/img here because of #!optional until ticket #277 if fixed
(define (image-draw-text img font color x y text #!optional (direction 'to-right) (angle #f))
  (assert-image img 'image-draw-text font color x y text direction)
  (imlib-context-set-image (image-ptr img))
  (context-set-font font)
  (context-set-color color)
  (imlib-context-set-direction direction)
  (when angle (imlib-context-set-angle angle))
  ((foreign-lambda void imlib_text_draw int int c-string) x y text))


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

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

(define (imlib-context-set-direction d)
  ((foreign-lambda void imlib_context_set_direction text-direction) d))

(define (imlib-context-get-direction d)
  ((foreign-lambda text-direction imlib_context_get_direction)))

(define (imlib-context-set-font f)
  ((foreign-lambda void imlib_context_set_font font) f))

(define (imlib-context-get-font)
  ((foreign-lambda font imlib_context_get_font)))

(define (imlib-context-set-angle a)
  ((foreign-lambda void imlib_context_set_angle double) a))

)