path: root/chickadee/render/texture.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2016 David Thompson <davet@gnu.org>
;;;
;;; 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/>.

(define-module (chickadee render texture)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (system foreign)
  #:use-module (gl)
  #:use-module ((gl enums)
                #:select (texture-min-filter texture-mag-filter)
                #:prefix gl:)
  #:use-module ((sdl2 image) #:prefix sdl-image:)
  #:use-module (sdl2 surface)
  #:use-module (oop goops)
  #:use-module (chickadee math rect)
  #:use-module (chickadee render gl)
  #:use-module (chickadee render gpu)
  #:export (make-texture
            load-image
            texture?
            texture-null?
            texture-id
            texture-parent
            texture-width
            texture-height
            texture-min-filter
            texture-mag-filter
            texture-wrap-s
            texture-wrap-t
            null-texture
            *texture-state*

            texture-atlas
            list->texture-atlas
            split-texture
            texture-atlas?
            texture-atlas-ref))


;;;
;;; Textures
;;;

;; The <texture> object is a simple wrapper around an OpenGL texture
;; id.
(define-record-type <texture>
  (%make-texture id width height min-filter mag-filter wrap-s wrap-t)
  texture?
  (id texture-id)
  (width texture-width)
  (height texture-height)
  (min-filter texture-min-filter)
  (mag-filter texture-mag-filter)
  (wrap-s texture-wrap-s)
  (wrap-t texture-wrap-t))

(set-record-type-printer! <texture>
  (lambda (texture port)
    (format port
            "#<texture width: ~d height: ~d min-filter: ~a mag-filter: ~a wrap-s: ~a wrap-t: ~a>"
            (texture-width texture)
            (texture-height texture)
            (texture-min-filter texture)
            (texture-mag-filter texture)
            (texture-wrap-s texture)
            (texture-wrap-t texture))))

(define null-texture (%make-texture 0 0 0 'linear 'linear 'repeat 'repeat))

(define <<texture>> (class-of null-texture))

(define (texture-null? texture)
  "Return #t if TEXTURE is the null texture."
  (eq? texture null-texture))

(define (free-texture texture)
  (gl-delete-texture (texture-id texture)))

(define-method (gpu-finalize (texture <<texture>>))
  (free-texture texture))

(define (apply-texture texture)
  (gl-enable (enable-cap texture-2d))
  (gl-bind-texture (texture-target texture-2d)
                   (texture-id texture)))

(define *texture-state* (make-gpu-state apply-texture null-texture))

(define* (make-texture pixels width height #:key
                       (min-filter 'linear)
                       (mag-filter 'linear)
                       (wrap-s 'repeat)
                       (wrap-t 'repeat)
                       (format 'rgba))
  "Translate the bytevector PIXELS into an OpenGL texture with
dimensions WIDTHxHEIGHT where each pixel is in 32-bit RGBA format.
The generated texture uses MIN-FILTER for downscaling and MAG-FILTER
for upscaling.  WRAP-S and WRAP-T are symbols that control how texture
access is handled for texture coordinates outside the [0, 1] range.
Allowed symbols are: repeat (the default), clamp, clamp-to-border,
clamp-to-edge.  FORMAT specifies the pixel format.  Currently only
32-bit RGBA format is supported."
  (define (gl-wrap mode)
    (match mode
      ('repeat (texture-wrap-mode repeat))
      ('clamp (texture-wrap-mode clamp))
      ('clamp-to-border (texture-wrap-mode clamp-to-border-sgis))
      ('clamp-to-edge (texture-wrap-mode clamp-to-edge-sgis))))

  (let ((texture (gpu-guard
                  (%make-texture (gl-generate-texture) width height
                                 min-filter mag-filter wrap-s wrap-t))))
    (gpu-state-set! *texture-state* texture)
    (gl-texture-parameter (texture-target texture-2d)
                          (texture-parameter-name texture-min-filter)
                          (match min-filter
                            ('nearest (gl:texture-min-filter nearest))
                            ('linear (gl:texture-min-filter linear))))
    (gl-texture-parameter (texture-target texture-2d)
                          (texture-parameter-name texture-mag-filter)
                          (match mag-filter
                            ('nearest (gl:texture-mag-filter nearest))
                            ('linear (gl:texture-mag-filter linear))))
    (gl-texture-parameter (texture-target texture-2d)
                          (texture-parameter-name texture-wrap-s)
                          (gl-wrap wrap-s))
    (gl-texture-parameter (texture-target texture-2d)
                          (texture-parameter-name texture-wrap-t)
                          (gl-wrap wrap-t))
    (gl-texture-image-2d (texture-target texture-2d)
                         0 (pixel-format rgba) width height 0
                         (match format
                           ('rgba (pixel-format rgba)))
                         (color-pointer-type unsigned-byte)
                         (or pixels %null-pointer))
    texture))

(define (flip-pixels-vertically pixels width height)
  "Create a new bytevector that reverses the rows in PIXELS, a WIDTH x
HEIGHT, 32 bit color bytevector."
  (let ((buffer (make-u8vector (bytevector-length pixels)))
        (row-width (* width 4))) ; assuming 32 bit color
    (let loop ((y 0))
      (when (< y height)
        (let* ((y* (- height y 1))
               (source-start (* y row-width))
               (target-start (* y* row-width)))
          (bytevector-copy! pixels source-start buffer target-start row-width)
          (loop (1+ y)))))
    buffer))

(define (surface->texture surface min-filter mag-filter wrap-s wrap-t)
  "Convert SURFACE, an SDL2 surface object, into a texture that uses
the given MIN-FILTER and MAG-FILTER."
  ;; Convert to 32 bit RGBA color.
  (call-with-surface (convert-surface-format surface 'abgr8888)
    (lambda (surface)
      (let* ((width (surface-width surface))
             (height (surface-height surface))
             ;; OpenGL textures use the bottom-left corner as the
             ;; origin, whereas SDL uses the top-left, so the rows
             ;; of pixels must be reversed before creating a
             ;; texture from them.
             (pixels (flip-pixels-vertically (surface-pixels surface)
                                             width height)))
        (make-texture pixels width height
                      #:min-filter min-filter
                      #:mag-filter mag-filter
                      #:wrap-s wrap-s
                      #:wrap-t wrap-t)))))

(define* (load-image file #:key
                     (min-filter 'nearest)
                     (mag-filter 'nearest)
                     (wrap-s 'repeat)
                     (wrap-t 'repeat))
  "Load a texture from an image in FILE.  MIN-FILTER and MAG-FILTER
describe the method that should be used for minification and
magnification.  Valid values are 'nearest and 'linear.  By default,
'nearest is used."
  (call-with-surface (sdl-image:load-image file)
    (lambda (surface)
      (surface->texture surface min-filter mag-filter wrap-s wrap-t))))


;;;
;;; Texture Atlas
;;;

(define-record-type <texture-atlas>
  (%make-texture-atlas texture vector)
  texture-atlas?
  (texture texture-atlas-texture)
  (vector texture-atlas-vector))

(define (list->texture-atlas texture rects)
  "Return a new atlas for TEXTURE containing RECTS, a list of texture
coordinate rects denoting the various tiles within."
  (let ((v (make-vector (length rects))))
    (let loop ((i 0)
               (rects rects))
      (match rects
        (() (%make-texture-atlas texture v))
        ((r . rest)
         (vector-set! v i r)
         (loop (1+ i) rest))))))

(define (texture-atlas texture . rects)
  "Return a new atlas for TEXTURE containing RECTS, a series of
texture coordinate rect arguments denoting the various tiles within."
  (list->texture-atlas texture rects))

(define (texture-atlas-ref atlas index)
  "Return the texture coordinate rect associated with INDEX in
ATLAS."
  (vector-ref (texture-atlas-vector atlas) index))

(define* (split-texture texture tile-width tile-height #:key
                        (margin 0) (spacing 0))
  "Return a new texture atlas that splits TEXTURE into a grid of
TILE-WIDTH by TILE-HEIGHT rectangles.  Optionally, each tile may have
SPACING pixels of horizontal and vertical space between surrounding
tiles and the entire image may have MARGIN pixels of empty space
around its border.

This type of texture atlas layout is very common for tile map
terrain."
  (let* ((w (texture-width texture))
         (h (texture-height texture))
         (sw (/ tile-width w))
         (th (/ tile-height h))
         (rows (/ (- h margin) (+ tile-height spacing)))
         (columns (/ (- w margin) (+ tile-width spacing)))
         (v (make-vector (* rows columns))))
    (define (make-tile tx ty)
      (let* ((x (+ (* tx (+ tile-width spacing)) margin))
             (y (+ (* ty (+ tile-height spacing)) margin)))
        (make-rect (/ x w) (/ y h) sw th)))
    (let y-loop ((y 0))
      (when (< y rows)
        (let x-loop ((x 0))
          (when (< x columns)
            (vector-set! v (+ x (* y columns)) (make-tile x y))
            (x-loop (1+ x))))
        (y-loop (1+ y))))
    (%make-texture-atlas texture v)))