diff options
Diffstat (limited to 'chickadee/graphics/texture.scm')
| -rw-r--r-- | chickadee/graphics/texture.scm | 1113 |
1 files changed, 547 insertions, 566 deletions
diff --git a/chickadee/graphics/texture.scm b/chickadee/graphics/texture.scm index 65b7300..efdbfd9 100644 --- a/chickadee/graphics/texture.scm +++ b/chickadee/graphics/texture.scm @@ -23,411 +23,191 @@ #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) #:use-module (system foreign) - #:use-module (gl) - #:use-module ((gl enums) #:prefix gl:) #:use-module (chickadee math rect) #:use-module (chickadee graphics color) - #:use-module (chickadee graphics engine) - #:use-module (chickadee graphics gl) + #:use-module ((chickadee graphics backend) #:prefix gpu:) #:use-module (chickadee graphics pixbuf) #:use-module (chickadee image) #:use-module (chickadee utils) #:export (make-texture - make-texture-region - make-cube-map - pixbuf->texture - load-image - load-cube-map - texture-copy-pixbuf! - texture->pixbuf - write-texture + destroy-texture texture? - texture-region? - cube-map? - texture-null? - texture-type - texture-parent - texture-min-filter - texture-mag-filter - texture-wrap-s - texture-wrap-t - texture-x - texture-y + texture-destroyed? + texture-1d? + texture-2d? + texture-3d? + texture-destroyed? + texture-name texture-width texture-height - texture-gl-rect - texture-gl-tex-rect - null-texture + texture-depth + texture-mip-levels + texture-samples + texture-dimension + texture-format + texture-view black-texture white-texture gray-texture flat-texture - g:texture-0 - g:texture-1 - g:texture-2 - g:texture-3 - g:texture-4 - g:texture-5 - current-texture-0 - current-texture-1 - current-texture-2 - current-texture-3 - current-texture-4 - current-texture-5 - - texture-atlas - list->texture-atlas - split-texture - texture-tileset-dimensions - texture-atlas? - texture-atlas-size - texture-atlas-texture - texture-atlas-ref - load-tileset)) + pixbuf->texture + load-image + + make-texture-view + destroy-texture-view + texture-view? + texture-view-1d? + texture-view-2d? + texture-view-2d-array? + texture-view-3d? + texture-view-cube? + texture-view-cube-array? + texture-view-destroyed? + texture-view-texture + texture-view-name + texture-view-format + texture-view-dimension + texture-view-aspect + texture-view-base-mip-level + texture-view-mip-levels + texture-view-base-layer + texture-view-layers + texture-view-width + texture-view-height + texture-view-depth + + make-sampler + destroy-sampler + sampler? + sampler-destroyed? + sampler-name + sampler-address-mode-u + sampler-address-mode-v + sampler-address-mode-w + sampler-mag-filter + sampler-min-filter + sampler-mipmap-filter)) ;;; ;;; Textures ;;; -;; The <texture> object is a simple wrapper around an OpenGL texture -;; id. (define-record-type <texture> - (%make-texture id type parent min-filter mag-filter wrap-s wrap-t - x y width height gl-rect gl-tex-rect) + (%make-texture gpu handle name destroyed? width height depth mip-levels + samples dimension format) texture? - (id texture-id) - (type texture-type) - (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) + (gpu texture-gpu) + (handle texture-handle) + (name texture-name) + (destroyed? texture-destroyed? set-texture-destroyed!) (width texture-width) (height texture-height) - (gl-rect texture-gl-rect) - (gl-tex-rect texture-gl-tex-rect)) - -(set-record-type-printer! <texture> - (lambda (texture port) - (format port - "#<texture id: ~d region?: ~a x: ~d y: ~d width: ~d height: ~d min-filter: ~a mag-filter: ~a wrap-s: ~a wrap-t: ~a>" - (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 '2d #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 (cube-map? texture) - (and (texture? texture) (eq? (texture-type texture) 'cube-map))) - -(define (free-texture texture) - (gl-delete-texture (texture-id texture))) - -(define (gl-texture-target type) - (case type - ((2d) - (texture-target texture-2d)) - ((cube-map) - (version-1-3 texture-cube-map)))) - -(define (make-bind-texture n) - (lambda (texture) - (let ((texture-unit (+ (version-1-3 texture0) n))) - (set-gl-active-texture texture-unit) - (gl-bind-texture (gl-texture-target (texture-type texture)) - (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-graphics-state g:texture-4 - current-texture-4 - #:default null-texture - #:bind (make-bind-texture 4)) - -(define-graphics-state g:texture-5 - current-texture-5 - #:default null-texture - #:bind (make-bind-texture 5)) - -(define (gl-wrap-mode mode) - (case mode - ((repeat) - (texture-wrap-mode repeat)) - ('mirrored-repeat (version-1-4 mirrored-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)))) - -(define (gl-min-filter min-filter) - (case min-filter - ((nearest) - (gl:texture-min-filter nearest)) - ((linear) - (gl:texture-min-filter linear)) - ((nearest-mipmap-nearest) - (gl:texture-min-filter nearest-mipmap-nearest)) - ((linear-mipmap-nearest) - (gl:texture-min-filter linear-mipmap-nearest)) - ((nearest-mipmap-linear) - (gl:texture-min-filter nearest-mipmap-linear)) - ((linear-mipmap-linear) - (gl:texture-min-filter linear-mipmap-linear)))) - -(define (gl-mag-filter mag-filter) - (case mag-filter - ((nearest) - (gl:texture-mag-filter nearest)) - ((linear) - (gl:texture-mag-filter linear)))) - -(define (gl-pixel-format format) - (case format - ((rgba) - (pixel-format rgba)))) - -(define* (make-texture width height #:key - pixels flip? - (min-filter 'nearest) - (mag-filter 'nearest) - (wrap-s 'repeat) - (wrap-t 'repeat) - (format 'rgba)) - "Return a new GPU texture of WIDTH x HEIGHT pixels in size. PIXELS -may be a bytevector of WIDTH x HEIGHT pixels in 32-bit RGBA format, in -which case the texture will contain a copy of that data. If PIXELS is -not provided, the texture data will not be initialized. If FLIP? is -#t then the texture coordinates will be flipped vertically. 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), mirrored-repeat, clamp, -clamp-to-border, clamp-to-edge. FORMAT specifies the pixel format. -Currently only 32-bit RGBA format is supported." - (assert-current-graphics-engine) - (let ((texture (%make-texture (gl-generate-texture) '2d #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)) - ;; Ensure that we are using texture unit 0 because - ;; with-graphics-state! doesn't guarantee it. - (set-gl-active-texture (version-1-3 texture0)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-min-filter) - (gl-min-filter min-filter)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-mag-filter) - (gl-mag-filter mag-filter)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-wrap-s) - (gl-wrap-mode wrap-s)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-wrap-t) - (gl-wrap-mode wrap-t)) - (gl-texture-image-2d (texture-target texture-2d) - 0 (pixel-format rgba) width height 0 - (gl-pixel-format format) - (color-pointer-type unsigned-byte) - (or pixels %null-pointer)) - ;; Generate mipmaps, if needed. - (when (memq min-filter - '(nearest-mipmap-nearest - linear-mipmap-nearest - nearest-mipmap-linear - linear-mipmap-linear)) - (gl-generate-mipmap (texture-target texture-2d)))) - texture)) + (depth texture-depth) + (mip-levels texture-mip-levels) + (samples texture-samples) + (dimension texture-dimension) + (format texture-format) + (view %texture-view set-texture-view!)) + +(define (print-texture texture port) + (match texture + (($ <texture> _ _ name _ width height depth _ _ dimension format*) + (format #t "#<texture name: ~s width: ~s height: ~s depth: ~s dimension: ~s format: ~s>" + name width height depth dimension format*)))) + +(set-record-type-printer! <texture> print-texture) + +(define* (make-texture #:key + name + (width 1) + (height 1) + (depth 1) + (mip-levels 0) + (samples 1) + (dimension '2d) + (format 'rgba8)) + (let* ((gpu (gpu:current-gpu)) + (handle (gpu:make-texture gpu width height depth mip-levels + samples dimension format))) + (%make-texture gpu handle name #f width height depth mip-levels samples + dimension format))) + +(define (destroy-texture texture) + (unless (texture-destroyed? texture) + (gpu:destroy-texture (texture-gpu texture) (texture-handle texture)) + (set-texture-destroyed! texture #t))) + +(define (texture-1d? texture) + "Return #t if TEXTURE is a one-dimensional texture." + (eq? (texture-dimension texture) '1d)) + +(define (texture-2d? texture) + "Return #t if TEXTURE is a two-dimensional texture." + (eq? (texture-dimension texture) '2d)) + +(define (texture-3d? texture) + "Return #t if TEXTURE is a three-dimensional texture." + (eq? (texture-dimension texture) '3d)) + +;; TODO: This should be temporary??? +(define (texture-view texture) + (or (%texture-view texture) + (let ((view (make-texture-view texture))) + (set-texture-view! texture view) + view))) + +(define* (texture-write! texture data #:key + (x 0) (y 0) (z 0) + (width 0) (height 0) (depth 0) + (mip-level 0) (offset 0) + (format 'rgba8)) + (gpu:write-texture (texture-gpu texture) (texture-handle texture) + x y z width height depth mip-level format data offset)) -(define* (pixbuf->texture pixbuf #:key - flip? - (min-filter 'nearest) - (mag-filter 'nearest) - (wrap-s 'repeat) - (wrap-t 'repeat) - (format 'rgba)) - "Translate PIXBUF into a texture stored on the GPU. See -'make-texture' for documentation of all keyword arguments." - (assert-current-graphics-engine) - (let* ((width (pixbuf-width pixbuf)) - (height (pixbuf-height pixbuf)) - (texture (%make-texture (gl-generate-texture) '2d #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)) - ;; Ensure that we are using texture unit 0 because - ;; with-graphics-state! doesn't guarantee it. - (set-gl-active-texture (version-1-3 texture0)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-min-filter) - (gl-min-filter min-filter)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-mag-filter) - (gl-mag-filter mag-filter)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-wrap-s) - (gl-wrap-mode wrap-s)) - (gl-texture-parameter (texture-target texture-2d) - (texture-parameter-name texture-wrap-t) - (gl-wrap-mode wrap-t)) - (gl-texture-image-2d (texture-target texture-2d) - 0 (pixel-format rgba) width height 0 - (gl-pixel-format format) - (color-pointer-type unsigned-byte) - (pixbuf-pixels pixbuf)) - ;; Generate mipmaps, if needed. - (when (memq min-filter - '(nearest-mipmap-nearest - linear-mipmap-nearest - nearest-mipmap-linear - linear-mipmap-linear)) - (gl-generate-mipmap (texture-target texture-2d)))) +(define (texture-copy-pixbuf! texture pixbuf) + "Copy the contents of PIXBUF to TEXTURE." + (texture-write! texture (pixbuf-pixels pixbuf) + #:width (pixbuf-width pixbuf) + #:height (pixbuf-height pixbuf))) + +(define* (pixbuf->texture pixbuf #:key name) + "Return a new 2D texture loaded with the contents of PIXBUF and the +debug name NAME." + (let ((texture (make-texture #:name name + #:width (pixbuf-width pixbuf) + #:height (pixbuf-height pixbuf)))) + (texture-copy-pixbuf! texture pixbuf) texture)) -(define* (make-cube-map #:key - right left top bottom front back - (min-filter 'linear) - (mag-filter 'linear) - (format 'rgba)) - (define (set-face name pixbuf) - (gl-texture-image-2d (case name - ((right) - (version-1-3 texture-cube-map-positive-x)) - ((left) - (version-1-3 texture-cube-map-negative-x)) - ((top) - (version-1-3 texture-cube-map-positive-y)) - ((bottom) - (version-1-3 texture-cube-map-negative-y)) - ((front) - (version-1-3 texture-cube-map-positive-z)) - ((back) - (version-1-3 texture-cube-map-negative-z))) - 0 - (pixel-format rgba) - (pixbuf-width pixbuf) - (pixbuf-height pixbuf) - 0 - (gl-pixel-format format) - (color-pointer-type unsigned-byte) - (pixbuf-pixels pixbuf))) - (assert-current-graphics-engine) - (let ((texture (%make-texture (gl-generate-texture) 'cube-map #f - min-filter mag-filter - 'clamp-to-edge 'clamp-to-edge - 0 0 0 0 #f #f))) - (graphics-engine-guard! texture) - (with-graphics-state! ((g:texture-0 texture)) - ;; Ensure that we are using texture unit 0 because - ;; with-graphics-state! doesn't guarantee it. - (set-gl-active-texture (version-1-3 texture0)) - (gl-texture-parameter (gl-texture-target 'cube-map) - (texture-parameter-name texture-min-filter) - (gl-min-filter min-filter)) - (gl-texture-parameter (gl-texture-target 'cube-map) - (texture-parameter-name texture-mag-filter) - (gl-mag-filter mag-filter)) - (gl-texture-parameter (gl-texture-target 'cube-map) - (texture-parameter-name texture-wrap-s) - (gl-wrap-mode 'clamp-to-edge)) - (gl-texture-parameter (gl-texture-target 'cube-map) - (texture-parameter-name texture-wrap-t) - (gl-wrap-mode 'clamp-to-edge)) - (gl-texture-parameter (gl-texture-target 'cube-map) - (texture-parameter-name texture-wrap-r-ext) - (gl-wrap-mode 'clamp-to-edge)) - (set-face 'right right) - (set-face 'left left) - (set-face 'top top) - (set-face 'bottom bottom) - (set-face 'front front) - (set-face 'back back) - ;; Generate mipmaps, if needed. - (when (memq min-filter - '(nearest-mipmap-nearest - linear-mipmap-nearest - nearest-mipmap-linear - linear-mipmap-linear)) - (gl-generate-mipmap (gl-texture-target 'cube-map)))) - texture)) +(define (make-simple-texture name width height pixels) + (pixbuf->texture (bytevector->pixbuf pixels width height) + #:name name)) + +(define-syntax-rule (define-simple-texture name name* width height pixels) + (define name + (let ((promise (delay (make-simple-texture name* width height pixels)))) + (define (name) (force promise)) + name))) -(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)))) - (case (texture-type texture) - ((2d) - (%make-texture (texture-id texture) - '2d - 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)) - (else - (error "regions can only be made from 2d textures"))))) +(define-simple-texture black-texture "Black texture" 2 2 (u32vector 0 0 0 0)) + +(define-simple-texture white-texture "White texture" 2 2 + (u32vector #xffffffff #xffffffff #xffffffff #xffffffff)) + +(define-simple-texture gray-texture "Gray texture" 2 2 + (u32vector #xff808080 #xff808080 #xff808080 #xff808080)) + +;; A "flat" normal map, in tangent space. It's like the identity +;; property for normals. The colors are used to store 3D tangent space +;; vectors, with positive Z being "up". Each coordinate is in the +;; [-1,1] range and then remapped to an 8-bit color channel in the +;; 0-255 range. Thus, 0 maps to 127 or #x80, -1 maps to 0, and 1 maps +;; to 255. A flat tangent normal is (0, 0, 1), which is encoded as +;; the color #xffff8080. Such a value means that a mesh's vertex +;; normals remain completely unchanged by this normal map. +(define-simple-texture flat-texture "Flat texture" 2 2 + (u32vector #xffff8080 #xffff8080 #xffff8080 #xffff8080)) (define (%load-image image transparent-color flip?) (let ((pixbuf (read-image image))) @@ -438,204 +218,405 @@ by the bounding box RECT." pixbuf)) (define* (load-image image #:key - (min-filter 'nearest) - (mag-filter 'nearest) - (wrap-s 'repeat) - (wrap-t 'repeat) + name transparent-color (flip? #t)) "Load a texture from an image in IMAGE, which can be an image object -or a file name string. 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." +or a file name string." (let* ((image* (if (image? image) image (make-image image))) (pixbuf (%load-image image* transparent-color flip?))) - (pixbuf->texture pixbuf - #:min-filter min-filter - #:mag-filter mag-filter - #:wrap-s wrap-s - #:wrap-t wrap-t))) - -(define* (load-cube-map #:key right left top bottom front back - (min-filter 'linear-mipmap-linear) - (mag-filter 'linear)) - (make-cube-map #:right (%load-image right #f #f) - #:left (%load-image left #f #f) - #:top (%load-image top #f #f) - #:bottom (%load-image bottom #f #f) - #:front (%load-image front #f #f) - #:back (%load-image back #f #f) - #:min-filter min-filter - #:mag-filter mag-filter)) + (pixbuf->texture pixbuf #:name name))) -(define (texture-copy-pixbuf! texture pixbuf) - "Copy the contents of PIXBUF to TEXTURE." - (with-graphics-state! ((g:texture-0 texture)) - (gl-texture-sub-image-2d (texture-target texture-2d) 0 - (texture-x texture) (texture-y texture) - (pixbuf-width pixbuf) (pixbuf-height pixbuf) - (gl-pixel-format 'rgba) - (color-pointer-type unsigned-byte) - (pixbuf-pixels pixbuf)))) - -(define (texture->pixbuf texture) - "Return a new pixbuf with the contents of TEXTURE." - (let* ((w (texture-width texture)) - (h (texture-height texture)) - (pixels (make-bytevector (* w h 4) 0))) - (with-graphics-state! ((g:texture-0 texture)) - (gl-get-tex-image (texture-target texture-2d) - 0 - (gl-pixel-format 'rgba) - (color-pointer-type unsigned-byte) - (bytevector->pointer pixels))) - (let ((pixbuf (bytevector->pixbuf pixels w h - #:format 'rgba - #:bit-depth 8))) - (pixbuf-flip-vertically! pixbuf) - pixbuf))) - -(define* (write-texture texture - #:optional (file-name (temp-image-file-name 'png)) - #:key (format 'png)) - "Write TEXTURE to FILE-NAME using FORMAT ('png' by default.)" - (write-image (texture->pixbuf texture) file-name #:format format)) - -(define (black-texture) - null-texture) - -(define %white-texture - (delay - (make-texture 2 2 #:pixels (u32vector #xffffffff #xffffffff - #xffffffff #xffffffff)))) - -(define (white-texture) - (force %white-texture)) - -(define %gray-texture - (delay - (make-texture 2 2 #:pixels (u32vector #xff808080 #xff808080 - #xff808080 #xff808080)))) - -(define (gray-texture) - (force %gray-texture)) + +;;; +;;; Texture views +;;; -;; A "flat" normal map, in tangent space. It's like the identity -;; property for normals. The colors are used to store 3D tangent space -;; vectors, with positive Z being "up". Each coordinate is in the -;; [-1,1] range and then remapped to an 8-bit color channel in the -;; 0-255 range. Thus, 0 maps to 127 or #x80, -1 maps to 0, and 1 maps -;; to 255. The color values are in ABGR ordering. A flat tangent -;; normal is (0, 0, 1), which is encoded as the color #xffff8080. -;; Such a value means that a mesh's vertex normals remain completely -;; unchanged by this normal map. -(define %flat-texture - (delay - (make-texture 2 2 #:pixels (u32vector #xffff8080 #xffff8080 - #xffff8080 #xffff8080)))) - -(define (flat-texture) - (force %flat-texture)) +(define-record-type <texture-view> + (%make-texture-view gpu handle name destroyed? texture format dimension + aspect base-mip-level mip-levels base-layer layers) + texture-view? + (gpu texture-view-gpu) + (handle texture-view-handle) + (name texture-view-name) + (destroyed? texture-view-destroyed? set-texture-view-destroyed!) + (texture texture-view-texture) + (format texture-view-format) + (dimension texture-view-dimension) + (aspect texture-view-aspect) + (base-mip-level texture-view-base-mip-level) + (mip-levels texture-view-mip-levels) + (base-layer texture-view-base-layer) + (layers texture-view-layers)) + +(define (print-texture-view view port) + (match view + (($ <texture-view> _ _ name _ texture format* dimension aspect) + (format port "#<texture-view name: ~s texture: ~s format: ~s dimension: ~s aspect: ~s>" + name texture format* dimension aspect)))) + +(set-record-type-printer! <texture-view> print-texture-view) + +(define* (make-texture-view texture #:key + name + (format (texture-format texture)) + (dimension (texture-dimension texture)) + (aspect 'all) + (base-mip-level 0) + (mip-levels (texture-mip-levels texture)) + (base-layer 0) + (layers (match dimension + ((or 'cube 'cube-array) 6) + (_ 1)))) + (let* ((gpu (gpu:current-gpu)) + (handle (gpu:make-texture-view gpu (texture-handle texture) format + dimension aspect + base-mip-level mip-levels + base-layer layers))) + (%make-texture-view gpu handle name #f texture format dimension aspect + base-mip-level mip-levels base-layer layers))) + +(define (destroy-texture-view view) + (unless (texture-view-destroyed? view) + (gpu:destroy-texture-view (texture-view-gpu view) (texture-view-handle view)) + (set-texture-view-destroyed! view #t))) + +(define (texture-view-1d? view) + "Return #t if TEXTURE-VIEW is a one-dimensional texture view." + (eq? (texture-view-dimension view) '1d)) + +(define (texture-view-2d? view) + "Return #t if TEXTURE-VIEW is a two-dimensional texture view." + (eq? (texture-view-dimension view) '2d)) + +(define (texture-view-2d-array? view) + "Return #t if TEXTURE-VIEW is a two-dimensional array texture view." + (eq? (texture-view-dimension view) '2d-array)) + +(define (texture-view-3d? view) + "Return #t if TEXTURE-VIEW is a three-dimensional texture view." + (eq? (texture-view-dimension view) '3d)) + +(define (texture-view-cube? view) + "Return #t if TEXTURE-VIEW is a cube texture view." + (eq? (texture-view-dimension view) 'cube)) + +(define (texture-view-cube-array? view) + "Return #t if TEXTURE-VIEW is a cube array texture view." + (eq? (texture-view-dimension view) 'cube-array)) + +(define (texture-view-width view) + (texture-width (texture-view-texture view))) + +(define (texture-view-height view) + (texture-height (texture-view-texture view))) + +(define (texture-view-depth view) + (texture-depth (texture-view-texture view))) ;;; -;;; Texture Atlas +;;; Samplers ;;; -(define-record-type <texture-atlas> - (%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: ~a size: ~d>" - (texture-atlas-texture atlas) - (vector-length (texture-atlas-vector atlas)))) - -(set-record-type-printer! <texture-atlas> 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-size atlas) - "Return the size of ATLAS." - (vector-length (texture-atlas-vector atlas))) - -(define (texture-atlas-ref atlas index) - "Return the texture region associated with INDEX in -ATLAS." - (vector-ref (texture-atlas-vector atlas) index)) - -(define* (texture-tileset-dimensions texture tile-width tile-height #:key - (margin 0) (spacing 0)) - (values (inexact->exact - (ceiling (/ (- (texture-width texture) margin) - (+ tile-width spacing)))) - (inexact->exact - (ceiling (/ (- (texture-height texture) margin) - (+ tile-height spacing)))))) - -(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." - (call-with-values (lambda () - (texture-tileset-dimensions texture tile-width tile-height - #:margin margin - #:spacing spacing)) - (lambda (columns rows) - (let ((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) +(define-record-type <sampler> + (%make-sampler gpu handle name destroyed? + address-mode-u address-mode-v address-mode-w + mag-filter min-filter mipmap-filter) + sampler? + (gpu sampler-gpu) + (handle sampler-handle) + (name sampler-name) + (destroyed? sampler-destroyed? set-sampler-destroyed!) + (address-mode-u sampler-address-mode-u) + (address-mode-v sampler-address-mode-v) + (address-mode-w sampler-address-mode-w) + (mag-filter sampler-mag-filter) + (min-filter sampler-min-filter) + (mipmap-filter sampler-mipmap-filter)) + +(define (print-sampler sampler port) + (match sampler + (($ <sampler> _ _ name _ u v w mag min mip) + (format port + "#<sampler name: ~s address-mode: (u: ~s v: ~s w: ~s) filter: (mag: ~s min: ~s: mipmap: ~s)>" + name u v w mag min mip)))) + +(set-record-type-printer! <sampler> print-sampler) + +(define* (make-sampler #:key name + (address-mode-u 'clamp-to-edge) + (address-mode-v 'clamp-to-edge) + (address-mode-w 'clamp-to-edge) (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)) + (min-filter 'nearest) + (mipmap-filter 'nearest)) + (let* ((gpu (gpu:current-gpu)) + (handle (gpu:make-sampler gpu address-mode-u address-mode-v + address-mode-w mag-filter min-filter + mipmap-filter))) + (%make-sampler gpu handle name #f + address-mode-u address-mode-v address-mode-w + mag-filter min-filter mipmap-filter))) + +(define (destroy-sampler sampler) + (unless (sampler-destroyed? sampler) + (gpu:destroy-sampler (sampler-gpu sampler) (sampler-handle sampler)) + (set-sampler-destroyed! sampler #t))) + +;; +;; ;;; +;; ;;; Textures +;; ;;; + +;; ;; The <texture> object is a simple wrapper around an OpenGL texture +;; ;; id. +;; (define-record-type <texture> +;; (%make-texture id type parent min-filter mag-filter wrap-s wrap-t +;; x y width height gl-rect gl-tex-rect) +;; texture? +;; (id texture-id) +;; (type texture-type) +;; (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! <texture> +;; (lambda (texture port) +;; (format port +;; "#<texture id: ~d region?: ~a x: ~d y: ~d width: ~d height: ~d min-filter: ~a mag-filter: ~a wrap-s: ~a wrap-t: ~a>" +;; (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 '2d #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 (cube-map? texture) +;; (and (texture? texture) (eq? (texture-type texture) 'cube-map))) + +;; (define (free-texture texture) +;; (gl-delete-texture (texture-id texture))) + +;; (define (gl-texture-target type) +;; (case type +;; ((2d) +;; (texture-target texture-2d)) +;; ((cube-map) +;; (version-1-3 texture-cube-map)))) + +;; (define (make-bind-texture n) +;; (lambda (texture) +;; (let ((texture-unit (+ (version-1-3 texture0) n))) +;; (set-gl-active-texture texture-unit) +;; (gl-bind-texture (gl-texture-target (texture-type texture)) +;; (texture-id texture))))) + + +;; (define* (make-texture width height #:key +;; pixels flip? +;; (min-filter 'nearest) +;; (mag-filter 'nearest) +;; (wrap-s 'repeat) +;; (wrap-t 'repeat) +;; (format 'rgba)) +;; "Return a new GPU texture of WIDTH x HEIGHT pixels in size. PIXELS +;; may be a bytevector of WIDTH x HEIGHT pixels in 32-bit RGBA format, in +;; which case the texture will contain a copy of that data. If PIXELS is +;; not provided, the texture data will not be initialized. If FLIP? is +;; #t then the texture coordinates will be flipped vertically. 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), mirrored-repeat, clamp, +;; clamp-to-border, clamp-to-edge. FORMAT specifies the pixel format. +;; Currently only 32-bit RGBA format is supported." +;; (assert-current-graphics-engine) +;; (let ((texture (%make-texture (gl-generate-texture) '2d #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)) +;; ;; Ensure that we are using texture unit 0 because +;; ;; with-graphics-state! doesn't guarantee it. +;; (set-gl-active-texture (version-1-3 texture0)) +;; (gl-texture-parameter (texture-target texture-2d) +;; (texture-parameter-name texture-min-filter) +;; (gl-min-filter min-filter)) +;; (gl-texture-parameter (texture-target texture-2d) +;; (texture-parameter-name texture-mag-filter) +;; (gl-mag-filter mag-filter)) +;; (gl-texture-parameter (texture-target texture-2d) +;; (texture-parameter-name texture-wrap-s) +;; (gl-wrap-mode wrap-s)) +;; (gl-texture-parameter (texture-target texture-2d) +;; (texture-parameter-name texture-wrap-t) +;; (gl-wrap-mode wrap-t)) +;; (gl-texture-image-2d (texture-target texture-2d) +;; 0 (pixel-format rgba) width height 0 +;; (gl-pixel-format format) +;; (color-pointer-type unsigned-byte) +;; (or pixels %null-pointer)) +;; ;; Generate mipmaps, if needed. +;; (when (memq min-filter +;; '(nearest-mipmap-nearest +;; linear-mipmap-nearest +;; nearest-mipmap-linear +;; linear-mipmap-linear)) +;; (gl-generate-mipmap (texture-target texture-2d)))) +;; texture)) + +;; (define* (make-cube-map #:key +;; right left top bottom front back +;; (min-filter 'linear) +;; (mag-filter 'linear) +;; (format 'rgba)) +;; (define (set-face name pixbuf) +;; (gl-texture-image-2d (case name +;; ((right) +;; (version-1-3 texture-cube-map-positive-x)) +;; ((left) +;; (version-1-3 texture-cube-map-negative-x)) +;; ((top) +;; (version-1-3 texture-cube-map-positive-y)) +;; ((bottom) +;; (version-1-3 texture-cube-map-negative-y)) +;; ((front) +;; (version-1-3 texture-cube-map-positive-z)) +;; ((back) +;; (version-1-3 texture-cube-map-negative-z))) +;; 0 +;; (pixel-format rgba) +;; (pixbuf-width pixbuf) +;; (pixbuf-height pixbuf) +;; 0 +;; (gl-pixel-format format) +;; (color-pointer-type unsigned-byte) +;; (pixbuf-pixels pixbuf))) +;; (assert-current-graphics-engine) +;; (let ((texture (%make-texture (gl-generate-texture) 'cube-map #f +;; min-filter mag-filter +;; 'clamp-to-edge 'clamp-to-edge +;; 0 0 0 0 #f #f))) +;; (graphics-engine-guard! texture) +;; (with-graphics-state! ((g:texture-0 texture)) +;; ;; Ensure that we are using texture unit 0 because +;; ;; with-graphics-state! doesn't guarantee it. +;; (set-gl-active-texture (version-1-3 texture0)) +;; (gl-texture-parameter (gl-texture-target 'cube-map) +;; (texture-parameter-name texture-min-filter) +;; (gl-min-filter min-filter)) +;; (gl-texture-parameter (gl-texture-target 'cube-map) +;; (texture-parameter-name texture-mag-filter) +;; (gl-mag-filter mag-filter)) +;; (gl-texture-parameter (gl-texture-target 'cube-map) +;; (texture-parameter-name texture-wrap-s) +;; (gl-wrap-mode 'clamp-to-edge)) +;; (gl-texture-parameter (gl-texture-target 'cube-map) +;; (texture-parameter-name texture-wrap-t) +;; (gl-wrap-mode 'clamp-to-edge)) +;; (gl-texture-parameter (gl-texture-target 'cube-map) +;; (texture-parameter-name texture-wrap-r-ext) +;; (gl-wrap-mode 'clamp-to-edge)) +;; (set-face 'right right) +;; (set-face 'left left) +;; (set-face 'top top) +;; (set-face 'bottom bottom) +;; (set-face 'front front) +;; (set-face 'back back) +;; ;; Generate mipmaps, if needed. +;; (when (memq min-filter +;; '(nearest-mipmap-nearest +;; linear-mipmap-nearest +;; nearest-mipmap-linear +;; linear-mipmap-linear)) +;; (gl-generate-mipmap (gl-texture-target 'cube-map)))) +;; 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)))) +;; (case (texture-type texture) +;; ((2d) +;; (%make-texture (texture-id texture) +;; '2d +;; 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)) +;; (else +;; (error "regions can only be made from 2d textures"))))) + +;; (define* (load-cube-map #:key right left top bottom front back +;; (min-filter 'linear-mipmap-linear) +;; (mag-filter 'linear)) +;; (make-cube-map #:right (%load-image right #f #f) +;; #:left (%load-image left #f #f) +;; #:top (%load-image top #f #f) +;; #:bottom (%load-image bottom #f #f) +;; #:front (%load-image front #f #f) +;; #:back (%load-image back #f #f) +;; #:min-filter min-filter +;; #:mag-filter mag-filter)) + +;; (define (texture->pixbuf texture) +;; "Return a new pixbuf with the contents of TEXTURE." +;; (let* ((w (texture-width texture)) +;; (h (texture-height texture)) +;; (pixels (make-bytevector (* w h 4) 0))) +;; (with-graphics-state! ((g:texture-0 texture)) +;; (gl-get-tex-image (texture-target texture-2d) +;; 0 +;; (gl-pixel-format 'rgba) +;; (color-pointer-type unsigned-byte) +;; (bytevector->pointer pixels))) +;; (let ((pixbuf (bytevector->pixbuf pixels w h +;; #:format 'rgba +;; #:bit-depth 8))) +;; (pixbuf-flip-vertically! pixbuf) +;; pixbuf))) + +;; (define* (write-texture texture +;; #:optional (file-name (temp-image-file-name 'png)) +;; #:key (format 'png)) +;; "Write TEXTURE to FILE-NAME using FORMAT ('png' by default.)" +;; (write-image (texture->pixbuf texture) file-name #:format format)) |