1 files changed, 150 insertions, 0 deletions
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))))))