;;; Chickadee Game Toolkit ;;; Copyright © 2016, 2021 David Thompson ;;; ;;; 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 ;;; . (define-module (chickadee graphics 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) #:prefix gl:) #:use-module ((sdl2 surface) #:prefix sdl2:) #:use-module (chickadee math rect) #:use-module (chickadee graphics color) #:use-module (chickadee graphics engine) #:use-module (chickadee graphics gl) #:use-module (chickadee utils) #:export (make-texture make-texture-region load-image texture? texture-region? texture-null? texture-parent texture-min-filter texture-mag-filter texture-wrap-s texture-wrap-t texture-x texture-y texture-width texture-height texture-gl-rect texture-gl-tex-rect null-texture g:texture-0 g:texture-1 g:texture-2 g:texture-3 current-texture-0 current-texture-1 current-texture-2 current-texture-3 texture-atlas list->texture-atlas split-texture texture-atlas? texture-atlas-texture texture-atlas-ref load-tileset)) ;;; ;;; Textures ;;; ;; The object is a simple wrapper around an OpenGL texture ;; id. (define-record-type (%make-texture id parent min-filter mag-filter wrap-s wrap-t x y width height gl-rect gl-tex-rect) texture? (id texture-id) (parent texture-parent) (min-filter texture-min-filter) (mag-filter texture-mag-filter) (wrap-s texture-wrap-s) (wrap-t texture-wrap-t) (x texture-x) (y texture-y) (width texture-width) (height texture-height) (gl-rect texture-gl-rect) (gl-tex-rect texture-gl-tex-rect)) (set-record-type-printer! (lambda (texture port) (format port "#" (texture-id texture) (texture-region? texture) (texture-x texture) (texture-y texture) (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 #f 'linear 'linear 'repeat 'repeat 0 0 0 0 (make-rect 0.0 0.0 0.0 0.0) (make-rect 0.0 0.0 0.0 0.0))) (define (texture-null? texture) "Return #t if TEXTURE is the null texture." (eq? texture null-texture)) (define (texture-region? texture) (texture? (texture-parent texture))) (define (free-texture texture) (gl-delete-texture (texture-id texture))) (define (make-bind-texture n) (lambda (texture) (let ((texture-unit (+ (version-1-3 texture0) n))) (set-gl-active-texture texture-unit) (gl-bind-texture (texture-target texture-2d) (texture-id texture))))) (define-graphics-finalizer texture-finalizer #:predicate texture? #:free free-texture) (define-graphics-state g:texture-0 current-texture-0 #:default null-texture #:bind (make-bind-texture 0)) (define-graphics-state g:texture-1 current-texture-1 #:default null-texture #:bind (make-bind-texture 1)) (define-graphics-state g:texture-2 current-texture-2 #:default null-texture #:bind (make-bind-texture 2)) (define-graphics-state g:texture-3 current-texture-3 #:default null-texture #:bind (make-bind-texture 3)) (define* (make-texture pixels width height #:key flip? (min-filter 'nearest) (mag-filter 'nearest) (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 first pixel in PIXELS corresponds to the upper-left corner of the image. If this is not the case and the first pixel corresponds to the lower-left corner of the image, set FLIP? to #t. 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)))) (assert-current-graphics-engine) (let ((texture (%make-texture (gl-generate-texture) #f min-filter mag-filter wrap-s wrap-t 0 0 width height (make-rect 0.0 0.0 width height) (if flip? (make-rect 0.0 1.0 1.0 -1.0) (make-rect 0.0 0.0 1.0 1.0))))) (graphics-engine-guard! texture) (with-graphics-state ((g:texture-0 texture)) (graphics-engine-commit!) (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 (make-texture-region texture rect) "Create a new texture region covering a section of TEXTURE defined by the bounding box RECT." (let* ((pw (texture-width texture)) (ph (texture-height texture)) (x (rect-x rect)) (y (rect-y rect)) (w (rect-width rect)) (h (rect-height rect)) (vert-rect (make-rect 0.0 0.0 w h)) (tex-rect (make-rect (/ x pw) (/ y ph) (/ w pw) (/ h ph)))) (%make-texture (texture-id texture) texture (texture-min-filter texture) (texture-mag-filter texture) (texture-wrap-s texture) (texture-wrap-t texture) x y w h vert-rect tex-rect))) (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 (for-range ((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))) buffer)) (define (surface->texture surface min-filter mag-filter wrap-s wrap-t transparent-color) "Convert SURFACE, an SDL2 surface object, into a texture that uses the given MIN-FILTER and MAG-FILTER." ;; Convert to 32 bit RGBA color. (sdl2:call-with-surface (sdl2:convert-surface-format surface 'abgr8888) (lambda (surface) (let* ((width (sdl2:surface-width surface)) (height (sdl2:surface-height surface)) (pixels (sdl2:surface-pixels surface))) ;; Zero the alpha channel of pixels that match the transparent ;; color key. (when transparent-color (let ((r (inexact->exact (* (color-r transparent-color) 255))) (g (inexact->exact (* (color-g transparent-color) 255))) (b (inexact->exact (* (color-b transparent-color) 255))) (pixel-count (* width height 4))) (for-range ((i pixel-count 0 4)) (when (and (= r (bytevector-u8-ref pixels i)) (= g (bytevector-u8-ref pixels (+ i 1))) (= b (bytevector-u8-ref pixels (+ i 2)))) (bytevector-u8-set! pixels (+ i 3) 0))))) (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) transparent-color) "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." (sdl2:call-with-surface ((@ (sdl2 image) load-image) file) (lambda (surface) (surface->texture surface min-filter mag-filter wrap-s wrap-t transparent-color)))) ;;; ;;; Texture Atlas ;;; (define-record-type (%make-texture-atlas texture vector) texture-atlas? (texture texture-atlas-texture) (vector texture-atlas-vector)) (define (display-texture-atlas atlas port) (format port "#" (texture-atlas-texture atlas) (vector-length (texture-atlas-vector atlas)))) (set-record-type-printer! display-texture-atlas) (define (list->texture-atlas texture rects) "Return a new atlas for TEXTURE containing RECTS, a list of texture coordinate rects denoting the various regions within." (let ((v (make-vector (length rects)))) (let loop ((i 0) (rects rects)) (match rects (() (%make-texture-atlas texture v)) (((x y width height) . rest) (vector-set! v i (make-texture-region texture (make-rect x y width height))) (loop (1+ i) rest)))))) (define (texture-atlas texture . rects) "Return a new atlas for TEXTURE containing RECTS, a series of 4-tuples in the form (x y width height) describing the various tiles within." (list->texture-atlas texture rects)) (define (texture-atlas-ref atlas index) "Return the texture region 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)) (rows (inexact->exact (ceiling (/ (- h margin) (+ tile-height spacing))))) (columns (inexact->exact (ceiling (/ (- 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-texture-region texture (make-rect x y tile-width tile-height)))) (for-range ((x columns) (y rows)) (vector-set! v (+ x (* y columns)) (make-tile x y))) (%make-texture-atlas texture v))) (define* (load-tileset file-name tile-width tile-height #:key (margin 0) (spacing 0) (min-filter 'nearest) (mag-filter 'nearest) (wrap-s 'repeat) (wrap-t 'repeat) transparent-color) "Return a new texture atlas that splits the texture loaded from the file FILE-NAME into a grid of TILE-WIDTH by TILE-HEIGHT rectangles. See load-image and split-texture for information about all keyword arguments." (split-texture (load-image file-name #:min-filter min-filter #:mag-filter mag-filter #:wrap-s wrap-s #:wrap-t wrap-t #:transparent-color transparent-color) tile-width tile-height #:margin margin #:spacing spacing))