diff options
| -rw-r--r-- | chickadee/image/png.scm | 160 |
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))))))) |