summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2021-12-17 08:57:01 -0500
committerDavid Thompson <dthompson2@worcester.edu>2021-12-17 08:57:16 -0500
commitc405b463a00c719e015f30a8a7da4db787736560 (patch)
tree27b5c945ce8285832e07ad1848d9bab427aac83d
parenta9aa99ac55440b36fe0c2c647bcfa151f08bcce2 (diff)
Add libpng bindings.
-rw-r--r--Makefile.am1
-rw-r--r--chickadee/config.scm.in9
-rw-r--r--chickadee/image/png.scm392
-rw-r--r--configure.ac14
-rw-r--r--guix.scm1
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