Add libturbojpeg bindings.

5 files changed, 167 insertions, 0 deletions

diff --git a/Makefile.am b/Makefile.am
index bbb2887..1ce452d 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -65,6 +65,7 @@ SOURCES = 					\
   chickadee/audio/vorbis.scm			\
   chickadee/audio/wav.scm			\
   chickadee/audio.scm				\
+  chickadee/image/jpeg.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 e4a8e1f..721a6d5 100644
--- a/chickadee/config.scm.in
+++ b/chickadee/config.scm.in
@@ -27,6 +27,7 @@
   #:export (dynamic-link*
             %datadir
             %chickadee-version
+            %libturbojpeg
             %libopenal
             %libvorbisfile
             %libmpg123
@@ -65,6 +66,9 @@
      (else
       '(absolute ...)))))
 
+(define-library-name %libturbojpeg
+  ("@TURBOJPEG_LIBDIR@/libturbojpeg")
+  ("libturbojpeg"))
 (define-library-name %libopenal
   ("@OPENAL_LIBDIR@/libopenal")
   ("libopenal"))
diff --git a/chickadee/image/jpeg.scm b/chickadee/image/jpeg.scm
new file mode 100644
index 0000000..4ba60fe
--- /dev/null
+++ b/chickadee/image/jpeg.scm
@@ -0,0 +1,150 @@
+;;; 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:
+;;
+;; JPEG image loading.
+;;
+;;; Code:
+
+(define-module (chickadee image jpeg)
+  #:use-module (chickadee config)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
+  #:use-module (system foreign)
+  #:export (load-jpeg))
+
+
+;;;
+;;; Enums
+;;;
+
+(define TJERR_WARNING 0)
+(define TJERR_FATAL 1)
+
+(define TJPF_RGBA 7)
+
+(define TJFLAG_BOTTOMUP 2)
+
+
+;;;
+;;; Low-level bindings
+;;;
+
+(define libturbojpeg-func
+  (let ((lib (dynamic-link* %libturbojpeg)))
+    (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
+    (libturbojpeg-func return-type func-name arg-types)))
+
+(define-foreign tj-get-error-code
+  int "tjGetErrorCode" '(*))
+
+(define-foreign tj-get-error-str2
+  '* "tjGetErrorStr2" '(*))
+
+(define-foreign tj-init-decompress
+  '* "tjInitDecompress" '())
+
+(define-foreign tj-destroy
+  int "tjDestroy" '(*))
+
+(define-foreign tj-decompress-header3
+  int "tjDecompressHeader3" (list '* '* unsigned-long '* '* '* '*))
+
+(define-foreign tj-decompress2
+  int "tjDecompress2" (list '* '* unsigned-long '* int int int int int))
+
+
+;;;
+;;; High-level bindings
+;;;
+
+(define (display-tjhandle handle port)
+  (display "#<tjhandle>" port))
+
+(define-wrapped-pointer-type <tjhandle> tjhandle?
+  wrap-tjhandle unwrap-tjhandle display-tjhandle)
+
+(define (check-error handle)
+  (let* ((ptr (if handle (unwrap-tjhandle handle) %null-pointer))
+         (error-code (tj-get-error-code ptr))
+         (error-string (pointer->string (tj-get-error-str2 ptr))))
+    (if (= error-code TJERR_FATAL)
+        (raise-exception (make-exception-with-message error-string))
+        (format (current-error-port) "warning: ~a~%" error-string))))
+
+(define (init-decompress)
+  (wrap-tjhandle (tj-init-decompress)))
+
+(define (destroy-handle handle)
+  (tj-destroy (unwrap-tjhandle handle)))
+
+(define (decompress-headers handle buffer)
+  (let ((result (make-s32vector 4)))
+    (unless (zero? (tj-decompress-header3 (unwrap-tjhandle handle)
+                                          (bytevector->pointer buffer)
+                                          (bytevector-length buffer)
+                                          (bytevector->pointer result)
+                                          (bytevector->pointer result 4)
+                                          (bytevector->pointer result 8)
+                                          (bytevector->pointer result 12)))
+      (check-error handle))
+    (values (s32vector-ref result 0)
+            (s32vector-ref result 1)
+            (s32vector-ref result 2)
+            (s32vector-ref result 3))))
+
+(define (decompress handle buffer width pitch height pixel-format flags)
+  (let ((bv (make-bytevector (* pitch height))))
+    (unless (zero? (tj-decompress2 (unwrap-tjhandle handle)
+                                   (bytevector->pointer buffer)
+                                   (bytevector-length buffer)
+                                   (bytevector->pointer bv)
+                                   width pitch height pixel-format flags))
+      (check-error handle))
+    bv))
+
+(define (load-jpeg file-name)
+  (if (file-exists? file-name)
+      (let ((buffer (call-with-input-file file-name get-bytevector-all))
+            (handle (init-decompress)))
+        (dynamic-wind
+          (lambda () #t)
+          (lambda ()
+            (let-values (((width height subsamples color-space)
+                          (decompress-headers handle buffer)))
+              (let ((pitch (* width 4)))
+                (values (decompress handle buffer width pitch height
+                                    TJPF_RGBA 0) ; TJFLAG_BOTTOMUP
+                        width height))))
+          (lambda ()
+            (destroy-handle handle))))
+      (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 bdef4ce..61fd8d3 100644
--- a/configure.ac
+++ b/configure.ac
@@ -25,6 +25,16 @@ GUILE_PROGS
 GUILE_MODULE_REQUIRED([gl])
 GUILE_MODULE_REQUIRED([sdl2])
 
+PKG_CHECK_MODULES([TURBOJPEG], [libturbojpeg])
+PKG_CHECK_VAR([TURBOJPEG_LIBDIR], [libturbojpeg], [libdir])
+AC_MSG_CHECKING([libturbojpeg library path])
+AS_IF([test "TURBOJPEG_LIBDIR" = "x"], [
+  AC_MSG_FAILURE([Unable to identify libturbojpeg lib path.])
+], [
+  AC_MSG_RESULT([$TURBOJPEG_LIBDIR])
+])
+AC_SUBST([TURBOJPEG_LIBDIR])
+
 PKG_CHECK_MODULES([OpenAL], [openal])
 PKG_CHECK_VAR([OPENAL_LIBDIR], [openal], [libdir])
 AC_MSG_CHECKING([OpenAL library path])
diff --git a/guix.scm b/guix.scm
index 490dcd0..dc82246 100644
--- a/guix.scm
+++ b/guix.scm
@@ -47,6 +47,7 @@
              (gnu packages audio)
              (gnu packages autotools)
              (gnu packages fontutils)
+             (gnu packages image)
              (gnu packages pkg-config)
              (gnu packages readline)
              (gnu packages texinfo)
@@ -140,6 +141,7 @@ SDL2 C shared library via the foreign function interface.")
   (inputs
    (list freetype
          target-guile
+         libjpeg-turbo
          libvorbis
          mpg123
          openal