From e3f07cfd92adfcd62d6605af16e122f85a4249dd Mon Sep 17 00:00:00 2001 From: David Thompson Date: Fri, 7 Nov 2014 22:22:17 -0500 Subject: render: Move texture module to sly/render directory. * sly/texture.scm: Delete. * sly/render/texture.scm: New file. * Makefile.am (SOURCES): Add it. * sly/animation.scm: Use (sly render texture). * sly/font.scm: Likewise. * sly/mesh.scm: Likewise. * sly/render/context.scm: Likewise. * sly/render/framebuffer.scm: Likewise. * sly/render/renderer.scm: Likewise. * sly/shape.scm: Likewise. * sly/sprite.scm: Likewise. * sly/tileset.scm: Likewise. * examples/coroutine.scm: Likewise. * examples/joystick.scm: Likewise. * examples/particles.scm: Likewise. * examples/tilemap.scm: Likewise. * examples/transition.scm: Likewise. --- Makefile.am | 2 +- examples/coroutine.scm | 2 +- examples/joystick.scm | 2 +- examples/particles.scm | 2 +- examples/tilemap.scm | 2 +- examples/transition.scm | 2 +- sly/animation.scm | 2 +- sly/font.scm | 2 +- sly/mesh.scm | 2 +- sly/render/context.scm | 2 +- sly/render/framebuffer.scm | 2 +- sly/render/renderer.scm | 2 +- sly/render/texture.scm | 246 +++++++++++++++++++++++++++++++++++++++++++++ sly/shape.scm | 2 +- sly/sprite.scm | 2 +- sly/texture.scm | 246 --------------------------------------------- sly/tileset.scm | 2 +- 17 files changed, 261 insertions(+), 261 deletions(-) create mode 100644 sly/render/texture.scm delete mode 100644 sly/texture.scm diff --git a/Makefile.am b/Makefile.am index 7a65af2..a5f1aa8 100644 --- a/Makefile.am +++ b/Makefile.am @@ -46,7 +46,6 @@ SOURCES = \ sly/shape.scm \ sly/signal.scm \ sly/sprite.scm \ - sly/texture.scm \ sly/tileset.scm \ sly/transform.scm \ sly/transition.scm \ @@ -55,6 +54,7 @@ SOURCES = \ sly/render/utils.scm \ sly/render/camera.scm \ sly/render/framebuffer.scm \ + sly/render/texture.scm \ sly/render/vertex-array.scm \ sly/render/context.scm \ sly/render/renderer.scm \ diff --git a/examples/coroutine.scm b/examples/coroutine.scm index ea7f881..708f174 100644 --- a/examples/coroutine.scm +++ b/examples/coroutine.scm @@ -20,7 +20,7 @@ (sly coroutine) (sly game) (sly sprite) - (sly texture) + (sly render texture) (sly vector) (sly window)) diff --git a/examples/joystick.scm b/examples/joystick.scm index 3df938d..268c1ee 100644 --- a/examples/joystick.scm +++ b/examples/joystick.scm @@ -25,7 +25,7 @@ (sly game) (sly repl) (sly sprite) - (sly texture) + (sly render texture) (sly joystick) (sly signal) (sly window) diff --git a/examples/particles.scm b/examples/particles.scm index a6c19a7..1d2f335 100644 --- a/examples/particles.scm +++ b/examples/particles.scm @@ -20,7 +20,7 @@ (sly agenda) (sly game) (sly sprite) - (sly texture) + (sly render texture) (sly vector) (sly window)) diff --git a/examples/tilemap.scm b/examples/tilemap.scm index bfe41b0..8ce7f81 100644 --- a/examples/tilemap.scm +++ b/examples/tilemap.scm @@ -21,7 +21,7 @@ (srfi srfi-42) (sly game) (sly sprite) - (sly texture) + (sly render texture) (sly tileset) (sly vector) (sly window) diff --git a/examples/transition.scm b/examples/transition.scm index 39f7a93..606942f 100644 --- a/examples/transition.scm +++ b/examples/transition.scm @@ -21,7 +21,7 @@ (sly window) (sly color) (sly signal) - (sly texture) + (sly render texture) (sly transition)) (load "common.scm") diff --git a/sly/animation.scm b/sly/animation.scm index d9ac11c..c64ee5d 100644 --- a/sly/animation.scm +++ b/sly/animation.scm @@ -23,7 +23,7 @@ (define-module (sly animation) #:use-module (srfi srfi-9) - #:use-module (sly texture)) + #:use-module (sly render texture)) ;;; ;;; Animations diff --git a/sly/font.scm b/sly/font.scm index 8ec62dc..9d28f74 100644 --- a/sly/font.scm +++ b/sly/font.scm @@ -36,7 +36,7 @@ #:use-module (sly mesh) #:use-module (sly shader) #:use-module (sly sprite) - #:use-module (sly texture) + #:use-module (sly render texture) #:export (enable-fonts load-font load-default-font diff --git a/sly/mesh.scm b/sly/mesh.scm index 2a0c8ec..eb6a53b 100644 --- a/sly/mesh.scm +++ b/sly/mesh.scm @@ -31,7 +31,7 @@ #:use-module (sly wrappers gl) #:use-module (sly color) #:use-module (sly shader) - #:use-module (sly texture) + #:use-module (sly render texture) #:use-module (sly math vector) #:use-module (sly signal) #:use-module (sly transform) diff --git a/sly/render/context.scm b/sly/render/context.scm index 67e233d..447dac0 100644 --- a/sly/render/context.scm +++ b/sly/render/context.scm @@ -28,7 +28,7 @@ #:use-module (gl low-level) #:use-module (sly wrappers gl) #:use-module (sly shader) - #:use-module (sly texture) + #:use-module (sly render texture) #:use-module (sly render utils) #:use-module (sly render vertex-array) #:export (make-render-context diff --git a/sly/render/framebuffer.scm b/sly/render/framebuffer.scm index c8e891f..a8c93d1 100644 --- a/sly/render/framebuffer.scm +++ b/sly/render/framebuffer.scm @@ -106,7 +106,7 @@ dimensions WIDTH x HEIGHT." (glBindRenderbuffer (version-3-0 renderbuffer) 0) (glBindFramebuffer (version-3-0 framebuffer) 0) ;; Build high-level framebuffer object. - (let ((texture ((@@ (sly texture) %make-texture) + (let ((texture ((@@ (sly render texture) %make-texture) texture-id #f width height 0 0 1 1))) (%make-framebuffer framebuffer-id renderbuffer-id texture)))))) diff --git a/sly/render/renderer.scm b/sly/render/renderer.scm index 19ab170..d04bf16 100644 --- a/sly/render/renderer.scm +++ b/sly/render/renderer.scm @@ -29,7 +29,7 @@ #:use-module (gl) #:use-module (gl low-level) #:use-module (sly shader) - #:use-module (sly texture) + #:use-module (sly render texture) #:use-module (sly transform) #:use-module (sly math vector) #:use-module (sly render utils) diff --git a/sly/render/texture.scm b/sly/render/texture.scm new file mode 100644 index 0000000..fbb97bb --- /dev/null +++ b/sly/render/texture.scm @@ -0,0 +1,246 @@ +;;; Sly +;;; Copyright (C) 2013, 2014 David Thompson +;;; +;;; This program 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. +;;; +;;; This program 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 +;;; . + +;;; Commentary: +;; +;; Textures and texture regions are high level wrappers over OpenGL +;; textures. +;; +;;; Code: + +(define-module (sly render texture) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (gl) + #:use-module (gl low-level) + #:use-module (gl contrib packed-struct) + #:use-module (sly color) + #:use-module (sly utils) + #:use-module (sly math vector) + #:use-module (sly wrappers gl) + #:use-module (sly wrappers freeimage) + #:export (make-texture + make-texture-region + load-texture + texture? + texture-region? + texture-id + texture-width + texture-height + texture-s1 + texture-t1 + texture-s2 + texture-t2 + anchor-texture + texture-vertex + pack-texture-vertices + draw-texture-vertices + apply-texture + with-texture)) + +;;; +;;; Textures +;;; + +;; The object is a simple wrapper around an OpenGL texture +;; id. +(define-record-type + (%make-texture id parent width height s1 t1 s2 t2) + texture? + (id texture-id) + (parent texture-parent) + (width texture-width) + (height texture-height) + (s1 texture-s1) + (t1 texture-t1) + (s2 texture-s2) + (t2 texture-t2)) + +(define (texture-region? texture) + "Return #t if TEXTURE has a parent texture." + (texture? (texture-parent texture))) + +(define (make-texture id parent width height s1 t1 s2 t2) + "Create a new texture object. ID is the OpenGL texture id. PARENT is +a texture object (if this texture only represents a region of another +texture) or #f. WIDTH and HEIGHT are the texture dimensions in +pixels. S1, T1, S2, and T2 are the OpenGL texture coordinates +representing the area of the texture that will be rendered." + (let ((texture (%make-texture id parent width height s1 t1 s2 t2))) + (texture-guardian texture) + texture)) + +(define (make-texture-region texture x y width height) + "Creates new texture region object. TEXTURE is the region's parent +texture. X, Y, WIDTH, and HEIGHT represent the region of the texture +that will be rendered, in pixels." + (let* ((w (texture-width texture)) + (h (texture-height texture))) + (make-texture (texture-id texture) + texture + width + height + (/ x w) + (/ y h) + (/ (+ x width) w) + (/ (+ y height) h)))) + +;; Use a guardian and an after GC hook that ensures that OpenGL +;; textures are deleted when texture objects are GC'd. +(define-guardian texture-guardian + (lambda (texture) + ;; Do not reap texture regions + (unless (texture-region? texture) + ;; When attempting to reap structures upon guile exit, the + ;; dynamic pointer to gl-delete-textures becomes invalid. So, we + ;; ignore the error and move on. + (false-if-exception (gl-delete-texture (texture-id texture)))))) + +(define (bitmap->texture bitmap min-filter mag-filter) + "Translates a freeimage bitmap into an OpenGL texture." + (let ((texture-id (gl-generate-texture)) + (pixels (freeimage-get-bits bitmap))) + (with-gl-bind-texture (texture-target texture-2d) texture-id + ;; Use "nearest" scaling method so that pixel art doesn't become + ;; blurry when scaled. + (gl-texture-parameter (texture-target texture-2d) + (texture-parameter-name texture-min-filter) + (match min-filter + ('nearest (texture-min-filter nearest)) + ('linear (texture-min-filter linear)))) + (gl-texture-parameter (texture-target texture-2d) + (texture-parameter-name texture-mag-filter) + (match mag-filter + ('nearest (texture-mag-filter nearest)) + ('linear (texture-mag-filter linear)))) + (gl-texture-image-2d (texture-target texture-2d) + 0 + (pixel-format rgba) + (freeimage-get-width bitmap) + (freeimage-get-height bitmap) + 0 + (version-1-2 bgra) + (color-pointer-type unsigned-byte) + pixels)) + (make-texture texture-id + #f + (freeimage-get-width bitmap) + (freeimage-get-height bitmap) + 0 0 1 1))) + +(define (load-bitmap filename) + ;; Throw an error if image file does not exist or else we will + ;; segfault later. + (unless (file-exists? filename) + (throw 'image-not-found filename)) + ;; Load image and convert it to 32 bit color. + (let* ((image-type (freeimage-get-file-type filename)) + (bitmap (freeimage-load image-type filename)) + (32bit-bitmap (freeimage-convert-to-32-bits bitmap))) + (freeimage-unload bitmap) + 32bit-bitmap)) + +(define* (load-texture file-name #:optional #:key + (min-filter 'nearest) (mag-filter 'nearest)) + "Load a texture from an image file at FILENAME. 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." + (let* ((bitmap (load-bitmap file-name)) + (texture (bitmap->texture bitmap min-filter mag-filter))) + (freeimage-unload bitmap) + texture)) + +(define (anchor-texture texture anchor) + "Translate ANCHOR into a vector that represents the desired centtral +point for TEXTURE. Valid values for ANCHOR are: 'center, 'top-left, +'top-right, 'bottom-left, 'bottom-right, 'top-center, 'bottom-center, +or any 2D vector. Passing a 2D vector will simply cause the same +vector to be returned." + (let ((w (texture-width texture)) + (h (texture-height texture))) + (match anchor + ((? vector2? anchor) + anchor) + ('center + (vector2 (/ w 2) + (/ h 2))) + ('top-left + (vector2 0 0)) + ('top-right + (vector2 w 0)) + ('bottom-left + (vector2 0 h)) + ('bottom-right + (vector2 w h)) + ('top-center + (vector2 (/ w 2) 0)) + ('bottom-center + (vector2 (/ w 2) h)) + (_ (error "Invalid anchor type: " anchor))))) + +;;; +;;; Texture Vertices +;;; + +(define-packed-struct texture-vertex + ;; Position + (x float) + (y float) + ;; Texture Coordinates + (s float) + (t float)) + +(define texture-vertex-size (packed-struct-size texture-vertex)) +(define x-offset (packed-struct-offset texture-vertex x)) +(define s-offset (packed-struct-offset texture-vertex s)) + +(define (pack-texture-vertices vertices offset width height s1 t1 s2 t2) + ;; Vertices go counter clockwise, starting from the top-left + ;; corner. + (pack vertices offset texture-vertex 0 0 s1 t1) + (pack vertices (+ offset 1) texture-vertex 0 height s1 t2) + (pack vertices (+ offset 2) texture-vertex width height s2 t2) + (pack vertices (+ offset 3) texture-vertex width 0 s2 t1)) + +(define (apply-texture texture) + (glBindTexture (texture-target texture-2d) (texture-id texture))) + +(define-syntax-rule (with-texture texture body ...) + (begin + (apply-texture texture) + body + ... + (glBindTexture (texture-target texture-2d) 0))) + +(define (draw-texture-vertices texture vertices size) + (let ((pointer-type (tex-coord-pointer-type float))) + (gl-enable-client-state (enable-cap vertex-array)) + (gl-enable-client-state (enable-cap texture-coord-array)) + (with-gl-bind-texture (texture-target texture-2d) (texture-id texture) + (set-gl-vertex-array pointer-type + vertices + 2 + #:stride texture-vertex-size + #:offset x-offset) + (set-gl-texture-coordinates-array pointer-type + vertices + #:stride texture-vertex-size + #:offset s-offset) + (gl-draw-arrays (begin-mode quads) 0 (* size 4))) + (gl-disable-client-state (enable-cap texture-coord-array)) + (gl-disable-client-state (enable-cap vertex-array)))) diff --git a/sly/shape.scm b/sly/shape.scm index ed9e440..e7b7d26 100644 --- a/sly/shape.scm +++ b/sly/shape.scm @@ -25,7 +25,7 @@ #:use-module (sly math) #:use-module (sly mesh) #:use-module (sly shader) - #:use-module (sly texture) + #:use-module (sly render texture) #:use-module (sly math vector) #:export (make-cube)) diff --git a/sly/sprite.scm b/sly/sprite.scm index 33c679f..e452247 100644 --- a/sly/sprite.scm +++ b/sly/sprite.scm @@ -36,7 +36,7 @@ #:use-module (sly mesh) #:use-module (sly shader) #:use-module (sly signal) - #:use-module (sly texture) + #:use-module (sly render texture) #:use-module (sly math vector) #:export (make-sprite load-sprite diff --git a/sly/texture.scm b/sly/texture.scm deleted file mode 100644 index b7221de..0000000 --- a/sly/texture.scm +++ /dev/null @@ -1,246 +0,0 @@ -;;; Sly -;;; Copyright (C) 2013, 2014 David Thompson -;;; -;;; This program 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. -;;; -;;; This program 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 -;;; . - -;;; Commentary: -;; -;; Textures and texture regions are high level wrappers over OpenGL -;; textures. -;; -;;; Code: - -(define-module (sly texture) - #:use-module (ice-9 match) - #:use-module (srfi srfi-9) - #:use-module (gl) - #:use-module (gl low-level) - #:use-module (gl contrib packed-struct) - #:use-module (sly color) - #:use-module (sly utils) - #:use-module (sly math vector) - #:use-module (sly wrappers gl) - #:use-module (sly wrappers freeimage) - #:export (make-texture - make-texture-region - load-texture - texture? - texture-region? - texture-id - texture-width - texture-height - texture-s1 - texture-t1 - texture-s2 - texture-t2 - anchor-texture - texture-vertex - pack-texture-vertices - draw-texture-vertices - apply-texture - with-texture)) - -;;; -;;; Textures -;;; - -;; The object is a simple wrapper around an OpenGL texture -;; id. -(define-record-type - (%make-texture id parent width height s1 t1 s2 t2) - texture? - (id texture-id) - (parent texture-parent) - (width texture-width) - (height texture-height) - (s1 texture-s1) - (t1 texture-t1) - (s2 texture-s2) - (t2 texture-t2)) - -(define (texture-region? texture) - "Return #t if TEXTURE has a parent texture." - (texture? (texture-parent texture))) - -(define (make-texture id parent width height s1 t1 s2 t2) - "Create a new texture object. ID is the OpenGL texture id. PARENT is -a texture object (if this texture only represents a region of another -texture) or #f. WIDTH and HEIGHT are the texture dimensions in -pixels. S1, T1, S2, and T2 are the OpenGL texture coordinates -representing the area of the texture that will be rendered." - (let ((texture (%make-texture id parent width height s1 t1 s2 t2))) - (texture-guardian texture) - texture)) - -(define (make-texture-region texture x y width height) - "Creates new texture region object. TEXTURE is the region's parent -texture. X, Y, WIDTH, and HEIGHT represent the region of the texture -that will be rendered, in pixels." - (let* ((w (texture-width texture)) - (h (texture-height texture))) - (make-texture (texture-id texture) - texture - width - height - (/ x w) - (/ y h) - (/ (+ x width) w) - (/ (+ y height) h)))) - -;; Use a guardian and an after GC hook that ensures that OpenGL -;; textures are deleted when texture objects are GC'd. -(define-guardian texture-guardian - (lambda (texture) - ;; Do not reap texture regions - (unless (texture-region? texture) - ;; When attempting to reap structures upon guile exit, the - ;; dynamic pointer to gl-delete-textures becomes invalid. So, we - ;; ignore the error and move on. - (false-if-exception (gl-delete-texture (texture-id texture)))))) - -(define (bitmap->texture bitmap min-filter mag-filter) - "Translates a freeimage bitmap into an OpenGL texture." - (let ((texture-id (gl-generate-texture)) - (pixels (freeimage-get-bits bitmap))) - (with-gl-bind-texture (texture-target texture-2d) texture-id - ;; Use "nearest" scaling method so that pixel art doesn't become - ;; blurry when scaled. - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-min-filter) - (match min-filter - ('nearest (texture-min-filter nearest)) - ('linear (texture-min-filter linear)))) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-mag-filter) - (match mag-filter - ('nearest (texture-mag-filter nearest)) - ('linear (texture-mag-filter linear)))) - (gl-texture-image-2d (texture-target texture-2d) - 0 - (pixel-format rgba) - (freeimage-get-width bitmap) - (freeimage-get-height bitmap) - 0 - (version-1-2 bgra) - (color-pointer-type unsigned-byte) - pixels)) - (make-texture texture-id - #f - (freeimage-get-width bitmap) - (freeimage-get-height bitmap) - 0 0 1 1))) - -(define (load-bitmap filename) - ;; Throw an error if image file does not exist or else we will - ;; segfault later. - (unless (file-exists? filename) - (throw 'image-not-found filename)) - ;; Load image and convert it to 32 bit color. - (let* ((image-type (freeimage-get-file-type filename)) - (bitmap (freeimage-load image-type filename)) - (32bit-bitmap (freeimage-convert-to-32-bits bitmap))) - (freeimage-unload bitmap) - 32bit-bitmap)) - -(define* (load-texture file-name #:optional #:key - (min-filter 'nearest) (mag-filter 'nearest)) - "Load a texture from an image file at FILENAME. 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." - (let* ((bitmap (load-bitmap file-name)) - (texture (bitmap->texture bitmap min-filter mag-filter))) - (freeimage-unload bitmap) - texture)) - -(define (anchor-texture texture anchor) - "Translate ANCHOR into a vector that represents the desired centtral -point for TEXTURE. Valid values for ANCHOR are: 'center, 'top-left, -'top-right, 'bottom-left, 'bottom-right, 'top-center, 'bottom-center, -or any 2D vector. Passing a 2D vector will simply cause the same -vector to be returned." - (let ((w (texture-width texture)) - (h (texture-height texture))) - (match anchor - ((? vector2? anchor) - anchor) - ('center - (vector2 (/ w 2) - (/ h 2))) - ('top-left - (vector2 0 0)) - ('top-right - (vector2 w 0)) - ('bottom-left - (vector2 0 h)) - ('bottom-right - (vector2 w h)) - ('top-center - (vector2 (/ w 2) 0)) - ('bottom-center - (vector2 (/ w 2) h)) - (_ (error "Invalid anchor type: " anchor))))) - -;;; -;;; Texture Vertices -;;; - -(define-packed-struct texture-vertex - ;; Position - (x float) - (y float) - ;; Texture Coordinates - (s float) - (t float)) - -(define texture-vertex-size (packed-struct-size texture-vertex)) -(define x-offset (packed-struct-offset texture-vertex x)) -(define s-offset (packed-struct-offset texture-vertex s)) - -(define (pack-texture-vertices vertices offset width height s1 t1 s2 t2) - ;; Vertices go counter clockwise, starting from the top-left - ;; corner. - (pack vertices offset texture-vertex 0 0 s1 t1) - (pack vertices (+ offset 1) texture-vertex 0 height s1 t2) - (pack vertices (+ offset 2) texture-vertex width height s2 t2) - (pack vertices (+ offset 3) texture-vertex width 0 s2 t1)) - -(define (apply-texture texture) - (glBindTexture (texture-target texture-2d) (texture-id texture))) - -(define-syntax-rule (with-texture texture body ...) - (begin - (apply-texture texture) - body - ... - (glBindTexture (texture-target texture-2d) 0))) - -(define (draw-texture-vertices texture vertices size) - (let ((pointer-type (tex-coord-pointer-type float))) - (gl-enable-client-state (enable-cap vertex-array)) - (gl-enable-client-state (enable-cap texture-coord-array)) - (with-gl-bind-texture (texture-target texture-2d) (texture-id texture) - (set-gl-vertex-array pointer-type - vertices - 2 - #:stride texture-vertex-size - #:offset x-offset) - (set-gl-texture-coordinates-array pointer-type - vertices - #:stride texture-vertex-size - #:offset s-offset) - (gl-draw-arrays (begin-mode quads) 0 (* size 4))) - (gl-disable-client-state (enable-cap texture-coord-array)) - (gl-disable-client-state (enable-cap vertex-array)))) diff --git a/sly/tileset.scm b/sly/tileset.scm index f66b6a8..24bbf54 100644 --- a/sly/tileset.scm +++ b/sly/tileset.scm @@ -25,7 +25,7 @@ (define-module (sly tileset) #:use-module (srfi srfi-9) #:use-module (srfi srfi-42) - #:use-module (sly texture) + #:use-module (sly render texture) #:export ( make-tileset load-tileset -- cgit v1.2.3