diff options
Diffstat (limited to '2d/texture.scm')
| -rw-r--r-- | 2d/texture.scm | 224 |
1 files changed, 0 insertions, 224 deletions
diff --git a/2d/texture.scm b/2d/texture.scm deleted file mode 100644 index bd7bea6..0000000 --- a/2d/texture.scm +++ /dev/null @@ -1,224 +0,0 @@ -;;; guile-2d -;;; Copyright (C) 2013, 2014 David Thompson <dthompson2@worcester.edu> -;;; -;;; 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 -;;; <http://www.gnu.org/licenses/>. - -;;; Commentary: -;; -;; Textures and texture regions are high level wrappers over OpenGL -;; textures. -;; -;;; Code: - -(define-module (2d texture) - #:use-module (srfi srfi-9) - #:use-module (gl) - #:use-module (gl contrib packed-struct) - #:use-module (2d color) - #:use-module (2d helpers) - #:use-module (2d vector) - #:use-module (2d wrappers gl) - #:use-module (2d 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)) - -;;; -;;; Textures -;;; - -;; The <texture> object is a simple wrapper around an OpenGL texture -;; id. -(define-record-type <texture> - (%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) - "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) - (texture-min-filter nearest)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-mag-filter) - (texture-mag-filter nearest)) - (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) - ;; Need to flip because y-axis is reversed. - (freeimage-flip-vertical 32bit-bitmap) - 32bit-bitmap)) - -(define (load-texture filename) - "Load a texture from an image file at FILENAME." - (let* ((bitmap (load-bitmap filename)) - (texture (bitmap->texture bitmap))) - (freeimage-unload bitmap) - texture)) - -(define (anchor-texture texture anchor) - "Return a vector of the coordinates for the center point of a -texture." - (let ((w (texture-width texture)) - (h (texture-height texture))) - (cond - ((vector2? anchor) - anchor) - ((eq? anchor 'center) - (vector (/ w 2) - (/ h 2))) - ((eq? anchor 'top-left) - #(0 0)) - ((eq? anchor 'top-right) - (vector w 0)) - ((eq? anchor 'bottom-left) - (vector 0 h)) - ((eq? anchor 'bottom-right) - (vector w h)) - ((eq? anchor 'top-center) - (vector (/ w 2) 0)) - ((eq? anchor 'bottom-center) - (vector (/ w 2) h)) - (else - (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 (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)))) |