;;; guile-sdl3 -- Scheme bindings for SDL3 ;;; Copyright © 2024 David Thompson ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;; ;; Adapted from https://github.com/thatcosmonaut/SDL/blob/main/test/testgpu_spinning_cube.c ;; ;;; Code: (use-modules (bstruct) (ice-9 match) (rnrs bytevectors) (sdl3) (sdl3 events) (sdl3 gpu) (sdl3 video)) ;; These SPIR-V blobs are taken directly from SDL. (define vert-spirv #vu8(#x03 #x02 #x23 #x07 #x00 #x00 #x01 #x00 #x0b #x00 #x08 #x00 #x2a #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x11 #x00 #x02 #x00 #x01 #x00 #x00 #x00 #x0b #x00 #x06 #x00 #x01 #x00 #x00 #x00 #x47 #x4c #x53 #x4c #x2e #x73 #x74 #x64 #x2e #x34 #x35 #x30 #x00 #x00 #x00 #x00 #x0e #x00 #x03 #x00 #x00 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x0f #x00 #x09 #x00 #x00 #x00 #x00 #x00 #x04 #x00 #x00 #x00 #x6d #x61 #x69 #x6e #x00 #x00 #x00 #x00 #x09 #x00 #x00 #x00 #x0c #x00 #x00 #x00 #x18 #x00 #x00 #x00 #x22 #x00 #x00 #x00 #x03 #x00 #x03 #x00 #x02 #x00 #x00 #x00 #xc2 #x01 #x00 #x00 #x05 #x00 #x04 #x00 #x04 #x00 #x00 #x00 #x6d #x61 #x69 #x6e #x00 #x00 #x00 #x00 #x05 #x00 #x05 #x00 #x09 #x00 #x00 #x00 #x6f #x75 #x74 #x5f #x63 #x6f #x6c #x6f #x72 #x00 #x00 #x00 #x05 #x00 #x05 #x00 #x0c #x00 #x00 #x00 #x69 #x6e #x5f #x63 #x6f #x6c #x6f #x72 #x00 #x00 #x00 #x00 #x05 #x00 #x06 #x00 #x16 #x00 #x00 #x00 #x67 #x6c #x5f #x50 #x65 #x72 #x56 #x65 #x72 #x74 #x65 #x78 #x00 #x00 #x00 #x00 #x06 #x00 #x06 #x00 #x16 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x67 #x6c #x5f #x50 #x6f #x73 #x69 #x74 #x69 #x6f #x6e #x00 #x06 #x00 #x07 #x00 #x16 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x67 #x6c #x5f #x50 #x6f #x69 #x6e #x74 #x53 #x69 #x7a #x65 #x00 #x00 #x00 #x00 #x06 #x00 #x07 #x00 #x16 #x00 #x00 #x00 #x02 #x00 #x00 #x00 #x67 #x6c #x5f #x43 #x6c #x69 #x70 #x44 #x69 #x73 #x74 #x61 #x6e #x63 #x65 #x00 #x06 #x00 #x07 #x00 #x16 #x00 #x00 #x00 #x03 #x00 #x00 #x00 #x67 #x6c #x5f #x43 #x75 #x6c #x6c #x44 #x69 #x73 #x74 #x61 #x6e #x63 #x65 #x00 #x05 #x00 #x03 #x00 #x18 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x05 #x00 #x03 #x00 #x1c #x00 #x00 #x00 #x55 #x42 #x4f #x00 #x06 #x00 #x07 #x00 #x1c #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x6d #x6f #x64 #x65 #x6c #x56 #x69 #x65 #x77 #x50 #x72 #x6f #x6a #x00 #x00 #x00 #x05 #x00 #x03 #x00 #x1e #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x05 #x00 #x05 #x00 #x22 #x00 #x00 #x00 #x69 #x6e #x5f #x70 #x6f #x73 #x69 #x74 #x69 #x6f #x6e #x00 #x47 #x00 #x04 #x00 #x09 #x00 #x00 #x00 #x1e #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x47 #x00 #x04 #x00 #x0c #x00 #x00 #x00 #x1e #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x48 #x00 #x05 #x00 #x16 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x0b #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x48 #x00 #x05 #x00 #x16 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x0b #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x48 #x00 #x05 #x00 #x16 #x00 #x00 #x00 #x02 #x00 #x00 #x00 #x0b #x00 #x00 #x00 #x03 #x00 #x00 #x00 #x48 #x00 #x05 #x00 #x16 #x00 #x00 #x00 #x03 #x00 #x00 #x00 #x0b #x00 #x00 #x00 #x04 #x00 #x00 #x00 #x47 #x00 #x03 #x00 #x16 #x00 #x00 #x00 #x02 #x00 #x00 #x00 #x48 #x00 #x04 #x00 #x1c #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x05 #x00 #x00 #x00 #x48 #x00 #x05 #x00 #x1c #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x23 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x48 #x00 #x05 #x00 #x1c #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x07 #x00 #x00 #x00 #x10 #x00 #x00 #x00 #x47 #x00 #x03 #x00 #x1c #x00 #x00 #x00 #x02 #x00 #x00 #x00 #x47 #x00 #x04 #x00 #x1e #x00 #x00 #x00 #x22 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x47 #x00 #x04 #x00 #x1e #x00 #x00 #x00 #x21 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x47 #x00 #x04 #x00 #x22 #x00 #x00 #x00 #x1e #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x13 #x00 #x02 #x00 #x02 #x00 #x00 #x00 #x21 #x00 #x03 #x00 #x03 #x00 #x00 #x00 #x02 #x00 #x00 #x00 #x16 #x00 #x03 #x00 #x06 #x00 #x00 #x00 #x20 #x00 #x00 #x00 #x17 #x00 #x04 #x00 #x07 #x00 #x00 #x00 #x06 #x00 #x00 #x00 #x04 #x00 #x00 #x00 #x20 #x00 #x04 #x00 #x08 #x00 #x00 #x00 #x03 #x00 #x00 #x00 #x07 #x00 #x00 #x00 #x3b #x00 #x04 #x00 #x08 #x00 #x00 #x00 #x09 #x00 #x00 #x00 #x03 #x00 #x00 #x00 #x17 #x00 #x04 #x00 #x0a #x00 #x00 #x00 #x06 #x00 #x00 #x00 #x03 #x00 #x00 #x00 #x20 #x00 #x04 #x00 #x0b #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x0a #x00 #x00 #x00 #x3b #x00 #x04 #x00 #x0b #x00 #x00 #x00 #x0c #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x2b #x00 #x04 #x00 #x06 #x00 #x00 #x00 #x0e #x00 #x00 #x00 #x00 #x00 #x80 #x3f #x15 #x00 #x04 #x00 #x13 #x00 #x00 #x00 #x20 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x2b #x00 #x04 #x00 #x13 #x00 #x00 #x00 #x14 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x1c #x00 #x04 #x00 #x15 #x00 #x00 #x00 #x06 #x00 #x00 #x00 #x14 #x00 #x00 #x00 #x1e #x00 #x06 #x00 #x16 #x00 #x00 #x00 #x07 #x00 #x00 #x00 #x06 #x00 #x00 #x00 #x15 #x00 #x00 #x00 #x15 #x00 #x00 #x00 #x20 #x00 #x04 #x00 #x17 #x00 #x00 #x00 #x03 #x00 #x00 #x00 #x16 #x00 #x00 #x00 #x3b #x00 #x04 #x00 #x17 #x00 #x00 #x00 #x18 #x00 #x00 #x00 #x03 #x00 #x00 #x00 #x15 #x00 #x04 #x00 #x19 #x00 #x00 #x00 #x20 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x2b #x00 #x04 #x00 #x19 #x00 #x00 #x00 #x1a #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x18 #x00 #x04 #x00 #x1b #x00 #x00 #x00 #x07 #x00 #x00 #x00 #x04 #x00 #x00 #x00 #x1e #x00 #x03 #x00 #x1c #x00 #x00 #x00 #x1b #x00 #x00 #x00 #x20 #x00 #x04 #x00 #x1d #x00 #x00 #x00 #x02 #x00 #x00 #x00 #x1c #x00 #x00 #x00 #x3b #x00 #x04 #x00 #x1d #x00 #x00 #x00 #x1e #x00 #x00 #x00 #x02 #x00 #x00 #x00 #x20 #x00 #x04 #x00 #x1f #x00 #x00 #x00 #x02 #x00 #x00 #x00 #x1b #x00 #x00 #x00 #x3b #x00 #x04 #x00 #x0b #x00 #x00 #x00 #x22 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x36 #x00 #x05 #x00 #x02 #x00 #x00 #x00 #x04 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x03 #x00 #x00 #x00 #xf8 #x00 #x02 #x00 #x05 #x00 #x00 #x00 #x3d #x00 #x04 #x00 #x0a #x00 #x00 #x00 #x0d #x00 #x00 #x00 #x0c #x00 #x00 #x00 #x51 #x00 #x05 #x00 #x06 #x00 #x00 #x00 #x0f #x00 #x00 #x00 #x0d #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x51 #x00 #x05 #x00 #x06 #x00 #x00 #x00 #x10 #x00 #x00 #x00 #x0d #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x51 #x00 #x05 #x00 #x06 #x00 #x00 #x00 #x11 #x00 #x00 #x00 #x0d #x00 #x00 #x00 #x02 #x00 #x00 #x00 #x50 #x00 #x07 #x00 #x07 #x00 #x00 #x00 #x12 #x00 #x00 #x00 #x0f #x00 #x00 #x00 #x10 #x00 #x00 #x00 #x11 #x00 #x00 #x00 #x0e #x00 #x00 #x00 #x3e #x00 #x03 #x00 #x09 #x00 #x00 #x00 #x12 #x00 #x00 #x00 #x41 #x00 #x05 #x00 #x1f #x00 #x00 #x00 #x20 #x00 #x00 #x00 #x1e #x00 #x00 #x00 #x1a #x00 #x00 #x00 #x3d #x00 #x04 #x00 #x1b #x00 #x00 #x00 #x21 #x00 #x00 #x00 #x20 #x00 #x00 #x00 #x3d #x00 #x04 #x00 #x0a #x00 #x00 #x00 #x23 #x00 #x00 #x00 #x22 #x00 #x00 #x00 #x51 #x00 #x05 #x00 #x06 #x00 #x00 #x00 #x24 #x00 #x00 #x00 #x23 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x51 #x00 #x05 #x00 #x06 #x00 #x00 #x00 #x25 #x00 #x00 #x00 #x23 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x51 #x00 #x05 #x00 #x06 #x00 #x00 #x00 #x26 #x00 #x00 #x00 #x23 #x00 #x00 #x00 #x02 #x00 #x00 #x00 #x50 #x00 #x07 #x00 #x07 #x00 #x00 #x00 #x27 #x00 #x00 #x00 #x24 #x00 #x00 #x00 #x25 #x00 #x00 #x00 #x26 #x00 #x00 #x00 #x0e #x00 #x00 #x00 #x91 #x00 #x05 #x00 #x07 #x00 #x00 #x00 #x28 #x00 #x00 #x00 #x21 #x00 #x00 #x00 #x27 #x00 #x00 #x00 #x41 #x00 #x05 #x00 #x08 #x00 #x00 #x00 #x29 #x00 #x00 #x00 #x18 #x00 #x00 #x00 #x1a #x00 #x00 #x00 #x3e #x00 #x03 #x00 #x29 #x00 #x00 #x00 #x28 #x00 #x00 #x00 #xfd #x00 #x01 #x00 #x38 #x00 #x01 #x00)) (define frag-spirv #vu8( #x03 #x02 #x23 #x07 #x00 #x00 #x01 #x00 #x0b #x00 #x08 #x00 #x0d #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x11 #x00 #x02 #x00 #x01 #x00 #x00 #x00 #x0b #x00 #x06 #x00 #x01 #x00 #x00 #x00 #x47 #x4c #x53 #x4c #x2e #x73 #x74 #x64 #x2e #x34 #x35 #x30 #x00 #x00 #x00 #x00 #x0e #x00 #x03 #x00 #x00 #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x0f #x00 #x07 #x00 #x04 #x00 #x00 #x00 #x04 #x00 #x00 #x00 #x6d #x61 #x69 #x6e #x00 #x00 #x00 #x00 #x09 #x00 #x00 #x00 #x0b #x00 #x00 #x00 #x10 #x00 #x03 #x00 #x04 #x00 #x00 #x00 #x07 #x00 #x00 #x00 #x03 #x00 #x03 #x00 #x02 #x00 #x00 #x00 #xc2 #x01 #x00 #x00 #x05 #x00 #x04 #x00 #x04 #x00 #x00 #x00 #x6d #x61 #x69 #x6e #x00 #x00 #x00 #x00 #x05 #x00 #x05 #x00 #x09 #x00 #x00 #x00 #x6f #x75 #x74 #x5f #x63 #x6f #x6c #x6f #x72 #x00 #x00 #x00 #x05 #x00 #x05 #x00 #x0b #x00 #x00 #x00 #x69 #x6e #x5f #x63 #x6f #x6c #x6f #x72 #x00 #x00 #x00 #x00 #x47 #x00 #x04 #x00 #x09 #x00 #x00 #x00 #x1e #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x47 #x00 #x04 #x00 #x0b #x00 #x00 #x00 #x1e #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x13 #x00 #x02 #x00 #x02 #x00 #x00 #x00 #x21 #x00 #x03 #x00 #x03 #x00 #x00 #x00 #x02 #x00 #x00 #x00 #x16 #x00 #x03 #x00 #x06 #x00 #x00 #x00 #x20 #x00 #x00 #x00 #x17 #x00 #x04 #x00 #x07 #x00 #x00 #x00 #x06 #x00 #x00 #x00 #x04 #x00 #x00 #x00 #x20 #x00 #x04 #x00 #x08 #x00 #x00 #x00 #x03 #x00 #x00 #x00 #x07 #x00 #x00 #x00 #x3b #x00 #x04 #x00 #x08 #x00 #x00 #x00 #x09 #x00 #x00 #x00 #x03 #x00 #x00 #x00 #x20 #x00 #x04 #x00 #x0a #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x07 #x00 #x00 #x00 #x3b #x00 #x04 #x00 #x0a #x00 #x00 #x00 #x0b #x00 #x00 #x00 #x01 #x00 #x00 #x00 #x36 #x00 #x05 #x00 #x02 #x00 #x00 #x00 #x04 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x03 #x00 #x00 #x00 #xf8 #x00 #x02 #x00 #x05 #x00 #x00 #x00 #x3d #x00 #x04 #x00 #x07 #x00 #x00 #x00 #x0c #x00 #x00 #x00 #x0b #x00 #x00 #x00 #x3e #x00 #x03 #x00 #x09 #x00 #x00 #x00 #x0c #x00 #x00 #x00 #xfd #x00 #x01 #x00 #x38 #x00 #x01 #x00)) (define data-vert #f32( ;; Front face. ;; Bottom left -0.5 0.5 -0.5 1.0 0.0 0.0 ; red 0.5 -0.5 -0.5 0.0 0.0 1.0 ; blue -0.5 -0.5 -0.5 0.0 1.0 0.0 ; green ;; Top right -0.5 0.5 -0.5 1.0 0.0 0.0 ; red 0.5 0.5 -0.5 1.0 1.0 0.0 ; yellow 0.5 -0.5 -0.5 0.0 0.0 1.0 ; blue ;; Left face ;; Bottom left -0.5 0.5 0.5 1.0 1.0 1.0 ; white -0.5 -0.5 -0.5 0.0 1.0 0.0 ; green -0.5 -0.5 0.5 0.0 1.0 1.0 ; cyan ;; Top right -0.5 0.5 0.5 1.0 1.0 1.0 ; white -0.5 0.5 -0.5 1.0 0.0 0.0 ; red -0.5 -0.5 -0.5 0.0 1.0 0.0 ; green ;; Top face ;; Bottom left -0.5 0.5 0.5 1.0 1.0 1.0 ; white 0.5 0.5 -0.5 1.0 1.0 0.0 ; yellow -0.5 0.5 -0.5 1.0 0.0 0.0 ; red ;; Top right -0.5 0.5 0.5 1.0 1.0 1.0 ; white 0.5 0.5 0.5 0.0 0.0 0.0 ; black 0.5 0.5 -0.5 1.0 1.0 0.0 ; yellow ;; Right face ;; Bottom left 0.5 0.5 -0.5 1.0 1.0 0.0 ; yellow 0.5 -0.5 0.5 1.0 0.0 1.0 ; magenta 0.5 -0.5 -0.5 0.0 0.0 1.0 ; blue ;; Top right 0.5 0.5 -0.5 1.0 1.0 0.0 ; yellow 0.5 0.5 0.5 0.0 0.0 0.0 ; black 0.5 -0.5 0.5 1.0 0.0 1.0 ; magenta ;; Back face ;; Bottom left 0.5 0.5 0.5 0.0 0.0 0.0 ; black -0.5 -0.5 0.5 0.0 1.0 1.0 ; cyan 0.5 -0.5 0.5 1.0 0.0 1.0 ; magenta ;; Top right 0.5 0.5 0.5 0.0 0.0 0.0 ; black -0.5 0.5 0.5 1.0 1.0 1.0 ; white -0.5 -0.5 0.5 0.0 1.0 1.0 ; cyan ;; Bottom face ;; Bottom left -0.5 -0.5 -0.5 0.0 1.0 0.0 ; green 0.5 -0.5 0.5 1.0 0.0 1.0 ; magenta -0.5 -0.5 0.5 0.0 1.0 1.0 ; cyan ;; Top right -0.5 -0.5 -0.5 0.0 1.0 0.0 ; green 0.5 -0.5 -0.5 0.0 0.0 1.0 ; blue 0.5 -0.5 0.5 1.0 0.0 1.0 ; magenta )) ;; Initialize SDL. All we need is the video subsystem. (sdl-init '(video)) ;; Open window. (define window (make-window "SDL3 GPU" 800 600)) ;; Create GPU device. (define device (make-gpu-device '(spirv))) (claim-window-for-gpu-device! device window) ;; Create shaders. (define shader-vert (make-gpu-shader device 'vertex 'spirv vert-spirv #:uniform-buffers 1)) (define shader-frag (make-gpu-shader device 'fragment 'spirv frag-spirv)) ;; Create empty vertex buffer (define nbytes-vert (bytevector-length data-vert)) (define buffer-vert (make-gpu-buffer device nbytes-vert '(vertex))) (set-gpu-buffer-name! device buffer-vert "vertex buffer") ;; Create transfer buffer and copy vertex data into it. (define buffer-transfer (make-gpu-transfer-buffer device nbytes-vert 'upload)) (define mapped (map-gpu-transfer-buffer! device buffer-transfer nbytes-vert)) (bytevector-copy! data-vert 0 mapped 0 nbytes-vert) (unmap-gpu-transfer-buffer! device buffer-transfer) ;; Upload vertex data to vertex buffer. (define cmd (acquire-gpu-command-buffer device)) (define copy-pass (begin-gpu-copy-pass cmd)) (upload-to-gpu-buffer copy-pass buffer-transfer 0 buffer-vert 0 nbytes-vert) (end-gpu-copy-pass copy-pass) (submit-gpu-command-buffer! cmd) (release-gpu-transfer-buffer! device buffer-transfer) ;; Figure out our sample rate. (define swapchain-texture-format (gpu-swapchain-texture-format device window)) (define sample-count (if (gpu-texture-supports-sample-count? device swapchain-texture-format 4) 4 1)) ;; Setup graphics pipeline. (define color-target-desc (make-gpu-color-target-description #:format swapchain-texture-format)) (define target-info (make-gpu-graphics-pipeline-target-info #:color-targets (vector color-target-desc) #:depth-stencil-format 'd16-unorm)) (define depth-stencil-state (make-gpu-depth-stencil-state #:compare-op 'less-or-equal)) (define multisample-state (make-gpu-multisample-state #:sample-count sample-count)) (define vertex-buffer-desc (make-gpu-vertex-buffer-description #:slot 0 #:pitch (* 4 6))) (define vertex-attrib-position (make-gpu-vertex-attribute #:buffer-slot 0 #:format 'float3 #:location 0)) (define vertex-attrib-color (make-gpu-vertex-attribute #:buffer-slot 0 #:format 'float3 #:location 1 #:offset (* 4 3))) (define vertex-input-state (make-gpu-vertex-input-state #:vertex-buffer-descriptions (vector vertex-buffer-desc) #:vertex-attributes (vector vertex-attrib-position vertex-attrib-color))) (define pipeline (make-gpu-graphics-pipeline device #:vertex-shader shader-vert #:fragment-shader shader-frag #:vertex-input-state vertex-input-state #:multisample-state multisample-state #:depth-stencil-state depth-stencil-state #:target-info target-info)) ;; Shaders can be released once the pipeline has been built. (release-gpu-shader! device shader-vert) (release-gpu-shader! device shader-frag) ;; Create textures. (define-values (width height) (window-size-in-pixels window)) (define tex-depth (make-gpu-texture device #:format 'd16-unorm #:width width #:height height #:sample-count sample-count #:usage '(depth-stencil-target))) (define tex-msaa (make-gpu-texture device #:format swapchain-texture-format #:width width #:height height #:sample-count sample-count)) (define tex-resolve (make-gpu-texture device #:format swapchain-texture-format #:width width #:height height #:usage '(color-target sampler))) ;; Transformation matrices. (define pi 3.1415926535897932) (define tau (* 2.0 pi)) (define-bstruct (array 16 f32)) (define (make-mat4) (bstruct-alloc )) (define (make-identity-mat4) (bstruct-alloc (0 1.0) (1 0.0) (2 0.0) (3 0.0) (4 0.0) (5 1.0) (6 0.0) (7 0.0) (8 0.0) (9 0.0) (10 1.0) (11 0.0) (12 0.0) (13 0.0) (14 0.0) (15 1.0))) (define (mat4-identity! m) (bstruct-set! m (0 1.0) (1 0.0) (2 0.0) (3 0.0) (4 0.0) (5 1.0) (6 0.0) (7 0.0) (8 0.0) (9 0.0) (10 1.0) (11 0.0) (12 0.0) (13 0.0) (14 0.0) (15 1.0))) (define (mat4-perspective! m fovy aspect znear zfar) (let ((f (/ 1.0 (tan (* fovy 0.5))))) (bstruct-set! m (0 (/ f aspect)) (1 0.0) (2 0.0) (3 0.0) (4 0.0) (5 f) (6 0.0) (7 0.0) (8 0.0) (9 0.0) (10 (/ (+ znear zfar) (- znear zfar))) (11 -1.0) (12 0.0) (13 0.0) (14 (/ (* 2.0 znear zfar) (- znear zfar))) (15 0.0)))) (define (mat4-rotate! m angle x y z) (let* ((c (cos angle)) (s (sin angle)) (xx (* x x)) (yy (* y y)) (zz (* z z)) (xy (* x y)) (xz (* x z)) (yz (* y z))) (bstruct-set! m (0 (+ xx (* c (- 1.0 xx)))) (1 (+ (- xy (* c xy)) (* s z))) (2 (- xz (* c xz) (* s y))) (3 0.0) (4 (- xy (* c xy) (* s z))) (5 (+ yy (* c (- 1.0 yy)))) (6 (+ (- yz (* c yz)) (* s x))) (7 0.0) (8 (+ (- xz (* c xz)) (* s y))) (9 (- yz (* c yz) (* s x))) (10 (+ zz (* c (- 1.0 zz)))) (11 0.0) (12 0.0) (13 0.0) (14 0.0) (15 1.0)))) (define (mat4-mult! a b c) (let ((a0 (bstruct-ref a 0)) (a1 (bstruct-ref a 1)) (a2 (bstruct-ref a 2)) (a3 (bstruct-ref a 3)) (a4 (bstruct-ref a 4)) (a5 (bstruct-ref a 5)) (a6 (bstruct-ref a 6)) (a7 (bstruct-ref a 7)) (a8 (bstruct-ref a 8)) (a9 (bstruct-ref a 9)) (a10 (bstruct-ref a 10)) (a11 (bstruct-ref a 11)) (a12 (bstruct-ref a 12)) (a13 (bstruct-ref a 13)) (a14 (bstruct-ref a 14)) (a15 (bstruct-ref a 15)) (b0 (bstruct-ref b 0)) (b1 (bstruct-ref b 1)) (b2 (bstruct-ref b 2)) (b3 (bstruct-ref b 3)) (b4 (bstruct-ref b 4)) (b5 (bstruct-ref b 5)) (b6 (bstruct-ref b 6)) (b7 (bstruct-ref b 7)) (b8 (bstruct-ref b 8)) (b9 (bstruct-ref b 9)) (b10 (bstruct-ref b 10)) (b11 (bstruct-ref b 11)) (b12 (bstruct-ref b 12)) (b13 (bstruct-ref b 13)) (b14 (bstruct-ref b 14)) (b15 (bstruct-ref b 15))) (bstruct-set! c (0 (+ (* a0 b0) (* a1 b4) (* a2 b8) (* a3 b12))) (1 (+ (* a0 b1) (* a1 b5) (* a2 b9) (* a3 b13))) (2 (+ (* a0 b2) (* a1 b6) (* a2 b10) (* a3 b14))) (3 (+ (* a0 b3) (* a1 b7) (* a2 b11) (* a3 b15))) (4 (+ (* a4 b0) (* a5 b4) (* a6 b8) (* a7 b12))) (5 (+ (* a4 b1) (* a5 b5) (* a6 b9) (* a7 b13))) (6 (+ (* a4 b2) (* a5 b6) (* a6 b10) (* a7 b14))) (7 (+ (* a4 b3) (* a5 b7) (* a6 b11) (* a7 b15))) (8 (+ (* a8 b0) (* a9 b4) (* a10 b8) (* a11 b12))) (9 (+ (* a8 b1) (* a9 b5) (* a10 b9) (* a11 b13))) (10 (+ (* a8 b2) (* a9 b6) (* a10 b10) (* a11 b14))) (11 (+ (* a8 b3) (* a9 b7) (* a10 b11) (* a11 b15))) (12 (+ (* a12 b0) (* a13 b4) (* a14 b8) (* a15 b12))) (13 (+ (* a12 b1) (* a13 b5) (* a14 b9) (* a15 b13))) (14 (+ (* a12 b2) (* a13 b6) (* a14 b10) (* a15 b14))) (15 (+ (* a12 b3) (* a13 b7) (* a14 b11) (* a15 b15)))))) (define perspective (make-mat4)) (define modelview (make-mat4)) (define rotation (make-mat4)) (define mvp (make-mat4)) (define angle-x 0.0) (define angle-y 0.0) (define angle-z 0.0) (define aspect-ratio (exact->inexact (/ width height))) ;; Setup various command buffer state. (define vertex-bindings (vector (make-gpu-buffer-binding buffer-vert))) (define main-color-target (if (= sample-count 1) (make-gpu-color-target #f #:load-op 'clear) (make-gpu-color-target tex-msaa #:load-op 'clear #:store-op 'resolve #:resolve-texture tex-resolve #:cycle? #t #:cycle-resolve-texture? #t))) (define blit-info (and (> sample-count 1) (make-gpu-blit-info #:source-texture tex-resolve #:source-width width #:source-height height #:destination-texture tex-resolve #:destination-width width #:destination-height height))) (define color-targets (vector main-color-target)) (define depth-target (make-gpu-depth-stencil-target tex-depth #:load-op 'clear #:clear-depth 1.0 #:cycle? #t)) (define (render) (define cmd (acquire-gpu-command-buffer device)) ;; TODO: This could fail. Catch exception and try again next frame ;; in that case. (define-values (tex-swapchain width height) (acquire-gpu-swapchain-texture cmd window)) ;; Setup transformation matrix. (mat4-rotate! modelview angle-x 1.0 0.0 0.0) (mat4-rotate! rotation angle-y 0.0 1.0 0.0) (mat4-mult! modelview rotation modelview) (mat4-rotate! rotation angle-z 0.0 1.0 0.0) (mat4-mult! modelview rotation modelview) (let ((z (bstruct-ref modelview 14))) (bstruct-set! modelview (14 (- z 2.5)))) (mat4-perspective! perspective 45.0 aspect-ratio 0.01 100.0) (mat4-mult! modelview perspective mvp) ;; Setup matrix uniform buffer. (call-with-values (lambda () (bstruct-unwrap mvp)) (lambda (bv offset) (push-gpu-vertex-uniform-data cmd 0 bv (bstruct-sizeof ) offset))) ;; Step rotation. (set! angle-x (+ angle-x 0.03)) (set! angle-y (+ angle-y 0.02)) (set! angle-z (+ angle-z 0.01)) (when (>= angle-x tau) (set! angle-x (- angle-x tau))) (when (>= angle-y tau) (set! angle-y (- angle-y tau))) (when (>= angle-z tau) (set! angle-z (- angle-z tau))) ;; Write directly to swapchain texture when not multisampling. (when (= sample-count 1) (set-gpu-color-target-texture! main-color-target tex-swapchain)) ;; Draw the cube! (define pass (begin-gpu-render-pass cmd color-targets depth-target)) (bind-gpu-graphics-pipeline pass pipeline) (bind-gpu-vertex-buffers pass 0 vertex-bindings) (draw-gpu-primitives pass 36 1) (end-gpu-render-pass pass) ;; Blit to swapchain texture when multisampling. (when (> sample-count 1) (set-gpu-blit-info-destination-texture! blit-info tex-swapchain) (blit-gpu-texture cmd blit-info)) ;; Submit commands! (submit-gpu-command-buffer! cmd)) (define (handle-events) (match (poll-event) (#f #t) (event (match (event-type event) ((or 'quit 'key-down) #f) (_ (handle-events)))))) (let lp () (when (handle-events) (render) (lp))) (release-gpu-texture! device tex-depth) (release-gpu-texture! device tex-msaa) (release-gpu-texture! device tex-resolve) (release-gpu-graphics-pipeline! device pipeline) (release-gpu-buffer! device buffer-vert) (release-window-from-gpu-device! device window) (destroy-gpu-device! device) (destroy-window! window)