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