;;; Chickadee Game Toolkit
;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;
;; CPU-side pixel data buffers.
;;
;;; Code:

(define-module (chickadee graphics pixbuf)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee utils)
  #:use-module (ice-9 exceptions)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:export (make-pixbuf
            bytevector->pixbuf
            pixbuf?
            pixbuf-alpha?
            pixbuf-pixels
            pixbuf-width
            pixbuf-height
            pixbuf-format
            pixbuf-bit-depth
            pixbuf-copy-raw!
            pixbuf-flip-vertically!
            pixbuf-color-key!))

(define &pixbuf-error
  (make-exception-type '&pixbuf-error &error '()))

(define make-pixbuf-error (record-constructor &pixbuf-error))

(define (pixbuf-error message irritants)
 (raise-exception
  (make-exception
   (make-pixbuf-error)
   (make-exception-with-message message)
   (make-exception-with-irritants irritants))))

;; A pixbuf is raw pixel data stored in memory that can be saved to
;; disk or loaded into a GPU texture.
(define-record-type <pixbuf>
  (%make-pixbuf pixels width height format bit-depth)
  pixbuf?
  (pixels pixbuf-pixels)
  (width pixbuf-width)
  (height pixbuf-height)
  (format pixbuf-format)
  (bit-depth pixbuf-bit-depth))

(define (print-pixbuf pixbuf port)
  (format port "#<pixbuf width: ~a height: ~a format: ~a bit-depth: ~a>"
          (pixbuf-width pixbuf)
          (pixbuf-height pixbuf)
          (pixbuf-format pixbuf)
          (pixbuf-bit-depth pixbuf)))

(set-record-type-printer! <pixbuf> print-pixbuf)

(define (channel-count format)
  (case format
    ((rgba) 4)))

(define (byte-depth bit-depth)
  (/ bit-depth 8))

(define (buffer-length width height format bit-depth)
  (* width height
     (byte-depth bit-depth)
     (channel-count format)))

(define* (make-pixbuf width height #:key (format 'rgba) (bit-depth 8))
  "Return a new pixbuf object of WIDTH x HEIGHT pixels using color
channel FORMAT and BIT-DEPTH bits per channel.  Initially, all color
channel values are 0.  Currently, the only supported format is 'rgba'
and the only supported bit depth is 8."
  (unless (= bit-depth 8)
    (pixbuf-error "unsupported bit depth" (list bit-depth)))
  (unless (eq? format 'rgba)
    (pixbuf-error "unsupported format" (list format)))
  (let* ((n (buffer-length width height format bit-depth))
         (buffer (make-bytevector n 0)))
    (%make-pixbuf buffer width height format bit-depth)))

(define* (bytevector->pixbuf bv width height #:key (format 'rgba) (bit-depth 8))
  (let ((pixbuf (make-pixbuf width height
                             #:format format
                             #:bit-depth bit-depth)))
    (pixbuf-copy-raw! pixbuf bv)
    pixbuf))

(define (pixbuf-alpha? pixbuf)
  "Return #t if PIXBUF has an alpha channel."
  (case (pixbuf-format pixbuf)
    ((rgba) #t)
    (else #f)))

(define (pixbuf-byte-depth pixbuf)
  (byte-depth (pixbuf-bit-depth pixbuf)))

(define (pixbuf-red-channel-index pixbuf)
  (case (pixbuf-format pixbuf)
    ((rgba) 0)))

(define (pixbuf-green-channel-index pixbuf)
  (case (pixbuf-format pixbuf)
    ((rgba) 1)))

(define (pixbuf-blue-channel-index pixbuf)
  (case (pixbuf-format pixbuf)
    ((rgba) 2)))

(define (pixbuf-alpha-channel-index pixbuf)
  (case (pixbuf-format pixbuf)
    ((rgba) 3)))

(define (pixbuf-channel-count pixbuf)
  "Return the number of channels per pixel in PIXBUF."
  (channel-count (pixbuf-format pixbuf)))

(define (pixbuf-copy-raw! pixbuf bv)
  "Copy the contents of the bytevector BV into PIXBUF.  BV must be
exactly the same size as the underlying buffer of PIXBUF."
  (let* ((pixels (pixbuf-pixels pixbuf))
         (n (bytevector-length pixels)))
    (if (= (bytevector-length bv) n)
        (bytevector-copy! bv 0 pixels 0 n)
        (pixbuf-error "improperly sized bytevector" (list bv)))))

(define (pixbuf-flip-vertically! pixbuf)
  "Flip the pixel data in PIXBUF upside-down."
  (let* ((w (pixbuf-width pixbuf))
         (h (pixbuf-height pixbuf))
         (n (pixbuf-channel-count pixbuf))
         (d (pixbuf-byte-depth pixbuf))
         (row-length (* w n d))
         (temp-row (make-bytevector row-length 0))
         (pixels (pixbuf-pixels pixbuf)))
    (for-range ((y (floor (/ h 2))))
      (let* ((y* (- h y 1))
             (source-start (* y row-length))
             (target-start (* y* row-length)))
        ;; Copy the target row into the temp row.
        (bytevector-copy! pixels target-start temp-row 0 row-length)
        ;; Overwrite the target row with the source row.
        (bytevector-copy! pixels source-start pixels target-start row-length)
        ;; Overwrite the source row with the temp row.
        (bytevector-copy! temp-row 0 pixels source-start row-length)))))

(define (pixbuf-color-key! pixbuf color)
  "Overwrite the alpha channel for pixels in PIXBUF that match COLOR
with full transparency."
  (when (pixbuf-alpha? pixbuf)
    (let* ((w (pixbuf-width pixbuf))
           (h (pixbuf-height pixbuf))
           (n (pixbuf-channel-count pixbuf))
           (d (pixbuf-byte-depth pixbuf))
           (ri (pixbuf-red-channel-index pixbuf))
           (gi (pixbuf-green-channel-index pixbuf))
           (bi (pixbuf-blue-channel-index pixbuf))
           (ai (pixbuf-alpha-channel-index pixbuf))
           (high (- (expt 256 d) 1))
           (r (inexact->exact (* (color-r color) high)))
           (g (inexact->exact (* (color-g color) high)))
           (b (inexact->exact (* (color-b color) high)))
           (pixels (pixbuf-pixels pixbuf)))
      (define (channel-ref i offset)
        (bytevector-uint-ref pixels (+ i offset) (native-endianness) d))
      (define (channel-set! i offset x)
        (bytevector-uint-set! pixels (+ i offset) x (native-endianness) d))
      (for-range ((i (bytevector-length pixels) 0 (* n d)))
        ;; Zero the alpha channel of pixels that match the transparent
        ;; color key.
        (when (and (= r (channel-ref i ri))
                   (= g (channel-ref i gi))
                   (= b (channel-ref i bi)))
          (channel-set! i ai 0))))))