Add libpng bindings.

5 files changed, 417 insertions, 0 deletions

diff --git a/Makefile.am b/Makefile.am
index 1ce452d..4dc96a7 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -66,6 +66,7 @@ SOURCES = 					\
   chickadee/audio/wav.scm			\
   chickadee/audio.scm				\
   chickadee/image/jpeg.scm			\
+  chickadee/image/png.scm			\
   chickadee/graphics/gl.scm			\
   chickadee/graphics/engine.scm			\
   chickadee/graphics/color.scm			\
diff --git a/chickadee/config.scm.in b/chickadee/config.scm.in
index 721a6d5..13516dd 100644
--- a/chickadee/config.scm.in
+++ b/chickadee/config.scm.in
@@ -27,6 +27,8 @@
   #:export (dynamic-link*
             %datadir
             %chickadee-version
+            %libpng
+            %libpng-version
             %libturbojpeg
             %libopenal
             %libvorbisfile
@@ -53,6 +55,10 @@
 
 (define %chickadee-version "@PACKAGE_VERSION@")
 
+;; The version of libpng that chickadee was built against.  Used for
+;; initializing libpng.
+(define %libpng-version "@PNG_VERSION@")
+
 ;; When LD_LIBRARY_PATH is set, we *don't* want to use the absolute
 ;; file name of the library that pkgconfig found.  Instead, we want to
 ;; use the library name itself so the search path is used.
@@ -66,6 +72,9 @@
      (else
       '(absolute ...)))))
 
+(define-library-name %libpng
+  ("@PNG_LIBDIR@/libpng")
+  ("libpng"))
 (define-library-name %libturbojpeg
   ("@TURBOJPEG_LIBDIR@/libturbojpeg")
   ("libturbojpeg"))
diff --git a/chickadee/image/png.scm b/chickadee/image/png.scm
new file mode 100644
index 0000000..b6cb3bf
--- /dev/null
+++ b/chickadee/image/png.scm
@@ -0,0 +1,392 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2021 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; Chickadee is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published
+;;; by the Free Software Foundation, either version 3 of the License,
+;;; or (at your option) any later version.
+;;;
+;;; Chickadee is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; PNG image loading.
+;;
+;;; Code:
+
+(define-module (chickadee image png)
+  #:use-module (chickadee config)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 exceptions)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
+  #:use-module (system foreign)
+  #:export (load-png))
+
+
+;;;
+;;; Enums
+;;;
+
+(define PNG_TRANSFORM_IDENTITY 0)
+
+(define PNG_COLOR_MASK_PALETTE 1)
+(define PNG_COLOR_MASK_COLOR 2)
+(define PNG_COLOR_MASK_ALPHA 4)
+
+(define PNG_COLOR_TYPE_GRAY 0)
+(define PNG_COLOR_TYPE_PALETTE (logior PNG_COLOR_MASK_COLOR PNG_COLOR_MASK_PALETTE))
+(define PNG_COLOR_TYPE_RGB PNG_COLOR_MASK_COLOR)
+(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)
+
+
+;;;
+;;; Low-level bindings
+;;;
+
+(define libpng-func
+  (let ((lib (dynamic-link* %libpng)))
+    (lambda (return-type function-name arg-types)
+      (pointer->procedure return-type
+                          (dynamic-func function-name lib)
+                          arg-types))))
+
+(define-syntax-rule (define-foreign name return-type func-name arg-types)
+  (define name
+    (libpng-func return-type func-name arg-types)))
+
+(define-foreign png-sig-cmp
+  int "png_sig_cmp" (list '* size_t size_t))
+
+(define-foreign png-create-read-struct
+  '* "png_create_read_struct" '(* * * *))
+
+(define-foreign png-destroy-read-struct
+  void "png_destroy_read_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-sig-bytes
+  void "png_set_sig_bytes" (list '* int))
+
+(define-foreign png-read-png
+  void "png_read_png" (list '* '* int '*))
+
+(define-foreign png-get-rows
+  '* "png_get_rows" '(* *))
+
+(define-foreign png-get-rowbytes
+  size_t "png_get_rowbytes" '(* *))
+
+(define-foreign png-get-image-width
+  unsigned-int "png_get_image_width" '(* *))
+
+(define-foreign png-get-image-height
+  unsigned-int "png_get_image_height" '(* *))
+
+(define-foreign png-get-color-type
+  int8 "png_get_color_type" '(* *))
+
+(define-foreign png-get-bit-depth
+  int8 "png_get_bit_depth" '(* *))
+
+
+;;;
+;;; High-level bindings
+;;;
+
+(define (display-png-read-struct handle port)
+  (display "#<png-read-struct>" port))
+
+(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-info-struct handle port)
+  (display "#<png-info-struct>" port))
+
+(define-wrapped-pointer-type <png-info-struct> png-info-struct?
+  wrap-png-info-struct unwrap-png-info-struct display-png-info-struct)
+
+(define (on-error read-struct message)
+  (display (current-error-port) message))
+
+(define (on-warning read-struct message)
+  (display (current-error-port) message))
+
+(define (create-read-struct)
+  (let ((ptr (png-create-read-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 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))))
+    (if (null-pointer? ptr)
+        (raise-exception
+         (make-exception-with-message
+          "could not create png info struct"))
+        (wrap-png-info-struct ptr))))
+
+(define (destroy-read-struct read-struct info-struct)
+  (png-destroy-read-struct (unwrap-png-read-struct read-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)))
+
+(define (image-height read-struct info-struct)
+  (png-get-image-height (unwrap-png-read-struct read-struct)
+                        (unwrap-png-info-struct info-struct)))
+
+(define (color-type read-struct info-struct)
+  (png-get-color-type (unwrap-png-read-struct read-struct)
+                      (unwrap-png-info-struct info-struct)))
+
+(define (bit-depth read-struct info-struct)
+  (png-get-bit-depth (unwrap-png-read-struct read-struct)
+                     (unwrap-png-info-struct info-struct)))
+
+(define (bytes-per-row read-struct info-struct)
+  (png-get-rowbytes (unwrap-png-read-struct read-struct)
+                    (unwrap-png-info-struct info-struct)))
+
+(define (rows read-struct info-struct)
+  (png-get-rows (unwrap-png-read-struct read-struct)
+                (unwrap-png-info-struct info-struct)))
+
+(define (set-sig-bytes! read-struct n)
+  (png-set-sig-bytes (unwrap-png-read-struct read-struct) n))
+
+(define (set-read-function! read-struct func-ptr)
+  (png-set-read-fn (unwrap-png-read-struct read-struct)
+                   %null-pointer
+                   func-ptr))
+
+(define (read-png read-struct info-struct)
+  (png-read-png (unwrap-png-read-struct read-struct)
+                (unwrap-png-info-struct info-struct)
+                PNG_TRANSFORM_IDENTITY
+                %null-pointer))
+
+(define (png-header? header)
+  (zero? (png-sig-cmp (bytevector->pointer header) 0 8)))
+
+(define* (dereference-pointer pointer #:optional (offset 0))
+  (make-pointer
+   (bytevector-uint-ref (pointer->bytevector pointer
+                                             (sizeof uintptr_t)
+                                             (* offset (sizeof uintptr_t)))
+                        0
+                        (native-endianness)
+                        (sizeof uintptr_t))))
+
+(define (unpacker color-type bit-depth)
+  ;; 16 bit color channels need to be reduced to an 8 bit value.
+  (define (u16->u8 n)
+    (round (* (/ n 65536) 255)))
+  (cond
+   ((= color-type PNG_COLOR_TYPE_GRAY)
+    (case bit-depth
+      ;; For bit depths of 1, 2, and 4, multiple pixels are stored
+      ;; within a single byte.  So, we need to use some bit shifting
+      ;; magic to extract the grayscale values.  First, we find the
+      ;; byte that contains the pixel.  Then we make a bitmask (using
+      ;; a bit shift to the left) that selects the pixel bits (1, 2,
+      ;; or 4 bits) from within the byte and apply a bitwise AND to
+      ;; zero out the other, irrelevant bits.  To get a value within
+      ;; the target grayscale range, we shift the bits back to the
+      ;; right.  Finally, to arrive at a value for an 8-bit color
+      ;; channel, we scale the value as needed (by 255 for 1 bit
+      ;; grayscale, for example.)
+      ((1)
+       (lambda (row x)
+         (let* ((byte (bytevector-u8-ref row (floor (/ x 8))))
+                (bit (modulo x 8))
+                (gray (* (ash (logand byte (ash #b00000001 bit)) (- bit)) 255)))
+           (values gray gray gray 255))))
+      ((2)
+       (lambda (row x)
+         (let* ((byte (bytevector-u8-ref row (floor (/ x 4))))
+                (bit (* (modulo x 4) 2))
+                (gray (* (ash (logand byte (ash #b00000011 bit)) (- bit)) 85)))
+           (values gray gray gray 255))))
+      ((4)
+       (lambda (row x)
+         (let* ((byte (bytevector-u8-ref row (floor (/ x 2))))
+                (bit (* (modulo x 2) 4))
+                (gray (* (ash (logand byte (ash #b00001111 bit)) (- bit)) 17)))
+           (values gray gray gray 255))))
+      ((8)
+       (lambda (row x)
+         (let ((gray (bytevector-u8-ref row x)))
+           (values gray gray gray 255))))
+      ((16)
+       (lambda (row x)
+         (let* ((offset (* x 2))
+                (gray (u16->u8
+                       (bytevector-u16-ref row offset
+                                           (endianness big)))))
+           (values gray gray gray 255))))))
+   ((= color-type PNG_COLOR_TYPE_PALETTE)
+    ;; TODO: Handle palettes.
+    (raise-exception
+     (make-exception-with-message
+      "PNG images using color palettes are not supported")))
+   ((= color-type PNG_COLOR_TYPE_RGB)
+    (case bit-depth
+      ((8)
+       (lambda (row x)
+         (let ((offset (* x 3)))
+           (values (bytevector-u8-ref row offset)
+                   (bytevector-u8-ref row (+ offset 1))
+                   (bytevector-u8-ref row (+ offset 2))
+                   255))))
+      ((16)
+       (lambda (row x)
+         (let ((offset (* x 6)))
+           ;; PNGs encode 16-bit color data in big endian format.
+           (values (u16->u8
+                    (bytevector-u16-ref row offset
+                                        (endianness big)))
+                   (u16->u8
+                    (bytevector-u16-ref row (+ offset 2)
+                                        (endianness big)))
+                   (u16->u8
+                    (bytevector-u16-ref row (+ offset 4)
+                                        (endianness big)))
+                   255))))))
+   ((= color-type PNG_COLOR_TYPE_RGB_ALPHA)
+    (case bit-depth
+      ((8) #f) ; We can take a convenient shortcut in this case.
+      ((16)
+       (lambda (row x)
+         (let* ((offset (* x 8))
+                (r (u16->u8
+                    (bytevector-u16-ref row offset
+                                        (endianness big))))
+                (g (u16->u8
+                    (bytevector-u16-ref row (+ offset 2)
+                                        (endianness big))))
+                (b (u16->u8
+                    (bytevector-u16-ref row (+ offset 4)
+                                        (endianness big))))
+                (a (u16->u8
+                    (bytevector-u16-ref row (+ offset 6)
+                                        (endianness big)))))
+           (values r g b a))))))
+   ((= color-type PNG_COLOR_TYPE_GRAY_ALPHA)
+    (case bit-depth
+      ((8)
+       (lambda (row x)
+         (let* ((offset (* x 2))
+                (gray (bytevector-u8-ref row offset))
+                (alpha (bytevector-u8-ref row (+ offset 1))))
+           (values gray gray gray alpha))))
+      ((16)
+       (lambda (row x)
+         (let* ((offset (* x 4))
+                (gray (u16->u8
+                       (bytevector-u16-ref row offset
+                                           (endianness big))))
+                (alpha (u16->u8
+                        (bytevector-u16-ref row (+ offset 2)
+                                            (endianness big)))))
+           (values gray gray gray alpha))))))))
+
+(define (make-png-reader port)
+  (procedure->pointer void
+                      (lambda (read-struct ptr length)
+                        (let ((bv (pointer->bytevector ptr length)))
+                          (get-bytevector-n! port bv 0 length)))
+                      (list '* '* size_t)))
+
+(define (load-png file-name)
+  (if (file-exists? file-name)
+      (call-with-input-file file-name
+        (lambda (port)
+          (let* ((read-struct (create-read-struct))
+                 (info-struct (create-info-struct read-struct)))
+            (dynamic-wind
+              (lambda () #t)
+              (lambda ()
+                (unless (png-header? (get-bytevector-n port 8))
+                  (raise-exception
+                   (make-exception (make-external-error)
+                                   (make-exception-with-message
+                                    (string-append "not a PNG file: " file-name)))))
+                ;; Tell libpng that we've already read the header.
+                (set-sig-bytes! read-struct 8)
+                ;; Need to set a custom read function because the
+                ;; libpng default uses file pointers, but here we are
+                ;; with a file port in Scheme land.
+                (set-read-function! read-struct (make-png-reader port))
+                (read-png read-struct info-struct)
+                (let* ((width (image-width read-struct info-struct))
+                       (height (image-height read-struct info-struct))
+                       (color-type (color-type read-struct info-struct))
+                       (bit-depth (bit-depth read-struct info-struct))
+                       (pitch (bytes-per-row read-struct info-struct))
+                       (rows (rows read-struct info-struct))
+                       ;; Our target bitmap buffer, which uses RGBA
+                       ;; format with 8 bits per color channel, so 4
+                       ;; bytes per pixel.
+                       (pixels (make-bytevector (* width height 4)))
+                       (unpack (unpacker color-type bit-depth)))
+                  (if unpack
+                      ;; Unpack each row, converting from the PNG's
+                      ;; color type and bit depth to RGBA colors of
+                      ;; 8 bit depth.
+                      (let y-loop ((y 0))
+                        (when (< y height)
+                          (let* ((row (dereference-pointer rows y))
+                                 (bv (pointer->bytevector row pitch))
+                                 (offset (* y width 4)))
+                            (let x-loop ((x 0))
+                              (when (< x width)
+                                (let-values (((r g b a) (unpack bv x)))
+                                  (let ((offset (+ (* y width 4) (* x 4))))
+                                    (bytevector-u8-set! pixels offset r)
+                                    (bytevector-u8-set! pixels (+ offset 1) g)
+                                    (bytevector-u8-set! pixels (+ offset 2) b)
+                                    (bytevector-u8-set! pixels (+ offset 3) a)))
+                                (x-loop (+ x 1)))))
+                          (y-loop (+ y 1))))
+                      ;; Fastest case: The rows are already in RGBA
+                      ;; format with 8 bit depth, so we can just
+                      ;; copy each row verbatim.
+                      (let y-loop ((y 0))
+                        (when (< y height)
+                          (let* ((row (dereference-pointer rows y))
+                                 (bv (pointer->bytevector row pitch))
+                                 (offset (* y width 4)))
+                            (bytevector-copy! bv 0 pixels offset pitch))
+                          (y-loop (+ y 1)))))
+                  (values pixels
+                          width
+                          height)))
+              (lambda ()
+                (destroy-read-struct read-struct info-struct))))))
+      (raise-exception
+       (make-exception (make-external-error)
+                       (make-exception-with-message
+                        (string-append "file not found: " file-name))))))
diff --git a/configure.ac b/configure.ac
index 61fd8d3..b4cd56d 100644
--- a/configure.ac
+++ b/configure.ac
@@ -25,6 +25,20 @@ GUILE_PROGS
 GUILE_MODULE_REQUIRED([gl])
 GUILE_MODULE_REQUIRED([sdl2])
 
+AC_PATH_PROGS([PKG_CONFIG], [pkg-config])
+
+PKG_CHECK_MODULES([PNG], [libpng])
+PKG_CHECK_VAR([PNG_LIBDIR], [libpng], [libdir])
+AC_MSG_CHECKING([libpng library path])
+AS_IF([test "PNG_LIBDIR" = "x"], [
+  AC_MSG_FAILURE([Unable to identify libpng lib path.])
+], [
+  AC_MSG_RESULT([$PNG_LIBDIR])
+])
+AC_SUBST([PNG_LIBDIR])
+PNG_VERSION="`$PKG_CONFIG --modversion libpng`"
+AC_SUBST([PNG_VERSION])
+
 PKG_CHECK_MODULES([TURBOJPEG], [libturbojpeg])
 PKG_CHECK_VAR([TURBOJPEG_LIBDIR], [libturbojpeg], [libdir])
 AC_MSG_CHECKING([libturbojpeg library path])
diff --git a/guix.scm b/guix.scm
index dc82246..295ae85 100644
--- a/guix.scm
+++ b/guix.scm
@@ -142,6 +142,7 @@ SDL2 C shared library via the foreign function interface.")
    (list freetype
          target-guile
          libjpeg-turbo
+         libpng
          libvorbis
          mpg123
          openal