summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/image/png.scm160
1 files changed, 157 insertions, 3 deletions
diff --git a/chickadee/image/png.scm b/chickadee/image/png.scm
index 938dede..1d6d723 100644
--- a/chickadee/image/png.scm
+++ b/chickadee/image/png.scm
@@ -29,7 +29,8 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (system foreign)
- #:export (load-png))
+ #:export (load-png
+ save-png))
;;;
@@ -49,6 +50,16 @@
(define PNG_COLOR_TYPE_RGB_ALPHA (logior PNG_COLOR_MASK_COLOR PNG_COLOR_MASK_ALPHA))
(define PNG_COLOR_TYPE_GRAY_ALPHA PNG_COLOR_MASK_ALPHA)
+(define PNG_COMPRESSION_TYPE_BASE 0)
+(define PNG_COMPRESSION_TYPE_DEFAULT PNG_COMPRESSION_TYPE_BASE)
+
+(define PNG_FILTER_TYPE_BASE 0)
+(define PNG_FILTER_TYPE_DEFAULT PNG_FILTER_TYPE_BASE)
+
+(define PNG_INTERLACE_NONE 0)
+(define PNG_INTERLACE_ADAM7 1)
+(define PNG_INTERLACE_LAST 2)
+
;;;
;;; Low-level bindings
@@ -71,15 +82,24 @@
(define-foreign png-create-read-struct
'* "png_create_read_struct" '(* * * *))
+(define-foreign png-create-write-struct
+ '* "png_create_write_struct" '(* * * *))
+
(define-foreign png-destroy-read-struct
void "png_destroy_read_struct" '(* * *))
+(define-foreign png-destroy-write-struct
+ void "png_destroy_write_struct" '(* * *))
+
(define-foreign png-create-info-struct
'* "png_create_info_struct" '(*))
(define-foreign png-set-read-fn
void "png_set_read_fn" '(* * *))
+(define-foreign png-set-write-fn
+ void "png_set_write_fn" '(* * * *))
+
(define-foreign png-set-sig-bytes
void "png_set_sig_bytes" (list '* int))
@@ -104,6 +124,21 @@
(define-foreign png-get-bit-depth
int8 "png_get_bit_depth" '(* *))
+(define-foreign png-set-ihdr
+ void "png_set_IHDR" (list '* '* uint32 uint32 int int int int int))
+
+(define-foreign png-write-info
+ void "png_write_info" '(* *))
+
+(define-foreign png-write-image
+ void "png_write_image" '(* *))
+
+(define-foreign png-write-row
+ void "png_write_row" '(* *))
+
+(define-foreign png-write-end
+ void "png_write_end" '(* *))
+
;;;
;;; High-level bindings
@@ -115,6 +150,12 @@
(define-wrapped-pointer-type <png-read-struct> png-read-struct?
wrap-png-read-struct unwrap-png-read-struct display-png-read-struct)
+(define (display-png-write-struct handle port)
+ (display "#<png-write-struct>" port))
+
+(define-wrapped-pointer-type <png-write-struct> png-write-struct?
+ wrap-png-write-struct unwrap-png-write-struct display-png-write-struct)
+
(define (display-png-info-struct handle port)
(display "#<png-info-struct>" port))
@@ -138,8 +179,28 @@
"could not create png read struct"))
(wrap-png-read-struct ptr))))
-(define (create-info-struct read-struct)
- (let ((ptr (png-create-info-struct (unwrap-png-read-struct read-struct))))
+(define (create-write-struct file-name)
+ (define (on-error read-struct message)
+ (format (current-error-port) "libpng error: ~a: ~a\n"
+ file-name (pointer->string message)))
+ (define (on-warning read-struct message)
+ (format (current-error-port) "libpng warning: ~a: ~a\n"
+ file-name (pointer->string message)))
+ (let ((ptr (png-create-write-struct (string->pointer %libpng-version)
+ %null-pointer
+ (procedure->pointer void on-error '(* *))
+ (procedure->pointer void on-warning '(* *)))))
+ (if (null-pointer? ptr)
+ (raise-exception
+ (make-exception-with-message
+ "could not create png write struct"))
+ (wrap-png-write-struct ptr))))
+
+(define (create-info-struct png-struct)
+ (let ((ptr (png-create-info-struct
+ (if (png-read-struct? png-struct)
+ (unwrap-png-read-struct png-struct)
+ (unwrap-png-write-struct png-struct)))))
(if (null-pointer? ptr)
(raise-exception
(make-exception-with-message
@@ -151,6 +212,11 @@
(unwrap-png-info-struct info-struct)
%null-pointer))
+(define (destroy-write-struct write-struct info-struct)
+ (png-destroy-write-struct (unwrap-png-write-struct write-struct)
+ (unwrap-png-info-struct info-struct)
+ %null-pointer))
+
(define (image-width read-struct info-struct)
(png-get-image-width (unwrap-png-read-struct read-struct)
(unwrap-png-info-struct info-struct)))
@@ -183,12 +249,65 @@
%null-pointer
func-ptr))
+(define (set-write-function! write-struct write-func-ptr flush-func-ptr)
+ (png-set-write-fn (unwrap-png-write-struct write-struct)
+ %null-pointer
+ write-func-ptr
+ flush-func-ptr))
+
+(define (color-type->int type)
+ (case type
+ ((gray) PNG_COLOR_TYPE_GRAY)
+ ((gray-alpha) PNG_COLOR_TYPE_GRAY_ALPHA)
+ ((palette) PNG_COLOR_TYPE_PALETTE)
+ ((rgb) PNG_COLOR_TYPE_RGB)
+ ((rgba) PNG_COLOR_TYPE_RGB_ALPHA)))
+
+(define (interlace-method->int method)
+ (case method
+ ((none) PNG_INTERLACE_NONE)
+ ((adam7) PNG_INTERLACE_ADAM7)))
+
+(define (compression-method->int method)
+ (case method
+ ((default) PNG_COMPRESSION_TYPE_DEFAULT)))
+
+(define (filter-method->int method)
+ (case method
+ ((default) PNG_FILTER_TYPE_DEFAULT)))
+
+(define* (set-ihdr write-struct info-struct width height #:key
+ (bit-depth '8)
+ (color-type 'rgba)
+ (interlace-method 'none)
+ (compression-method 'default)
+ (filter-method 'default))
+ (png-set-ihdr (unwrap-png-write-struct write-struct)
+ (unwrap-png-info-struct info-struct)
+ width height bit-depth
+ (color-type->int color-type)
+ (interlace-method->int interlace-method)
+ (compression-method->int compression-method)
+ (filter-method->int filter-method)))
+
(define (read-png read-struct info-struct)
(png-read-png (unwrap-png-read-struct read-struct)
(unwrap-png-info-struct info-struct)
PNG_TRANSFORM_EXPAND
%null-pointer))
+(define (write-info write-struct info-struct)
+ (png-write-info (unwrap-png-write-struct write-struct)
+ (unwrap-png-info-struct info-struct)))
+
+(define (write-row write-struct bv)
+ (png-write-row (unwrap-png-write-struct write-struct)
+ (bytevector->pointer bv)))
+
+(define (write-end write-struct info-struct)
+ (png-write-end (unwrap-png-write-struct write-struct)
+ (unwrap-png-info-struct info-struct)))
+
(define (png-header? header)
(zero? (png-sig-cmp (bytevector->pointer header) 0 8)))
@@ -392,3 +511,38 @@
(make-exception (make-external-error)
(make-exception-with-message
(string-append "file not found: " file-name))))))
+
+(define (make-png-writer port)
+ (values (procedure->pointer void
+ (lambda (write-struct ptr length)
+ (let ((bv (pointer->bytevector ptr length)))
+ (put-bytevector port bv 0 length)))
+ (list '* '* size_t))
+ (procedure->pointer void
+ (lambda (write-struct)
+ (force-output port))
+ (list '*))))
+
+(define (save-png pixels width height file-name)
+ (call-with-output-file file-name
+ (lambda (port)
+ (let* ((write-struct (create-write-struct file-name))
+ (info-struct (create-info-struct write-struct))
+ (row-size (* width 4))
+ (row (make-bytevector row-size)))
+ (dynamic-wind
+ (lambda () #t)
+ (lambda ()
+ (define-values (write-ptr flush-ptr)
+ (make-png-writer port))
+ (set-write-function! write-struct write-ptr flush-ptr)
+ (set-ihdr write-struct info-struct width height)
+ (write-info write-struct info-struct)
+ (let loop ((y 0))
+ (when (< y height)
+ (bytevector-copy! pixels (* y row-size) row 0 row-size)
+ (write-row write-struct row)
+ (loop (+ y 1))))
+ (write-end write-struct info-struct))
+ (lambda ()
+ (destroy-write-struct write-struct info-struct)))))))