;;; epeg.scm
;
; Copyright (c) 2004-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.

(module epeg
  (image? image-open image-close image-size image-size-set!
   image-bounds-set! image-colorspace image-colorspace-set!
   image-encode
   image-comment image-comment-set! image-thumbnail-info
   image-comment-enable image-comment-disable
   image-quality-set! image-file-output-set! image-trim
   colorspace-gray8 colorspace-yuv8 colorspace-rgb8
   colorspace-bgr8 colorspace-rgba8 colorspace-bgra8
   colorspace-argb32 colorspace-cmyk)

(import chicken scheme foreign)

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

(define-foreign-type image (c-pointer "Epeg_Image"))

(define-record image ptr)

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

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

(define-syntax define/img
  (syntax-rules ()
    ((define/img (?func ?img ?args ...)
       ?body ...)
     (define (?func ?img ?args ...)
       (assert-image ?img (quote ?func) ?args ...)
       ?body ...))))

(define (image-open filename)
  (let ((img ((foreign-lambda image epeg_file_open c-string) filename)))
	(if img
	    (set-finalizer! (make-image img) gc-image)
	    (epeg-err 'image-open "cannot open file" (list filename)))))

(define (gc-image img)
  (let ((ptr (image-ptr img)))
    (if ptr
	((foreign-lambda void epeg_close image) ptr))))

(define/img (image-close img)
  ((foreign-lambda void epeg_close image) (image-ptr img))
  (image-ptr-set! img #f))

(define/img (image-size img)
  (let-location ([width int] [height int])
    ((foreign-lambda void epeg_size_get image (c-pointer int) (c-pointer int)) (image-ptr img) (location width) (location height))
    (values width height)))

(define/img (image-size-set! img width height)
  ((foreign-lambda void epeg_decode_size_set image int int) (image-ptr img) width height))

(define/img (image-bounds-set! img x y width height)
  ((foreign-lambda void epeg_decode_bounds_set image int int int int) (image-ptr img) x y width height))

; From the Chicken manual.  Why isn't this extremely useful macro in
; Chicken by default?
(define-syntax define-foreign-enum
  (syntax-rules ()
    ((define-foreign-enum)
     (void))
    ((define-foreign-enum (?name ?realname) ?rest ...)
     (begin
       (define-foreign-variable foo int ?realname)
       (define ?name foo) ;; Workaround - directly exporting foo doesn't work
       (define-foreign-enum ?rest ...)))
    ((define-foreign-enum
       ?name
       ?rest ...)
     (begin
       (define-foreign-variable ?name int)
       (define-foreign-enum ?rest ...)))))

(define-foreign-type colorspace (enum "_Epeg_Colorspace"))
(define-foreign-enum
  (colorspace-gray8 "EPEG_GRAY8")
  (colorspace-yuv8 "EPEG_YUV8")
  (colorspace-rgb8 "EPEG_RGB8")
  (colorspace-bgr8 "EPEG_BGR8")
  (colorspace-rgba8 "EPEG_RGBA8")
  (colorspace-bgra8 "EPEG_BGRA8")
  (colorspace-argb32 "EPEG_ARGB32")
  (colorspace-cmyk "EPEG_CMYK"))

;;
;; Actually, the integer argument is an (enum Epeg_Colorspace), but the
;; header doesn't list it(!) and the C file uses a raw int ptr.
;; It is in the Doxygen file, so we can assume it may be used nonetheless.
;;
(define/img (image-colorspace img)
  (let-location ([space int])
    ((foreign-lambda void epeg_colorspace_get image (c-pointer int)) (image-ptr img) (location space))
    space))

(define/img (image-colorspace-set! img space)
  ((foreign-lambda void epeg_decode_colorspace_set image colorspace) (image-ptr img) space))

(define/img (image-encode img)
  (not ((foreign-lambda bool epeg_encode image) (image-ptr img))))

(define memerr? (foreign-lambda* bool ()
		  "return (errno == ENOMEM);"))

;;
;; This code doesn't work.  We should really be able to calculate the bounds
;;  of an image and check if they're correct.  The implementation of an
;;  Epeg_Image is hidden, so we can't access it ourselves.
;;
#;(define sizeerr? (foreign-lambda* bool ([image im] [int x] [int y] [int w] [int h])
  "if (im == NULL)
    return (0);
  if ((x + w) > im->out.w)
    w = im->out.w - x;
  if ((y + h) > im->out.h)
    h = im->out.h - y;
  if (x < 0)
    w += x;
  if (y < 0)
    h += y;
  return ((w < 1) || (h < 1));"))
(define (sizeerr? . args) #f)

;; pixel query functions are unsafe.  They return a const void * which
;; must be freed with epeg_pixels_free, BEFORE epeg_close is called on the
;; image.  This freeing can be taken care of by attaching a list of pixel
;; info blocks to the 'image' structure which is freed upon close.
;; The real question is, how to deal with this data in a safe and
;; userfriendly way?
#;(define (pixels-get-caller pixels-get-func loc im x y w h)
  (or (pixels-get-func im x y w h)
      (abort 
	(make-composite-condition
	  (cond
	    ((memerr?)
	       (make-property-condition 'exn 'memory
					'location loc
					'message "out of memory"
					'arguments (list im x y w h)))
	    ((sizeerr? im x y w h)
	       (make-property-condition 'exn 'bounds
					'location loc
					'message "wrong image dimensions"
					'arguments (list im x y w h)))
	    (else
	      (make-property-condition 'exn 'runtime
				       'location loc
				       'message "cannot decode image data"
				       'arguments (list im x y w h)))
	  (make-property-condition 'epeg))))))

#;(define/img (image-pixels-get img x y width height)
  (pixels-get-caller
   (foreign-lambda* (const c-pointer) ([image im]
				       [int x]
				       [int y]
				       [int w]
				       [int h])
		    "errno = 0;
                     return (epeg_pixels_get(im, x, y, w, h));")
   'image-pixels-get
   (image-ptr img) x y width height))

#;(define/img (image-pixels-get-as-RGB8 img x y width height)
  (pixels-get-caller
   (foreign-lambda* (const c-pointer) ([image im]
				       [int x]
				       [int y]
				       [int w]
				       [int h])
		    "errno = 0;
                     return (epeg_pixels_get_as_RGB8(im, x, y, w, h));")
   'image-pixels-get-as-RGB8
   (image-ptr img) x y width height))

#;(define/img (image-pixels-free img pixels)
  ((foreign-lambda void epeg_pixels_free image c-pointer) (image-ptr img) pixels))

; Unused
;(define-foreign-type epeg-thumbnail-info (c-pointer "Epeg_Thumbnail_Info"))

(define/img (image-thumbnail-info img)
  (let ([thc-get
	  (foreign-lambda* void ([image im]
				 [(c-pointer c-string) uri]
				 [(c-pointer int) width]
				 [(c-pointer int) height]
				 [(c-pointer c-string) mimetype])
	    "Epeg_Thumbnail_Info nfo;
	    epeg_thumbnail_comments_get(im, &nfo);
	    *uri = nfo.uri;
	    *width = nfo.w;
	    *height = nfo.h;
	    *mimetype = nfo.mimetype;")])
    (let-location ([uri c-string] [width int] [height int] [mimetype c-string])
      (thc-get
        (image-ptr img)
        (location uri)
        (location width)
        (location height)
        (location mimetype))
      (values uri width height mimetype))))

(define/img (image-comment-enable img)
  ((foreign-lambda void epeg_thumbnail_comments_enable image bool) (image-ptr img) #t))

(define/img (image-comment-disable img)
  ((foreign-lambda void epeg_thumbnail_comments_enable image bool) (image-ptr img) #f))

(define/img (image-comment img)
  ((foreign-lambda c-string epeg_comment_get image) (image-ptr img)))

(define/img (image-comment-set! img string)
  ((foreign-lambda void epeg_comment_set image c-string) (image-ptr img) string))

; Integer values between 0 and 100
(define/img (image-quality-set! img qual)
  ((foreign-lambda void epeg_quality_set image int) (image-ptr img) qual))

(define/img (image-file-output-set! img file)
  ((foreign-lambda void epeg_file_output_set image c-string) (image-ptr img) file))

;
; Not really useful and perhaps a bit dangerous in Scheme
;
#;(define/img (image-memory-output-set! img ptr size)
  ((foreign-lambda void epeg_memory_output_set image
		        (c-pointer byte-vector) (c-pointer int))
   (image-ptr img) ptr size))

#;(define (image-memory-open data size)
  (let ((img ((foreign-lambda image epeg_memory_open byte-vector int) data size)))
    (if img
	(set-finalizer! (make-image img) gc-image)
	(abort
	 (make-composite-condition
	  (make-property-condition  'exn 'memory		; Is this ok?
				    'location 'epeg-memory-open
				    'message "cannot open image from memory"
				    'arguments (list data size))
	  (make-property-condition 'epeg))))))

;
; Badly documented, no idea what it does.
;
(define/img (image-trim img)
  (not ((foreign-lambda bool epeg_trim image) (image-ptr img))))
)