Add libpng bindings for writing PNG files.

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