diff options
Diffstat (limited to 'chickadee/render/texture.scm')
| -rw-r--r-- | chickadee/render/texture.scm | 191 |
1 files changed, 191 insertions, 0 deletions
diff --git a/chickadee/render/texture.scm b/chickadee/render/texture.scm new file mode 100644 index 0000000..ef55dca --- /dev/null +++ b/chickadee/render/texture.scm @@ -0,0 +1,191 @@ +;;; 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 (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 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*)) + +;;; +;;; 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) + pixels) + 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 #:optional #: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)))) |