diff options
Diffstat (limited to 'chickadee')
-rw-r--r-- | chickadee/color.scm | 182 | ||||
-rw-r--r-- | chickadee/config.scm.in | 36 | ||||
-rw-r--r-- | chickadee/input/controller.scm | 87 | ||||
-rw-r--r-- | chickadee/math.scm | 26 | ||||
-rw-r--r-- | chickadee/math/matrix.scm | 315 | ||||
-rw-r--r-- | chickadee/math/vector.scm | 201 | ||||
-rw-r--r-- | chickadee/render.scm | 135 | ||||
-rw-r--r-- | chickadee/render/blend.scm | 73 | ||||
-rw-r--r-- | chickadee/render/gl.scm | 275 | ||||
-rw-r--r-- | chickadee/render/gpu.scm | 64 | ||||
-rw-r--r-- | chickadee/render/shader.scm | 346 | ||||
-rw-r--r-- | chickadee/render/shapes.scm | 205 | ||||
-rw-r--r-- | chickadee/render/sprite.scm | 282 | ||||
-rw-r--r-- | chickadee/render/texture.scm | 191 | ||||
-rw-r--r-- | chickadee/render/vertex-buffer.scm | 261 | ||||
-rw-r--r-- | chickadee/window.scm | 89 |
16 files changed, 2768 insertions, 0 deletions
diff --git a/chickadee/color.scm b/chickadee/color.scm new file mode 100644 index 0000000..e40deb4 --- /dev/null +++ b/chickadee/color.scm @@ -0,0 +1,182 @@ +;;; 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/>. + +;;; Commentary: +;; +;; Colors! +;; +;;; Code: + +(define-module (chickadee color) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-1) + #:use-module (chickadee math) + #:export (<color> + make-color + color? + color-r color-g color-b color-a + rgba rgb transparency + color* color+ color- color-inverse color-lerp + + white black red green blue yellow magenta cyan transparent + tango-light-butter tango-butter tango-dark-butter + tango-light-orange tango-orange tango-dark-orange + tango-light-chocolate tango-chocolate tango-dark-chocolate + tango-light-chameleon tango-chameleon tango-dark-chameleon + tango-light-sky-blue tango-sky-blue tango-dark-sky-blue + tango-light-plum tango-plum tango-dark-plum + tango-light-scarlet-red tango-scarlet-red tango-dark-scarlet-red + tango-aluminium-1 tango-aluminium-2 tango-aluminium-3 + tango-aluminium-4 tango-aluminium-5 tango-aluminium-6)) + +(define-record-type <color> + (%make-color r g b a) + color? + (r color-r) + (g color-g) + (b color-b) + (a color-a)) + +(define (make-color r g b a) + "Return a newly allocated color with the given RGBA channel values. +Each channel is clamped to the range [0, 1]." + (%make-color (clamp 0 1 r) + (clamp 0 1 g) + (clamp 0 1 b) + (clamp 0 1 a))) + +(define (color-component color-code offset) + "Return the value of an 8-bit color channel in the range [0,1] for +the integer COLOR-CODE, given an OFFSET in bits." + (let ((mask (ash #xff offset))) + (/ (ash (logand mask color-code) + (- offset)) + 255.0))) + +(define (rgba color-code) + "Translate an RGBA format string COLOR-CODE into a color object. +For example: #xffffffff will return a color with RGBA values 1, 1, 1, +1." + (%make-color (color-component color-code 24) + (color-component color-code 16) + (color-component color-code 8) + (color-component color-code 0))) + +(define (rgb color-code) + "Translate an RGB format string COLOR-CODE into a color object. +For example: #xffffff will return a color with RGBA values 1, 1, 1, +1." + (%make-color (color-component color-code 16) + (color-component color-code 8) + (color-component color-code 0) + 1.0)) + +(define (transparency alpha) + "Create a new color that is white with a transparency value of +ALPHA. ALPHA is clamped to the range [0, 1]." + (make-color 1 1 1 alpha)) + +;; (define-method (* (a <<color>>) (b <<color>>)) +;; (make-color (* (color-r a) (color-r b)) +;; (* (color-g a) (color-g b)) +;; (* (color-b a) (color-b b)) +;; (* (color-a a) (color-a b)))) + +(define color* + (match-lambda* + ((($ <color> r1 g1 b1 a1) ($ <color> r2 g2 b2 a2)) + (make-color (* r1 r2) + (* g1 g2) + (* b1 b2) + (* a1 a2))) + ((($ <color> r g b a) (? number? k)) + (make-color (* r k) + (* g k) + (* b k) + (* a k))))) + +(define color+ + (match-lambda* + ((($ <color> r1 g1 b1 a1) ($ <color> r2 g2 b2 a2)) + (make-color (+ r1 r2) + (+ g1 g2) + (+ b1 b2) + (+ a1 a2))))) + +(define color- + (match-lambda* + ((($ <color> r1 g1 b1 a1) ($ <color> r2 g2 b2 a2)) + (make-color (- r1 r2) + (- g1 g2) + (- b1 b2) + (- a1 a2))))) + +(define color-inverse + (match-lambda + (($ <color> r g b a) + (make-color (- 1 r) + (- 1 g) + (- 1 b) + a)))) ; Do not alter alpha channel. + +;;(define color-lerp (make-lerp color+ color*)) + +;;; +;;; Pre-defined Colors +;;; + +;; Basic +(define white (rgb #xffffff)) +(define black (rgb #x000000)) +(define red (rgb #xff0000)) +(define green (rgb #x00ff00)) +(define blue (rgb #x0000ff)) +(define yellow (rgb #xffff00)) +(define magenta (rgb #xff00ff)) +(define cyan (rgb #x00ffff)) +(define transparent (make-color 0 0 0 0)) + +;; Tango color pallete +;; http://tango.freedesktop.org +(define tango-light-butter (rgb #xfce94f)) +(define tango-butter (rgb #xedd400)) +(define tango-dark-butter (rgb #xc4a000)) +(define tango-light-orange (rgb #xfcaf3e)) +(define tango-orange (rgb #xf57900)) +(define tango-dark-orange (rgb #xce5c00)) +(define tango-light-chocolate (rgb #xe9b96e)) +(define tango-chocolate (rgb #xc17d11)) +(define tango-dark-chocolate (rgb #x8f5902)) +(define tango-light-chameleon (rgb #x8ae234)) +(define tango-chameleon (rgb #x73d216)) +(define tango-dark-chameleon (rgb #x4e9a06)) +(define tango-light-sky-blue (rgb #x729fcf)) +(define tango-sky-blue (rgb #x3465a4)) +(define tango-dark-sky-blue (rgb #x204a87)) +(define tango-light-plum (rgb #xad7fa8)) +(define tango-plum (rgb #x75507b)) +(define tango-dark-plum (rgb #x5c3566)) +(define tango-light-scarlet-red (rgb #xef2929)) +(define tango-scarlet-red (rgb #xcc0000)) +(define tango-dark-scarlet-red (rgb #xa40000)) +(define tango-aluminium-1 (rgb #xeeeeec)) +(define tango-aluminium-2 (rgb #xd3d7cf)) +(define tango-aluminium-3 (rgb #xbabdb6)) +(define tango-aluminium-4 (rgb #x888a85)) +(define tango-aluminium-5 (rgb #x555753)) +(define tango-aluminium-6 (rgb #x2e3436)) diff --git a/chickadee/config.scm.in b/chickadee/config.scm.in new file mode 100644 index 0000000..86aaeb5 --- /dev/null +++ b/chickadee/config.scm.in @@ -0,0 +1,36 @@ +;;; 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 Lesser 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 Lesser General +;;; Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Build time configuration. +;; +;;; Code: + +(define-module (chickadee config) + #:export (%datadir + %sly-version + scope-datadir)) + +(define %datadir + (or (getenv "SLY_DATADIR") "@chickadee_datadir@/chickadee")) + +(define %chickadee-version "@PACKAGE_VERSION@") + +(define (scope-datadir file) + "Append the Chickadee data directory to FILE." + (string-append %datadir file)) diff --git a/chickadee/input/controller.scm b/chickadee/input/controller.scm new file mode 100644 index 0000000..e78623e --- /dev/null +++ b/chickadee/input/controller.scm @@ -0,0 +1,87 @@ +;;; 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 input controller) + #:use-module (srfi srfi-9) + #:use-module (sdl2) + #:use-module ((sdl2 input game-controller) #:prefix sdl2:) + #:use-module ((sdl2 input joystick) #:prefix sdl2:) + #:export (controller? + controller-name + controller-power-level + controller-button-pressed? + controller-axis)) + +(define-record-type <controller> + (wrap-controller sdl-controller) + controller? + (sdl-controller unwrap-controller)) + +(define %controllers (make-hash-table)) + +(define (open-controller index) + (let* ((sdl-controller (sdl2:open-game-controller index)) + (controller (wrap-controller sdl-controller))) + ;; Register controller in global hash table for future lookup. + (hash-set! %controllers + (sdl2:joystick-instance-id + (sdl2:game-controller-joystick sdl-controller)) + controller) + controller)) + +(define (close-controller controller) + (hash-remove! %controllers + (sdl2:joystick-instance-id + (sdl2:game-controller-joystick + (unwrap-controller controller)))) + (sdl2:close-game-controller (unwrap-controller controller))) + +(define (lookup-controller instance-id) + (hash-ref %controllers instance-id)) + +(define (controller-name controller) + "Return the human readable model name of CONTROLLER." + (sdl2:game-controller-name (unwrap-controller controller))) + +(define (controller-power-level controller) + "Return the symbolic power level for CONTROLLER. + +Possible return values are: +- unknown +- empty +- low +- medium +- full +- wired" + (sdl2:joystick-power-level + (sdl2:game-controller-joystick + (unwrap-controller controller)))) + +(define (controller-connected? controller) + "Return #t if CONTROLLER is currently in use." + (sdl2:game-controller-attached? (unwrap-controller controller))) + +(define (controller-button-pressed? controller button) + "Return #t if BUTTON is currently being pressed on CONTROLLER." + (sdl2:game-controller-button-pressed? (unwrap-controller controller) button)) + +(define (controller-axis controller axis) + "Return a floating point value in the range [-1, 1] corresponding to +how much AXIS is being pushed on CONTROLLER. 0 is returned if AXIS is +not being pushed at all." + (/ (sdl2:game-controller-axis (unwrap-controller controller) axis) + 32768.0)) diff --git a/chickadee/math.scm b/chickadee/math.scm new file mode 100644 index 0000000..753f70d --- /dev/null +++ b/chickadee/math.scm @@ -0,0 +1,26 @@ +;;; 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 math) + #:export (clamp)) + +(define (clamp min max x) + "Restrict X to the range defined by MIN and MAX. Assumes that MIN is +actually less than MAX." + (cond ((< x min) min) + ((> x max) max) + (else x))) diff --git a/chickadee/math/matrix.scm b/chickadee/math/matrix.scm new file mode 100644 index 0000000..be307ab --- /dev/null +++ b/chickadee/math/matrix.scm @@ -0,0 +1,315 @@ +;;; 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 math matrix) + #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-4) + #:use-module (system foreign) + #:use-module (chickadee math vector) + #:export (make-matrix4 + make-null-matrix4 + matrix4? + matrix4-mult! + matrix4* + matrix4-identity! + make-identity-matrix4 + orthographic-projection + matrix4-translate! + matrix4-translate + matrix4-scale! + matrix4-scale + matrix4-rotate-z! + matrix4-rotate-z + transform)) + +;; 4x4 matrix +(define-record-type <matrix4> + (%make-matrix4 bv ptr) + matrix4? + (bv matrix4-bv) + (ptr matrix4-ptr)) + +(define-inlinable (matrix-set! matrix row column x) + (f32vector-set! matrix (+ (* row 4) column) x)) + +(define-inlinable (matrix-ref matrix row column) + (f32vector-ref matrix (+ (* row 4) column))) + +(define (init-matrix4 matrix + aa ab ac ad + ba bb bc bd + ca cb cc cd + da db dc dd) + (let ((bv (matrix4-bv matrix))) + (matrix-set! bv 0 0 aa) + (matrix-set! bv 0 1 ab) + (matrix-set! bv 0 2 ac) + (matrix-set! bv 0 3 ad) + (matrix-set! bv 1 0 ba) + (matrix-set! bv 1 1 bb) + (matrix-set! bv 1 2 bc) + (matrix-set! bv 1 3 bd) + (matrix-set! bv 2 0 ca) + (matrix-set! bv 2 1 cb) + (matrix-set! bv 2 2 cc) + (matrix-set! bv 2 3 cd) + (matrix-set! bv 3 0 da) + (matrix-set! bv 3 1 db) + (matrix-set! bv 3 2 dc) + (matrix-set! bv 3 3 dd))) + +(define (make-null-matrix4) + (let ((bv (make-f32vector 16))) + (%make-matrix4 bv (bytevector->pointer bv)))) + +(define (make-matrix4 aa ab ac ad + ba bb bc bd + ca cb cc cd + da db dc dd) + "Return a new 4x4 matrix initialized with the given 16 values in +column-major format." + (let ((matrix (make-null-matrix4))) + (init-matrix4 matrix + aa ab ac ad + ba bb bc bd + ca cb cc cd + da db dc dd) + matrix)) + +(define (matrix4-mult! dest a b) + "Multiply matrices A and B, storing the result in DEST." + (let ((m1 (matrix4-bv a)) + (m2 (matrix4-bv b)) + (m3 (matrix4-bv dest))) + (let ((m1-0-0 (matrix-ref m1 0 0)) + (m1-0-1 (matrix-ref m1 0 1)) + (m1-0-2 (matrix-ref m1 0 2)) + (m1-0-3 (matrix-ref m1 0 3)) + (m1-1-0 (matrix-ref m1 1 0)) + (m1-1-1 (matrix-ref m1 1 1)) + (m1-1-2 (matrix-ref m1 1 2)) + (m1-1-3 (matrix-ref m1 1 3)) + (m1-2-0 (matrix-ref m1 2 0)) + (m1-2-1 (matrix-ref m1 2 1)) + (m1-2-2 (matrix-ref m1 2 2)) + (m1-2-3 (matrix-ref m1 2 3)) + (m1-3-0 (matrix-ref m1 3 0)) + (m1-3-1 (matrix-ref m1 3 1)) + (m1-3-2 (matrix-ref m1 3 2)) + (m1-3-3 (matrix-ref m1 3 3)) + (m2-0-0 (matrix-ref m2 0 0)) + (m2-0-1 (matrix-ref m2 0 1)) + (m2-0-2 (matrix-ref m2 0 2)) + (m2-0-3 (matrix-ref m2 0 3)) + (m2-1-0 (matrix-ref m2 1 0)) + (m2-1-1 (matrix-ref m2 1 1)) + (m2-1-2 (matrix-ref m2 1 2)) + (m2-1-3 (matrix-ref m2 1 3)) + (m2-2-0 (matrix-ref m2 2 0)) + (m2-2-1 (matrix-ref m2 2 1)) + (m2-2-2 (matrix-ref m2 2 2)) + (m2-2-3 (matrix-ref m2 2 3)) + (m2-3-0 (matrix-ref m2 3 0)) + (m2-3-1 (matrix-ref m2 3 1)) + (m2-3-2 (matrix-ref m2 3 2)) + (m2-3-3 (matrix-ref m2 3 3))) + (matrix-set! m3 0 0 + (+ (* m1-0-0 m2-0-0) + (* m1-0-1 m2-1-0) + (* m1-0-2 m2-2-0) + (* m1-0-3 m2-3-0))) + (matrix-set! m3 0 1 + (+ (* m1-0-0 m2-0-1) + (* m1-0-1 m2-1-1) + (* m1-0-2 m2-2-1) + (* m1-0-3 m2-3-1))) + (matrix-set! m3 0 2 + (+ (* m1-0-0 m2-0-2) + (* m1-0-1 m2-1-2) + (* m1-0-2 m2-2-2) + (* m1-0-3 m2-3-2))) + (matrix-set! m3 0 3 + (+ (* m1-0-0 m2-0-3) + (* m1-0-1 m2-1-3) + (* m1-0-2 m2-2-3) + (* m1-0-3 m2-3-3))) + (matrix-set! m3 1 0 + (+ (* m1-1-0 m2-0-0) + (* m1-1-1 m2-1-0) + (* m1-1-2 m2-2-0) + (* m1-1-3 m2-3-0))) + (matrix-set! m3 1 1 + (+ (* m1-1-0 m2-0-1) + (* m1-1-1 m2-1-1) + (* m1-1-2 m2-2-1) + (* m1-1-3 m2-3-1))) + (matrix-set! m3 1 2 + (+ (* m1-1-0 m2-0-2) + (* m1-1-1 m2-1-2) + (* m1-1-2 m2-2-2) + (* m1-1-3 m2-3-2))) + (matrix-set! m3 1 3 + (+ (* m1-1-0 m2-0-3) + (* m1-1-1 m2-1-3) + (* m1-1-2 m2-2-3) + (* m1-1-3 m2-3-3))) + (matrix-set! m3 2 0 + (+ (* m1-2-0 m2-0-0) + (* m1-2-1 m2-1-0) + (* m1-2-2 m2-2-0) + (* m1-2-3 m2-3-0))) + (matrix-set! m3 2 1 + (+ (* m1-2-0 m2-0-1) + (* m1-2-1 m2-1-1) + (* m1-2-2 m2-2-1) + (* m1-2-3 m2-3-1))) + (matrix-set! m3 2 2 + (+ (* m1-2-0 m2-0-2) + (* m1-2-1 m2-1-2) + (* m1-2-2 m2-2-2) + (* m1-2-3 m2-3-2))) + (matrix-set! m3 2 3 + (+ (* m1-2-0 m2-0-3) + (* m1-2-1 m2-1-3) + (* m1-2-2 m2-2-3) + (* m1-2-3 m2-3-3))) + (matrix-set! m3 3 0 + (+ (* m1-3-0 m2-0-0) + (* m1-3-1 m2-1-0) + (* m1-3-2 m2-2-0) + (* m1-3-3 m2-3-0))) + (matrix-set! m3 3 1 + (+ (* m1-3-0 m2-0-1) + (* m1-3-1 m2-1-1) + (* m1-3-2 m2-2-1) + (* m1-3-3 m2-3-1))) + (matrix-set! m3 3 2 + (+ (* m1-3-0 m2-0-2) + (* m1-3-1 m2-1-2) + (* m1-3-2 m2-2-2) + (* m1-3-3 m2-3-2))) + (matrix-set! m3 3 3 + (+ (* m1-3-0 m2-0-3) + (* m1-3-1 m2-1-3) + (* m1-3-2 m2-2-3) + (* m1-3-3 m2-3-3)))))) + +(define (matrix4-copy matrix) + (let ((bv (bytevector-copy (matrix4-bv matrix)))) + (%make-matrix4 bv (bytevector->pointer bv)))) + +(define (matrix4* . matrices) + "Return the product of MATRICES." + (match matrices + (() (make-identity-matrix4)) + ((a b) + (let ((result (make-identity-matrix4))) + (matrix4-mult! result a b) + result)) + ((first . rest) + (let loop ((temp (make-identity-matrix4)) + (prev (matrix4-copy first)) + (matrices rest)) + (match matrices + (() prev) + ((current . rest) + (matrix4-mult! temp prev current) + (loop prev temp rest))))))) + +(define (matrix4-identity! matrix) + (init-matrix4 matrix + 1.0 0.0 0.0 0.0 + 0.0 1.0 0.0 0.0 + 0.0 0.0 1.0 0.0 + 0.0 0.0 0.0 1.0)) + +(define (make-identity-matrix4) + (let ((matrix (make-null-matrix4))) + (matrix4-identity! matrix) + matrix)) + +(define (orthographic-projection left right top bottom near far) + "Return a new transform that represents an orthographic projection +for the vertical clipping plane LEFT and RIGHT, the horizontal +clipping plane TOP and BOTTOM, and the depth clipping plane NEAR and +FAR." + (make-matrix4 (/ 2 (- right left)) 0 0 0 + 0 (/ 2 (- top bottom)) 0 0 + 0 0 (/ 2 (- far near)) 0 + (- (/ (+ right left) (- right left))) + (- (/ (+ top bottom) (- top bottom))) + (- (/ (+ far near) (- far near))) + 1)) + +(define (matrix4-translate! matrix v) + (cond + ((vector2? v) + (init-matrix4 matrix + 1 0 0 0 + 0 1 0 0 + 0 0 1 0 + (vx v) (vy v) 0 1)) + ((vector3? v) + (init-matrix4 matrix + 1 0 0 0 + 0 1 0 0 + 0 0 1 0 + (vx v) (vy v) (vz v) 1)) + (else + (error "invalid translation vector" v)))) + +(define (matrix4-translate v) + (let ((matrix (make-null-matrix4))) + (matrix4-translate! matrix v) + matrix)) + +(define (matrix4-scale! matrix s) + (init-matrix4 matrix + s 0.0 0.0 0.0 + 0.0 s 0.0 0.0 + 0.0 0.0 s 0.0 + 0.0 0.0 0.0 1.0)) + +(define (matrix4-scale s) + (let ((matrix (make-null-matrix4))) + (matrix4-scale! matrix s) + matrix)) + +(define (matrix4-rotate-z! matrix angle) + (init-matrix4 matrix + (cos angle) (- (sin angle)) 0.0 0.0 + (sin angle) (cos angle) 0.0 0.0 + 0.0 0.0 1.0 0.0 + 0.0 0.0 0.0 1.0)) + +(define (matrix4-rotate-z angle) + "Return a new matrix that rotates the Z axis by ANGLE radians." + (let ((matrix (make-null-matrix4))) + (matrix4-rotate-z! matrix angle) + matrix)) + +(define (transform matrix x y) + (let ((bv (matrix4-bv matrix))) + (values (+ (* x (matrix-ref bv 0 0)) + (* y (matrix-ref bv 1 0)) + (matrix-ref bv 3 0)) + (+ (* x (matrix-ref bv 0 1)) + (* y (matrix-ref bv 1 1)) + (matrix-ref bv 3 1))))) diff --git a/chickadee/math/vector.scm b/chickadee/math/vector.scm new file mode 100644 index 0000000..66a21fd --- /dev/null +++ b/chickadee/math/vector.scm @@ -0,0 +1,201 @@ +;;; 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 math vector) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:export (<vector2> + <vector3> + <vector4> + vector2 vector3 vector4 + vector2? vector3? vector4? + polar2 + vx vy vz vw + + vadd! vmul! + vx-in-range? vy-in-range? + + vmap v+ v- v* vdot vcross + magnitude normalize + anchor-vector) + #:replace (magnitude)) + +(define-inlinable (square x) + (* x x)) + +(define-record-type <vector2> + (vector2 x y) + vector2? + (x vector2-x) + (y vector2-y)) + +(define-record-type <vector3> + (vector3 x y z) + vector3? + (x vector3-x) + (y vector3-y) + (z vector3-z)) + +(define-record-type <vector4> + (vector4 x y z w) + vector4? + (x vector4-x) + (y vector4-y) + (z vector4-z) + (w vector4-w)) + +(define vx + (match-lambda + ((or ($ <vector2> x _) + ($ <vector3> x _ _) + ($ <vector4> x _ _ _)) + x))) + +(define vy + (match-lambda + ((or ($ <vector2> _ y) + ($ <vector3> _ y _) + ($ <vector4> _ y _ _)) + y))) + +(define vz + (match-lambda + ((or ($ <vector3> _ _ z) + ($ <vector4> _ _ z _)) + z))) + +(define vw vector4-w) + +(define (polar2 r theta) + "Create a new 2D vector from the polar coordinate (R, THETA) where R +is the radius and THETA is the angle." + (vector2 (* r (cos theta)) + (* r (sin theta)))) + +(define (vmap proc v) + "Return a new vector that is the result of applying PROC to each +element of the 2D/3D/4D vector V." + (match v + (($ <vector2> x y) + (vector2 (proc x) (proc y))) + (($ <vector3> x y z) + (vector3 (proc x) (proc y) (proc z))) + (($ <vector4> x y z w) + (vector4 (proc x) (proc y) (proc z) (proc w))))) + +(define-syntax-rule (vector-lambda proc) + (match-lambda* + ((($ <vector2> x1 y1) ($ <vector2> x2 y2)) + (vector2 (proc x1 x2) (proc y1 y2))) + ((($ <vector2> x y) (? number? k)) + (vector2 (proc x k) (proc y k))) + (((? number? k) ($ <vector2> x y)) + (vector2 (proc k x) (proc k y))) + ((($ <vector3> x1 y1 z1) ($ <vector3> x2 y2 z2)) + (vector3 (proc x1 x2) (proc y1 y2) (proc z1 z2))) + ((($ <vector3> x y z) (? number? k)) + (vector3 (proc x k) (proc y k) (proc z k))) + (((? number? k) ($ <vector3> x y z)) + (vector3 (proc k x) (proc k y) (proc k z))) + ((($ <vector4> x1 y1 z1 w1) ($ <vector4> x2 y2 z2 w2)) + (vector4 (proc x1 x2) (proc y1 y2) (proc z1 z2) (proc w1 w2))) + ((($ <vector4> x y z w) (? number? k)) + (vector4 (proc x k) (proc y k) (proc z k) (proc w k))) + (((? number? k) ($ <vector4> x y z w)) + (vector4 (proc k x) (proc k y) (proc k z) (proc k w))))) + +(define (v+ . vectors) + (reduce (vector-lambda +) 0 vectors)) + +(define v- + (match-lambda* + ((v) (v- 0 v)) + ((v v* ...) + (fold-right (let ((- (vector-lambda -))) + (lambda (prev v) + (- v prev))) + v v*)))) + +(define (v* . vectors) + (reduce (vector-lambda *) 1 vectors)) + +(define vdot + (match-lambda* + ((($ <vector2> x1 y1) ($ <vector2> x2 y2)) + (+ (* x1 x2) (* y1 y2))) + ((($ <vector3> x1 y1 z1) ($ <vector3> x2 y2 z2)) + (+ (* x1 x2) (* y1 y2) (* z1 z2))) + ((($ <vector4> x1 y1 z1 w1) ($ <vector4> x2 y2 z2 w2)) + (+ (* x1 x2) (* y1 y2) (* z1 z2) (* w1 w2))))) + +(define vcross + (match-lambda* + ((($ <vector3> x1 y1 z1) ($ <vector3> x2 y2 z2)) + (vector3 (- (* y1 z2) (* z1 y2)) + (- (* z1 x2) (* x1 z2)) + (- (* x1 y2) (* y1 x2)))))) + +(define (magnitude v) + "Return the magnitude of the vector V." + (sqrt + (match v + (($ <vector2> x y) + (+ (square x) (square y))) + (($ <vector3> x y z) + (+ (square x) (square y) (square z))) + (($ <vector4> x y z w) + (+ (square x) (square y) (square z) (square w)))))) + +(define (normalize v) + "Return the normalized form of the vector V." + (let ((m (magnitude v))) + (if (zero? m) + v + (match v + (($ <vector2> x y) + (vector2 (/ x m) (/ y m))) + (($ <vector3> x y z) + (vector3 (/ x m) (/ y m) (/ z m))) + (($ <vector4> x y z w) + (vector4 (/ x m) (/ y m) (/ z m) (/ w m))))))) + +(define (anchor-vector width height anchor) + "Create an anchor point vector from the description ANCHOR within +the rectangular defined by WIDTH and HEIGHT. Valid values for ANCHOR +are: 'center', 'top-left', 'top-right', 'bottom-left', 'bottom-right', +'top-center', 'bottom-center', or any 2D vector. When ANCHOR is a 2D +vector, the return value is simply the same vector." + (match anchor + ((? vector2? anchor) + anchor) + ('center + (vector2 (/ width 2) + (/ height 2))) + ('top-left + (vector2 0 height)) + ('top-right + (vector2 width height)) + ('bottom-left + (vector2 0 0)) + ('bottom-right + (vector2 width 0)) + ('top-center + (vector2 (/ width 2) height)) + ('bottom-center + (vector2 (/ width 2) 0)) + (_ (error "Invalid anchor type: " anchor)))) diff --git a/chickadee/render.scm b/chickadee/render.scm new file mode 100644 index 0000000..d55c76e --- /dev/null +++ b/chickadee/render.scm @@ -0,0 +1,135 @@ +;;; 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/>. + +;;; Commentary: +;; +;; High-level rendering API. +;; +;;; Code: + +(define-module (chickadee render) + #:use-module (srfi srfi-88) + #:use-module (chickadee math matrix) + #:use-module (chickadee render gpu) + #:use-module (chickadee render blend) + #:use-module (chickadee render shader) + #:use-module (chickadee render texture) + #:use-module (chickadee render vertex-buffer) + #:export (current-blend-mode + current-depth-test + current-texture + current-projection + with-blend-mode + with-depth-test + with-texture + with-projection + gpu-apply + gpu-apply*)) + +(define *current-blend-mode* 'replace) +(define *current-depth-test* #f) +(define *current-texture* null-texture) +(define *current-projection* (make-identity-matrix4)) + +(define (current-blend-mode) + *current-blend-mode*) + +(define (current-depth-test) + *current-depth-test*) + +(define (current-texture) + *current-texture*) + +(define (current-projection) + *current-projection*) + +(define-syntax-rule (with (name value) body ...) + (let ((prev name)) + (dynamic-wind + (lambda () (set! name value)) + (lambda () body ...) + (lambda () (set! name prev))))) + +(define-syntax-rule (with-blend-mode blend-mode body ...) + (with (*current-blend-mode* blend-mode) body ...)) + +(define-syntax-rule (with-depth-test depth-test body ...) + (with (*current-depth-test* depth-test) body ...)) + +(define-syntax-rule (with-texture texture body ...) + (with (*current-texture* texture) body ...)) + +(define-syntax-rule (with-shader shader body ...) + (with (*current-shader* shader) + (initialize-uniforms) + body ...)) + +(define-syntax-rule (with-vertex-array vertex-array body ...) + (with (*current-vertex-array* vertex-array) body ...)) + +(define-syntax-rule (with-projection matrix body ...) + (with (*current-projection* matrix) body ...)) + +;; (define (initialize-uniforms) +;; (hash-for-each (lambda (name uniform) +;; (unless (hash-get-handle *current-uniforms* name) +;; (hash-set! *current-uniforms* name +;; (uniform-default-value uniform)))) +;; (shader-uniforms *current-shader*))) + +;; (define-syntax uniform-let +;; (syntax-rules () +;; ((_ () body ...) (begin body ...)) +;; ((_ ((name value) . rest) body ...) +;; (let ((uniform (shader-uniform (current-shader) name)) +;; (prev (hash-ref *current-uniforms* name))) +;; (if uniform +;; (dynamic-wind +;; (lambda () +;; (hash-set! *current-uniforms* name value)) +;; (lambda () +;; (uniform-let rest body ...)) +;; (lambda () +;; (hash-set! *current-uniforms* name prev))) +;; (error "no such uniform: " name)))))) + +;; (define (uniform-ref name) +;; (uniform-value (shader-uniform (current-shader) name))) + +(define-syntax uniform-apply + (lambda (x) + (syntax-case x () + ((_ shader ()) (datum->syntax x #t)) + ((_ shader (name value . rest)) + (with-syntax ((sname (datum->syntax x (keyword->string + (syntax->datum #'name))))) + #'(begin + (set-uniform-value! (shader-uniform shader sname) value) + (uniform-apply shader rest))))))) + +(define-syntax-rule (gpu-apply* shader vertex-array count . uniforms) + (begin + (gpu-state-set! *blend-mode-state* (current-blend-mode)) + (gpu-state-set! *depth-test-state* (current-depth-test)) + (gpu-state-set! *texture-state* (current-texture)) + (gpu-state-set! *shader-state* shader) + (gpu-state-set! *vertex-array-state* vertex-array) + (uniform-apply shader uniforms) + (render-vertices count))) + +(define-syntax-rule (gpu-apply shader vertex-array uniforms ...) + (gpu-apply* shader vertex-array #f uniforms ...)) diff --git a/chickadee/render/blend.scm b/chickadee/render/blend.scm new file mode 100644 index 0000000..2e8ebb0 --- /dev/null +++ b/chickadee/render/blend.scm @@ -0,0 +1,73 @@ +;;; 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 blend) + #:use-module (ice-9 match) + #:use-module (gl) + #:use-module (chickadee render gl) + #:use-module (chickadee render gpu) + #:export (*blend-mode-state* + *depth-test-state*)) + +(define (apply-blend-mode blend-mode) + (if blend-mode + (begin + (gl-enable (enable-cap blend)) + (match blend-mode + ('alpha + (gl-blend-equation (blend-equation-mode-ext func-add-ext)) + (gl-blend-func (blending-factor-src src-alpha) + (blending-factor-dest one-minus-src-alpha))) + ('multiply + (gl-blend-equation (blend-equation-mode-ext func-add-ext)) + (gl-blend-func (blending-factor-src dst-color) + (blending-factor-dest zero))) + ('subtract + (gl-blend-equation + (blend-equation-mode-ext func-reverse-subtract-ext)) + (gl-blend-func (blending-factor-src one) + (blending-factor-dest zero))) + ('add + (gl-blend-equation (blend-equation-mode-ext func-add-ext)) + (gl-blend-func (blending-factor-src one) + (blending-factor-dest zero))) + ('lighten + (gl-blend-equation (blend-equation-mode-ext max-ext)) + (gl-blend-func (blending-factor-src one) + (blending-factor-dest zero))) + ('darken + (gl-blend-equation (blend-equation-mode-ext min-ext)) + (gl-blend-func (blending-factor-src one) + (blending-factor-dest zero))) + ('screen + (gl-blend-equation (blend-equation-mode-ext func-add-ext)) + (gl-blend-func (blending-factor-src one) + (blending-factor-dest one-minus-src-color))) + ('replace + (gl-blend-equation (blend-equation-mode-ext func-add-ext)) + (gl-blend-func (blending-factor-src one) + (blending-factor-dest zero))))) + (gl-disable (enable-cap blend)))) + +(define *blend-mode-state* (make-gpu-state apply-blend-mode 'replace)) + +(define (apply-depth-test depth-test?) + (if depth-test? + (gl-enable (enable-cap depth-test)) + (gl-disable (enable-cap depth-test)))) + +(define *depth-test-state* (make-gpu-state apply-depth-test #f)) diff --git a/chickadee/render/gl.scm b/chickadee/render/gl.scm new file mode 100644 index 0000000..bc93d13 --- /dev/null +++ b/chickadee/render/gl.scm @@ -0,0 +1,275 @@ +;;; 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/>. + +;;; Commentary: +;; +;; Custom wrappers over low level OpenGL commands that aren't part of +;; guile-opengl. +;; +;;; Code: + +(define-module (chickadee render gl) + #:use-module (srfi srfi-4) + #:use-module ((system foreign) #:select (bytevector->pointer)) + #:use-module (gl) + #:use-module ((gl low-level) #:renamer (symbol-prefix-proc '%)) + #:use-module (gl enums) + #:use-module (gl runtime) + #:use-module (gl types)) + +(re-export (%glClearColor . gl-clear-color) + (%glScissor . gl-scissor) + (%glBlendFunc . gl-blend-func) + (%glBlendEquation . gl-blend-equation)) + +;;; +;;; 3.8.1 Texture Image Specification +;;; + +(re-export (%glTexImage3D . gl-texture-image-3d) + (%glTexImage2D . gl-texture-image-2d) + (%glTexImage1D . gl-texture-image-1d)) + +;;; +;;; 3.8.2 Alternate Texture Image Specification Commands +;;; + +(re-export (%glCopyTexImage2D . gl-copy-texture-image-2d) + (%glCopyTexImage1D . gl-copy-texture-image-1d) + (%glCopyTexSubImage3D . gl-copy-texture-sub-image-3d) + (%glCopyTexSubImage2D . gl-copy-texture-sub-image-2d) + (%glCopyTexSubImage1D . gl-copy-texture-sub-image-1d) + (%glTexSubImage3D . gl-texture-sub-image-3d) + (%glTexSubImage2D . gl-texture-sub-image-2d) + (%glTexSubImage1D . gl-texture-sub-image-1d)) + +;;; +;;; 3.8.3 Compressed Texture Images +;;; + +(re-export (%glCompressedTexImage1D . gl-compressed-texture-image-1d) + (%glCompressedTexImage2D . gl-compressed-texture-image-2d) + (%glCompressedTexImage3D . gl-compressed-texture-image-3d) + (%glCompressedTexSubImage1D . gl-compressed-texture-sub-image-1d) + (%glCompressedTexSubImage2D . gl-compressed-texture-sub-image-2d) + (%glCompressedTexSubImage3D . gl-compressed-texture-sub-image-3d)) + +;;; +;;; 3.8.4 Texture Parameters +;;; + +(re-export (%glTexParameteri . gl-texture-parameter) + (%glBindTexture . gl-bind-texture)) + +;;; +;;; Instancing extension +;;; + +(define-gl-procedure (glDrawArraysInstanced (mode GLenum) + (first GLint) + (count GLsizei) + (primcount GLsizei) + -> GLboolean) + "Draw multiple instances of a set of arrays.") + +(define-gl-procedure (glVertexAttribDivisor (index GLuint) + (divisor GLuint) + -> void) + "Modify the rate at which generic vertex attributes advance during +instanced rendering.") + +(export glDrawArraysInstanced + glVertexAttribDivisor) + +;;; +;;; VBOs +;;; + +(re-export (%glGenBuffers . gl-gen-buffers) + (%glDeleteBuffers . gl-delete-buffers) + (%glBufferData . gl-buffer-data) + (%glMapBuffer . gl-map-buffer) + (%glUnmapBuffer . gl-unmap-buffer)) + +;;; +;;; VAOs +;;; + +(define-gl-procedure (glGenVertexArrays (n GLsizei) + (arrays GLuint-*) + -> void) + "Generate N vertex arrays.") + +(define-gl-procedure (glDeleteVertexArrays (n GLsizei) + (arrays GLuint-*) + -> void) + "Delete vertex array objects.") + +(define-gl-procedure (glBindVertexArray (array GLuint) + -> void) + "Bind vertex array object ARRAY.") + +(define-gl-procedure (glEnableVertexAttribArray (index GLuint) + -> void) + "Enable or disable a generic vertex attribute array.") + +(define-gl-procedure (glVertexAttribPointer (index GLuint) + (size GLint) + (type GLenum) + (normalized GLboolean) + (stride GLsizei) + (pointer GLvoid-*) + -> void) + "Define an array of generic vertex attribute data.") + +(define-gl-procedure (glDrawElements (mode GLenum) + (count GLsizei) + (type GLenum) + (indices GLvoid-*) + -> void) + "Render primitives from array data.") + +(export (glGenVertexArrays . gl-gen-vertex-arrays) + (glDeleteVertexArrays . gl-delete-vertex-arrays) + (glBindVertexArray . gl-bind-vertex-array) + (glEnableVertexAttribArray . gl-enable-vertex-attrib-array) + (glVertexAttribPointer . gl-vertex-attrib-pointer) + (glDrawElements . gl-draw-elements)) + +(define-syntax-rule (with-gl-client-state state body ...) + (begin + (gl-enable-client-state state) + body ... + (gl-disable-client-state state))) + +(export with-gl-client-state) + +;;; +;;; Framebuffers +;;; + +(define-gl-procedure (glGenFramebuffers (n GLsizei) + (ids GLuint-*) + -> void) + "Generate framebuffer object names.") + +(define-gl-procedure (glDeleteFramebuffers (n GLsizei) + (framebuffers GLuint-*) + -> void) + "Delete framebuffer objects.") + +(define-gl-procedure (glBindFramebuffer (target GLenum) + (framebuffer GLuint) + -> void) + "Bind a framebuffer to a framebuffer target.") + +(define-gl-procedure (glFramebufferTexture2D (target GLenum) + (attachment GLenum) + (textarget GLenum) + (texture GLuint) + (level GLint) + -> void) + "Attach a level of a texture object as a logical buffer to the +currently bound framebuffer object.") + +(define-gl-procedure (glCheckFramebufferStatus (target GLenum) + -> GLenum) + "Return the framebuffer completeness status of a framebuffer +object.") + +(define-gl-procedure (glGenRenderbuffers (n GLsizei) + (ids GLuint-*) + -> void) + "Generate renderbuffer object names.") + +(define-gl-procedure (glDeleteRenderbuffers (n GLsizei) + (renderbuffers GLuint-*) + -> void) + "Delete renderbuffer objects.") + +(define-gl-procedure (glBindRenderbuffer (target GLenum) + (renderbuffer GLuint) + -> void) + "Bind a named renderbuffer object.") + +(define-gl-procedure (glRenderbufferStorage (target GLenum) + (internalformat GLenum) + (width GLsizei) + (height GLsizei) + -> void) + "Create and initialize a renderbuffer object's data store.") + +(define-gl-procedure (glFramebufferRenderbuffer (target GLenum) + (attachment GLenum) + (renderbuffertarget GLenum) + (renderbuffer GLuint) + -> void) + "Attach a renderbuffer object to a framebuffer object.") + +(export glGenFramebuffers + glDeleteFramebuffers + glBindFramebuffer + glFramebufferTexture2D + glCheckFramebufferStatus + glGenRenderbuffers + glDeleteRenderbuffers + glBindRenderbuffer + glRenderbufferStorage + glFramebufferRenderbuffer) + + +;;; +;;; Shaders +;;; + +(define-gl-procedure (glUniform1ui (location GLint) + (v0 GLuint) + -> void) + "Specify the value of a uniform variable for the current program object") + +(export (glUniform1ui . gl-uniform1ui)) + +(re-export (%glUseProgram . gl-use-program) + (%glDeleteProgram . gl-delete-program) + (%glDetachShader . gl-detach-shader) + (%glLinkProgram . gl-link-program) + (%glBindAttribLocation . gl-bind-attrib-location) + (%glAttachShader . gl-attach-shader) + (%glGetAttribLocation . gl-get-attrib-location) + (%glGetUniformLocation . gl-get-uniform-location) + (%glCreateProgram . gl-create-program) + (%glGetProgramInfoLog . gl-get-program-info-log) + (%glGetProgramiv . gl-get-programiv) + (%glDeleteProgram . gl-delete-program) + (%glDeleteShader . gl-delete-shader) + (%glGetShaderiv . gl-get-shaderiv) + (%glGetShaderInfoLog . gl-get-shader-info-log) + (%glCompileShader . gl-compile-shader) + (%glShaderSource . gl-shader-source) + (%glCreateShader . gl-create-shader) + (%glGetActiveUniform . gl-get-active-uniform) + (%glGetActiveAttrib . gl-get-active-attrib) + (%glUniform1i . gl-uniform1i) + (%glUniform2i . gl-uniform2i) + (%glUniform3i . gl-uniform3i) + (%glUniform4i . gl-uniform4i) + (%glUniform1f . gl-uniform1f) + (%glUniform2f . gl-uniform2f) + (%glUniform3f . gl-uniform3f) + (%glUniform4f . gl-uniform4f) + (%glUniformMatrix4fv . gl-uniform-matrix4fv) + (%glUniform4f . gl-uniform4f)) diff --git a/chickadee/render/gpu.scm b/chickadee/render/gpu.scm new file mode 100644 index 0000000..dde8a69 --- /dev/null +++ b/chickadee/render/gpu.scm @@ -0,0 +1,64 @@ +;;; 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 gpu) + #:use-module (oop goops) + #:use-module (srfi srfi-9) + #:export (make-gpu-state + gpu-state-ref + gpu-state-set! + + gpu-finalize + gpu-guard + gpu-reap!)) + + +;;; +;;; GPU state +;;; + +(define-record-type <gpu-state> + (make-gpu-state bind value) + gpu-state? + (bind gpu-state-bind) + (value gpu-state-ref %gpu-state-set!)) + +(define (gpu-state-set! state new-value) + (unless (eq? new-value (gpu-state-ref state)) + ((gpu-state-bind state) new-value) + (%gpu-state-set! state new-value))) + +;;; +;;; GPU finalizers +;;; + +(define-generic gpu-finalize) + +(define *gpu-guardian* (make-guardian)) + +(define (gpu-guard obj) + "Protect OBJ for the garbage collector until OBJ has been deleted +from the GPU's memory." + (*gpu-guardian* obj) + obj) + +(define (gpu-reap!) + "Delete all GPU objects that are no longer being referenced." + (let loop ((obj (*gpu-guardian*))) + (when obj + (gpu-finalize obj) + (loop (*gpu-guardian*))))) diff --git a/chickadee/render/shader.scm b/chickadee/render/shader.scm new file mode 100644 index 0000000..5e8afc9 --- /dev/null +++ b/chickadee/render/shader.scm @@ -0,0 +1,346 @@ +;;; 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 shader) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (system foreign) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-4) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (gl) + #:use-module (chickadee color) + #:use-module (chickadee math matrix) + #:use-module (chickadee math vector) + #:use-module (chickadee render gl) + #:use-module (chickadee render gpu) + #:use-module (chickadee render texture) + #:export (make-shader + shader? + null-shader + load-shader + strings->shader + shader-uniform + shader-uniforms + uniform? + uniform-name + uniform-value + uniform-default-value + set-uniform-value! + *shader-state*)) + +(define-record-type <shader> + (%make-shader id attributes uniforms) + shader? + (id shader-id) + (attributes shader-attributes) + (uniforms shader-uniforms)) + +(define-record-type <uniform> + (make-uniform name location type value setter) + uniform? + (name uniform-name) + (location uniform-location) + (type uniform-type) + (value uniform-value %set-uniform-value!) + (setter uniform-setter)) + +(define-record-type <attribute> + (make-attribute name location type) + attribute? + (name attribute-name) + (location attribute-location) + (type attribute-type)) + +(define null-shader (%make-shader 0 (make-hash-table) (make-hash-table))) + +(define <<shader>> (class-of null-shader)) + +(define-method (gpu-finalize (shader <<shader>>)) + (gl-delete-program (shader-id shader))) + +(define (apply-shader shader) + (gl-use-program (shader-id shader))) + +(define *shader-state* (make-gpu-state apply-shader null-shader)) + +(define (shader-compiled? id) + (let ((status (make-u32vector 1))) + (gl-get-shaderiv id (version-2-0 compile-status) + (bytevector->pointer status)) + (= (u32vector-ref status 0) 1))) + +(define (shader-linked? id) + (let ((status (make-u32vector 1))) + (gl-get-programiv id (version-2-0 link-status) + (bytevector->pointer status)) + (= (u32vector-ref status 0) 1))) + +(define (info-log length-proc log-proc id) + (let ((log-length-bv (make-u32vector 1))) + (length-proc id (version-2-0 info-log-length) + (bytevector->pointer log-length-bv)) + (u32vector-ref log-length-bv 0) + ;; Add one byte to account for the null string terminator. + (let* ((log-length (u32vector-ref log-length-bv 0)) + (log (make-u8vector (1+ log-length)))) + (log-proc id log-length %null-pointer (bytevector->pointer log)) + (utf8->string log)))) + +(define (compilation-error id) + (info-log gl-get-shaderiv gl-get-shader-info-log id)) + +(define (linking-error id) + (info-log gl-get-programiv gl-get-program-info-log id)) + +(define (uniform-count id) + (let ((bv (make-u32vector 1))) + (gl-get-programiv id + (arb-shader-objects active-uniforms) + (bytevector->pointer bv)) + (u32vector-ref bv 0))) + +(define (utf8->string* bv length) + (let ((bv* (make-bytevector length))) + (bytevector-copy! bv 0 bv* 0 length) + (utf8->string bv*))) + +(define (set-boolean-uniform! location bool) + (gl-uniform1i location (if bool 1 0))) + +(define (set-integer-uniform! location n) + (gl-uniform1i location n)) + +(define (set-unsigned-integer-uniform! location n) + (gl-uniform1ui location n)) + +(define (set-float-uniform! location n) + (gl-uniform1f location n)) + +(define (set-float-vector2-uniform! location v) + (gl-uniform2f location (vx v) (vy v))) + +(define (set-float-vector3-uniform! location v) + (gl-uniform3f location (vx v) (vy v) (vz v))) + +(define (set-float-vector4-uniform! location v) + (if (color? v) + (gl-uniform4f location + (color-r v) + (color-g v) + (color-b v) + (color-a v)) + (gl-uniform4f location (vx v) (vy v) (vz v) (vw v)))) + +(define (set-integer-vector2-uniform! location v) + (gl-uniform2i location (vx v) (vy v))) + +(define (set-integer-vector3-uniform! location v) + (gl-uniform3i location (vx v) (vy v) (vz v))) + +(define (set-integer-vector4-uniform! location v) + (gl-uniform4i location (vx v) (vy v) (vz v) (vw v))) + +(define (set-float-matrix4-uniform! location m) + (gl-uniform-matrix4fv location 1 #f + ((@@ (chickadee math matrix) matrix4-ptr) m))) + +(define (set-sampler-2d-uniform! location texture-unit) + (gl-uniform1i location texture-unit)) + +(define (gl-type->symbol type) + (cond + ((= type (version-2-0 bool)) 'bool) + ((= type (data-type int)) 'int) + ((= type (data-type unsigned-int)) 'unsigned-int) + ((= type (data-type float)) 'float) + ((= type (version-2-0 float-vec2)) 'float-vec2) + ((= type (version-2-0 float-vec3)) 'float-vec3) + ((= type (version-2-0 float-vec4)) 'float-vec4) + ((= type (version-2-0 int-vec2)) 'int-vec2) + ((= type (version-2-0 int-vec3)) 'int-vec3) + ((= type (version-2-0 int-vec4)) 'int-vec4) + ((= type (version-2-0 float-mat4)) 'mat4) + ((= type (version-2-0 sampler-2d)) 'sampler-2d) + (else + (error "unsupported OpenGL type" type)))) + +(define %default-mat4 (make-identity-matrix4)) + +(define (default-uniform-value type) + (match type + ('bool #f) + ('int 0) + ('unsigned-int 0) + ('float 0.0) + ('float-vec2 (vector2 0.0 0.0)) + ('float-vec3 (vector3 0.0 0.0 0.0)) + ('float-vec4 (vector4 0.0 0.0 0.0 0.0)) + ('int-vec2 (vector2 0 0)) + ('int-vec3 (vector3 0 0 0)) + ('int-vec4 (vector4 0 0 0 0)) + ('sampler-2d 0) + ('mat4 %default-mat4))) + +(define (uniform-setter-for-type type) + ;; TODO: Handle more data types, notably matrices. + (match type + ('bool set-boolean-uniform!) + ('int set-integer-uniform!) + ('unsigned-int set-unsigned-integer-uniform!) + ('float set-float-uniform!) + ('float-vec2 set-float-vector2-uniform!) + ('float-vec3 set-float-vector3-uniform!) + ('float-vec4 set-float-vector4-uniform!) + ('int-vec2 set-integer-vector2-uniform!) + ('int-vec3 set-integer-vector3-uniform!) + ('int-vec4 set-integer-vector4-uniform!) + ('mat4 set-float-matrix4-uniform!) + ('sampler-2d set-sampler-2d-uniform!))) + +(define (extract-uniforms id) + (let ((total (uniform-count id)) + (table (make-hash-table))) + (let loop ((i 0)) + (unless (= i total) + (let ((length-bv (make-u32vector 1)) + (size-bv (make-u32vector 1)) + (type-bv (make-u32vector 1)) + (name-bv (make-bytevector 255))) + (gl-get-active-uniform id i + (bytevector-length name-bv) + (bytevector->pointer length-bv) + (bytevector->pointer size-bv) + (bytevector->pointer type-bv) + (bytevector->pointer name-bv)) + (let* ((length (u32vector-ref length-bv 0)) + (name (utf8->string* name-bv length)) + (location (gl-get-uniform-location id name)) + (size (u32vector-ref size-bv 0)) + (type (gl-type->symbol (u32vector-ref type-bv 0))) + (default (default-uniform-value type)) + (setter (uniform-setter-for-type type))) + ;; TODO: Handle uniform arrays. + (unless (= size 1) + (error "unsupported uniform size" name size)) + + (unless (eq? type 'sampler-2d) + (hash-set! table + name + (make-uniform name location type default setter))))) + (loop (1+ i)))) + table)) + +(define (attribute-count id) + (let ((bv (make-u32vector 1))) + (gl-get-programiv id + (arb-shader-objects active-attributes) + (bytevector->pointer bv)) + (u32vector-ref bv 0))) + +(define (extract-attributes id) + (let ((total (attribute-count id)) + (table (make-hash-table))) + (let loop ((i 0)) + (unless (= i total) + (let ((length-bv (make-u32vector 1)) + (size-bv (make-u32vector 1)) + (type-bv (make-u32vector 1)) + (name-bv (make-bytevector 255))) + (gl-get-active-attrib id i + (bytevector-length name-bv) + (bytevector->pointer length-bv) + (bytevector->pointer size-bv) + (bytevector->pointer type-bv) + (bytevector->pointer name-bv)) + (let* ((length (u32vector-ref length-bv 0)) + (name (utf8->string* name-bv length)) + (size (u32vector-ref size-bv 0)) + (type (gl-type->symbol (u32vector-ref type-bv 0))) + (location (gl-get-attrib-location id name))) + (unless (= size 1) + (error "unsupported attribute size" name size)) + + (hash-set! table name (make-attribute name location type)))) + (loop (1+ i)))) + table)) + +(define (make-shader vertex-port fragment-port) + (define (make-shader-stage type port) + (let ((id (gl-create-shader type)) + (source (get-bytevector-all port))) + (gl-shader-source id 1 + (bytevector->pointer + (u64vector + (pointer-address (bytevector->pointer source)))) + (bytevector->pointer + (u32vector (bytevector-length source)))) + (gl-compile-shader id) + (unless (shader-compiled? id) + (let ((error-log (compilation-error id))) + (gl-delete-shader id) ; clean up GPU resource. + (error "failed to compile shader" error-log))) + id)) + + (let ((vertex-id (make-shader-stage (version-2-0 vertex-shader) + vertex-port)) + (fragment-id (make-shader-stage (version-2-0 fragment-shader) + fragment-port)) + (id (gl-create-program))) + (gl-attach-shader id vertex-id) + (gl-attach-shader id fragment-id) + (gl-link-program id) + (unless (shader-linked? id) + (let ((error-log (linking-error id))) + (gl-delete-program id) + (error "failed to link shader" error-log))) + (gl-delete-shader vertex-id) + (gl-delete-shader fragment-id) + (gpu-guard (%make-shader id (extract-attributes id) (extract-uniforms id))))) + +(define (load-shader vertex-source-file fragment-source-file) + (call-with-input-file vertex-source-file + (lambda (vertex-port) + (call-with-input-file fragment-source-file + (lambda (fragment-port) + (make-shader vertex-port fragment-port)))))) + +(define (strings->shader vertex-source fragment-source) + (call-with-input-string vertex-source + (lambda (vertex-port) + (call-with-input-string fragment-source + (lambda (fragment-port) + (make-shader vertex-port fragment-port)))))) + +(define (shader-uniform shader name) + (let ((uniform (hash-ref (shader-uniforms shader) name))) + (or uniform (error "no such uniform" name)))) + +(define (set-uniform-value! uniform x) + "Change the value of UNIFORM to X. This procedure assumes that the +shader where UNIFORM is defined is currently bound in the OpenGL +context. The behavior of this procedure under any other circumstance +is undefined." + ((uniform-setter uniform) (uniform-location uniform) x) + (%set-uniform-value! uniform x)) + +(define (uniform-default-value uniform) + (default-uniform-value (uniform-type uniform))) diff --git a/chickadee/render/shapes.scm b/chickadee/render/shapes.scm new file mode 100644 index 0000000..52e2613 --- /dev/null +++ b/chickadee/render/shapes.scm @@ -0,0 +1,205 @@ +;;; 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/>. + +;;; Commentary +;; +;; Polylines as described in +;; http://jcgt.org/published/0002/02/08/paper.pdf +;; +;;; Code: + +(define-module (chickadee render shapes) + #:use-module (ice-9 match) + #:use-module (srfi srfi-4) + #:use-module (chickadee math matrix) + #:use-module (chickadee math vector) + #:use-module (chickadee render) + #:use-module (chickadee color) + #:use-module (chickadee render shader) + #:use-module (chickadee render vertex-buffer) + #:export (draw-line + draw-rectangle-outline)) + +(define draw-line + (let* ((vertex-buffer + (delay (make-streaming-vertex-buffer 'vec2 4))) + (texcoord-buffer + (delay (make-streaming-vertex-buffer 'vec2 4))) + (index-buffer + (delay (make-vertex-buffer 'index 'static (u32vector 0 3 2 0 2 1)))) + (vertex-array + (delay (make-vertex-array (force index-buffer) + (force vertex-buffer) + (force texcoord-buffer)))) + (default-shader + (delay + (strings->shader + " +#version 330 + +in vec2 position; +in vec2 tex; +out vec2 frag_tex; +uniform mat4 projection; + +void main(void) { + frag_tex = tex; + gl_Position = projection * vec4(position.xy, 0.0, 1.0); +} +" + " +#version 330 + +in vec2 frag_tex; +uniform vec4 color; +uniform float r; +uniform float w; +uniform float t; +uniform float l; +uniform int cap; +float infinity = 1.0 / 0.0; + +void main (void) { + float hw = w / 2.0; + float u = frag_tex.x; + float v = frag_tex.y; + float dx; + float dy; + float d; + + if (u < 0 || u > l) { + if (u < 0) { + dx = abs(u); + } else { + dx = u - l; + } + dy = abs(v); + + switch (cap) { + // none + case 0: + d = infinity; + break; + // butt + case 1: + d = max(dx + w / 2 - 2 * r, dy); + break; + // square + case 2: + d = max(dx, dy); + break; + // round + case 3: + d = sqrt(dx * dx + dy * dy); + break; + // triangle out + case 4: + d = dx + dy; + break; + // triangle in + case 5: + d = max(dy, w / 2 - r + dx - dy); + break; + } + } else { + d = abs(v); + } + + if (d <= hw) { + gl_FragColor = color; + } else { + gl_FragColor = vec4(color.rgb, color.a * (1.0 - ((d - hw) / r))); + } +} +")))) + (lambda* (x1 y1 x2 y2 #:key + (thickness 1.0) + (feather 1.0) + (cap 'round) + (color white) + (shader (force default-shader))) + (let* ((dx (- x2 x1)) + (dy (- y2 y1)) + (length (sqrt (+ (expt dx 2) (expt dy 2)))) + (padding (/ (ceiling (+ thickness (* feather 2.5))) 2.0)) + (nx (/ dx length)) + (ny (/ dy length)) + (xpad (* nx padding)) + (ypad (* ny padding)) + ;; start left + (vx1 (+ (- x1 xpad) ypad)) + (vy1 (+ (- y1 ypad) (- xpad))) + (s1 (- padding)) + (t1 padding) + ;; start right + (vx2 (+ (- x1 xpad) (- ypad))) + (vy2 (+ (- y1 ypad) xpad)) + (s2 (- padding)) + (t2 (- padding)) + ;; end left + (vx3 (+ x2 xpad (- ypad))) + (vy3 (+ y2 ypad xpad)) + (s3 (+ length padding)) + (t3 (- padding)) + ;; end right + (vx4 (+ (+ x2 xpad) ypad)) + (vy4 (+ (+ y2 ypad) (- xpad))) + (s4 (+ length padding)) + (t4 padding)) + (with-mapped-vertex-buffer (force vertex-buffer) + (let ((bv (vertex-buffer-data (force vertex-buffer)))) + (f32vector-set! bv 0 vx1) + (f32vector-set! bv 1 vy1) + (f32vector-set! bv 2 vx2) + (f32vector-set! bv 3 vy2) + (f32vector-set! bv 4 vx3) + (f32vector-set! bv 5 vy3) + (f32vector-set! bv 6 vx4) + (f32vector-set! bv 7 vy4))) + (with-mapped-vertex-buffer (force texcoord-buffer) + (let ((bv (vertex-buffer-data (force texcoord-buffer)))) + (f32vector-set! bv 0 s1) + (f32vector-set! bv 1 t1) + (f32vector-set! bv 2 s2) + (f32vector-set! bv 3 t2) + (f32vector-set! bv 4 s3) + (f32vector-set! bv 5 t3) + (f32vector-set! bv 6 s4) + (f32vector-set! bv 7 t4))) + (with-blend-mode 'alpha + (gpu-apply shader (force vertex-array) + #:projection (current-projection) + #:color color + #:w thickness + #:r feather + #:l length + #:cap (match cap + ('none 0) + ('butt 1) + ('square 2) + ('round 3) + ('triangle-out 4) + ('triangle-in 5)))))))) + +;; TODO: Use an outline polygon instead of rendering a bunch of lines. +(define* (draw-rectangle-outline left bottom right top #:key + (thickness 1.0) + (color white)) + (draw-line left bottom right bottom #:thickness thickness #:color color) + (draw-line right bottom right top #:thickness thickness #:color color) + (draw-line right top left top #:thickness thickness #:color color) + (draw-line left top left bottom #:thickness thickness #:color color)) diff --git a/chickadee/render/sprite.scm b/chickadee/render/sprite.scm new file mode 100644 index 0000000..b23130a --- /dev/null +++ b/chickadee/render/sprite.scm @@ -0,0 +1,282 @@ +;;; 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 sprite) + #:use-module (srfi srfi-4) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (chickadee math matrix) + #:use-module (chickadee math vector) + #:use-module (chickadee render) + #:use-module (chickadee render shader) + #:use-module (chickadee render texture) + #:use-module (chickadee render vertex-buffer) + #:export (draw-sprite + with-batched-sprites)) + +(define default-shader + (delay + (strings->shader + " +#version 330 + +in vec2 position; +in vec2 tex; +out vec2 frag_tex; +uniform mat4 mvp; + +void main(void) { + frag_tex = tex; + gl_Position = mvp * vec4(position.xy, 0.0, 1.0); +} +" + " +#version 330 + +in vec2 frag_tex; +uniform sampler2D color_texture; + +void main (void) { + gl_FragColor = texture2D(color_texture, frag_tex); +} +"))) + +(define draw-sprite-unbatched + (let* ((vertex-buffer + (delay (make-streaming-vertex-buffer 'vec2 4))) + (texcoord-buffer + (delay (make-streaming-vertex-buffer 'vec2 4))) + (index-buffer + (delay (make-vertex-buffer 'index 'static (u32vector 0 3 2 0 2 1)))) + (vertex-array + (delay (make-vertex-array (force index-buffer) + (force vertex-buffer) + (force texcoord-buffer)))) + (tmp-matrix (make-null-matrix4)) + (mvp (make-null-matrix4))) + (lambda (texture position center width height + scale rotation blend-mode shader + s1 t1 s2 t2) + (with-mapped-vertex-buffer (force vertex-buffer) + (let* ((x1 (- (vx center))) + (y1 (- (vy center))) + (x2 (+ x1 width)) + (y2 (+ y1 height)) + (bv (vertex-buffer-data (force vertex-buffer)))) + (f32vector-set! bv 0 x1) + (f32vector-set! bv 1 y1) + (f32vector-set! bv 2 x2) + (f32vector-set! bv 3 y1) + (f32vector-set! bv 4 x2) + (f32vector-set! bv 5 y2) + (f32vector-set! bv 6 x1) + (f32vector-set! bv 7 y2))) + (with-mapped-vertex-buffer (force texcoord-buffer) + (let ((bv (vertex-buffer-data (force texcoord-buffer)))) + (f32vector-set! bv 0 s1) + (f32vector-set! bv 1 t1) + (f32vector-set! bv 2 s2) + (f32vector-set! bv 3 t1) + (f32vector-set! bv 4 s2) + (f32vector-set! bv 5 t2) + (f32vector-set! bv 6 s1) + (f32vector-set! bv 7 t2))) + (matrix4-identity! mvp) + (when rotation + (matrix4-rotate-z! tmp-matrix rotation) + (matrix4-mult! mvp mvp tmp-matrix)) + (when scale + (matrix4-scale! tmp-matrix scale) + (matrix4-mult! mvp mvp tmp-matrix)) + (matrix4-translate! tmp-matrix position) + (matrix4-mult! mvp mvp tmp-matrix) + (matrix4-mult! mvp mvp (current-projection)) + (with-blend-mode blend-mode + (with-texture texture + (gpu-apply shader (force vertex-array) #:mvp mvp)))))) + + +;;; +;;; Sprite Batch +;;; + +(define-record-type <sprite-batch> + (%make-sprite-batch texture blend-mode shader size capacity index-buffer + position-buffer texture-buffer vertex-array) + sprite-batch? + (texture sprite-batch-texture set-sprite-batch-texture!) + (blend-mode sprite-batch-blend-mode set-sprite-batch-blend-mode!) + (shader sprite-batch-shader set-sprite-batch-shader!) + (size sprite-batch-size set-sprite-batch-size!) + (capacity sprite-batch-capacity) + (index-buffer sprite-batch-index-buffer) + (position-buffer sprite-batch-position-buffer) + (texture-buffer sprite-batch-texture-buffer) + (vertex-array sprite-batch-vertex-array)) + +(define (make-sprite-batch capacity) + "Make a sprite batch that can hold CAPACITY sprites." + (let* ((index (make-streaming-vertex-buffer 'index (* capacity 6))) + (pos (make-streaming-vertex-buffer 'vec2 (* capacity 4))) + (tex (make-streaming-vertex-buffer 'vec2 (* capacity 4))) + (va (make-vertex-array index pos tex))) + (%make-sprite-batch #f #f #f 0 capacity index pos tex va))) + +(define (sprite-batch-full? batch) + (= (sprite-batch-capacity batch) (sprite-batch-size batch))) + +(define (double-sprite-batch-size! batch) + #f) + +(define (sprite-batch-reset! batch) + "Reset BATCH to size 0." + (set-sprite-batch-texture! batch #f) + (set-sprite-batch-blend-mode! batch #f) + (set-sprite-batch-shader! batch #f) + (set-sprite-batch-size! batch 0)) + +(define (sprite-batch-begin! batch) + (map-vertex-buffer! (sprite-batch-index-buffer batch)) + (map-vertex-buffer! (sprite-batch-position-buffer batch)) + (map-vertex-buffer! (sprite-batch-texture-buffer batch))) + +(define (sprite-batch-flush! batch) + "Render the contents of BATCH and clear the cache." + (unless (zero? (sprite-batch-size batch)) + (with-blend-mode (sprite-batch-blend-mode batch) + (with-texture (sprite-batch-texture batch) + (unmap-vertex-buffer! (sprite-batch-index-buffer batch)) + (unmap-vertex-buffer! (sprite-batch-position-buffer batch)) + (unmap-vertex-buffer! (sprite-batch-texture-buffer batch)) + (gpu-apply* (sprite-batch-shader batch) + (sprite-batch-vertex-array batch) + (* (sprite-batch-size batch) 6) + #:mvp (current-projection)) + (sprite-batch-reset! batch))))) + +(define sprite-batch-add! + (let ((tmp-matrix (make-null-matrix4)) + (matrix (make-null-matrix4))) + (lambda (batch texture position center width height + scale rotation blend-mode shader s1 t1 s2 t2) + ;; Expand the buffers when necessary. + (when (sprite-batch-full? batch) + (double-sprite-batch-size! batch)) + ;; Flush the batch if any GL state needs changing. + (unless (and (eq? (sprite-batch-texture batch) texture) + (eq? (sprite-batch-blend-mode batch) blend-mode) + (eq? (sprite-batch-shader batch) shader)) + (sprite-batch-flush! batch) + (sprite-batch-begin! batch) + (set-sprite-batch-texture! batch texture) + (set-sprite-batch-blend-mode! batch blend-mode) + (set-sprite-batch-shader! batch shader)) + (let ((size (sprite-batch-size batch))) + (let* ((index-offset (* size 6)) + (index-vertex-offset (* size 4)) + (vertex-offset (* size 8)) ;; 4 vertices, 2 floats per vertex + (texture-offset (* size 8)) + (indices (vertex-buffer-data (sprite-batch-index-buffer batch))) + (vertices (vertex-buffer-data (sprite-batch-position-buffer batch))) + (texcoords (vertex-buffer-data (sprite-batch-texture-buffer batch))) + (local-x1 (- (vx center))) + (local-y1 (- (vy center))) + (local-x2 (+ local-x1 width)) + (local-y2 (+ local-y1 height))) + (matrix4-identity! matrix) + (when rotation + (matrix4-rotate-z! tmp-matrix rotation) + (matrix4-mult! matrix matrix tmp-matrix)) + (when scale + (matrix4-scale! tmp-matrix scale) + (matrix4-mult! matrix matrix tmp-matrix)) + (matrix4-translate! tmp-matrix position) + (matrix4-mult! matrix matrix tmp-matrix) + (let-values (((world-x1 world-y1) + (transform matrix local-x1 local-y1)) + ((world-x2 world-y2) + (transform matrix local-x2 local-y2))) + ;; Add indices. + (u32vector-set! indices index-offset index-vertex-offset) + (u32vector-set! indices (+ index-offset 1) (+ index-vertex-offset 3)) + (u32vector-set! indices (+ index-offset 2) (+ index-vertex-offset 2)) + (u32vector-set! indices (+ index-offset 3) index-vertex-offset) + (u32vector-set! indices (+ index-offset 4) (+ index-vertex-offset 2)) + (u32vector-set! indices (+ index-offset 5) (+ index-vertex-offset 1)) + ;; Add vertices. + ;; Bottom-left + (f32vector-set! vertices vertex-offset world-x1) + (f32vector-set! vertices (+ vertex-offset 1) world-y1) + ;; Bottom-right + (f32vector-set! vertices (+ vertex-offset 2) world-x2) + (f32vector-set! vertices (+ vertex-offset 3) world-y1) + ;; Top-right + (f32vector-set! vertices (+ vertex-offset 4) world-x2) + (f32vector-set! vertices (+ vertex-offset 5) world-y2) + ;; Top-left + (f32vector-set! vertices (+ vertex-offset 6) world-x1) + (f32vector-set! vertices (+ vertex-offset 7) world-y2) + ;; Add texture coordinates. + ;; Bottom-left + (f32vector-set! texcoords texture-offset s1) + (f32vector-set! texcoords (+ texture-offset 1) t1) + ;; Bottom-right + (f32vector-set! texcoords (+ texture-offset 2) s2) + (f32vector-set! texcoords (+ texture-offset 3) t1) + ;; Top-right + (f32vector-set! texcoords (+ texture-offset 4) s2) + (f32vector-set! texcoords (+ texture-offset 5) t2) + ;; Top-left + (f32vector-set! texcoords (+ texture-offset 6) s1) + (f32vector-set! texcoords (+ texture-offset 7) t2) + (set-sprite-batch-size! batch (1+ size)))))))) + +(define *batch?* #f) +(define %batch (delay (make-sprite-batch 256))) + +(define (draw-sprite-batched texture position center width height + scale rotation blend-mode shader + s1 t1 s2 t2) + (sprite-batch-add! (force %batch) texture position center width height + scale rotation blend-mode shader + s1 t1 s2 t2)) + +(define-syntax-rule (with-batched-sprites body ...) + (dynamic-wind + (lambda () + (set! *batch?* #t)) + (lambda () + (sprite-batch-reset! (force %batch)) + body ... + (sprite-batch-flush! (force %batch))) + (lambda () + (set! *batch?* #f)))) + +(define* (draw-sprite texture position #:key + (center (vector2 0 0)) + (width (texture-width texture)) + (height (texture-height texture)) + scale rotation (blend-mode 'alpha) + (s1 0.0) (t1 0.0) (s2 1.0) (t2 1.0) + (shader (force default-shader))) + (if *batch?* + (draw-sprite-batched texture position center width height + scale rotation blend-mode shader + s1 t1 s2 t2 ) + (draw-sprite-unbatched texture position center width height + scale rotation blend-mode shader + s1 t1 s2 t2))) 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)))) diff --git a/chickadee/render/vertex-buffer.scm b/chickadee/render/vertex-buffer.scm new file mode 100644 index 0000000..5286a44 --- /dev/null +++ b/chickadee/render/vertex-buffer.scm @@ -0,0 +1,261 @@ +;;; 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/>. + +;;; Commentary: +;; +;; Vertex buffers and vertex arrays. +;; +;;; Code: + +(define-module (chickadee render vertex-buffer) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-4) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (gl) + #:use-module (system foreign) + #:use-module (chickadee render gl) + #:use-module (chickadee render gpu) + #:export (make-vertex-buffer + make-streaming-vertex-buffer + vertex-buffer? + index-buffer? + vertex-buffer-type + vertex-buffer-usage + vertex-buffer-data + null-vertex-buffer + map-vertex-buffer! + unmap-vertex-buffer! + with-mapped-vertex-buffer + *vertex-buffer-state* + + make-vertex-array + vertex-array? + vertex-array-index-buffer + vertex-array-attribute-buffers + null-vertex-array + *vertex-array-state* + + render-vertices)) + +;;; +;;; Vertex Buffers +;;; + +(define-record-type <vertex-buffer> + (%make-vertex-buffer id type usage data) + vertex-buffer? + (id vertex-buffer-id) + (type vertex-buffer-type) + (usage vertex-buffer-usage) + (data vertex-buffer-data set-vertex-buffer-data!)) + +(set-record-type-printer! <vertex-buffer> + (lambda (vb port) + (format port + "#<vertex-buffer type: ~a usage: ~a>" + (vertex-buffer-type vb) + (vertex-buffer-usage vb)))) + +(define (index-buffer? vb) + "Return #t if VB is of type 'index'." + (eq? (vertex-buffer-type vb) 'index)) + +(define null-vertex-buffer (%make-vertex-buffer 0 #f 'static #f)) + +(define <<vertex-buffer>> (class-of null-vertex-buffer)) + +(define (free-vertex-buffer vb) + (gl-delete-buffers 1 (u32vector (vertex-buffer-id vb)))) + +(define-method (gpu-finalize (vb <<vertex-buffer>>)) + (free-vertex-buffer vb)) + +(define (vertex-buffer-length vb) + (bytevector-length (vertex-buffer-data vb))) + +(define (type-size type) + (match type + ((or 'float 'index) 1) + ('vec2 2) + ('vec3 3) + ('vec4 4))) + +(define (vertex-buffer-attribute-size vb) + (type-size (vertex-buffer-type vb))) + +(define (apply-vertex-buffer vb) + (gl-bind-buffer (vertex-buffer-target-gl vb) + (vertex-buffer-id vb))) + +(define *vertex-buffer-state* + (make-gpu-state apply-vertex-buffer null-vertex-buffer)) + +(define (vertex-buffer-target-gl vb) + (if (index-buffer? vb) + (arb-vertex-buffer-object element-array-buffer-arb) + (arb-vertex-buffer-object array-buffer-arb))) + +(define (vertex-buffer-usage-gl vb) + (match (vertex-buffer-usage vb) + ('static (arb-vertex-buffer-object static-draw-arb)) + ('stream (arb-vertex-buffer-object stream-draw-arb)))) + +(define (generate-vertex-buffer-gl) + (let ((bv (u32vector 1))) + (gl-gen-buffers 1 (bytevector->pointer bv)) + (u32vector-ref bv 0))) + +(define (make-vertex-buffer type usage bv) + "Upload BV, a bytevector of TYPE elements, to the GPU as a vertex +buffer. + +USAGE provides a hint to the GPU as to how the vertex buffer will be +used: + +- static: The vertex buffer will not be updated after creation. +- stream: The vertex buffer will be dynamically updated frequently." + ;; Weird bugs will occur when creating a new vertex buffer while a + ;; vertex array is bound. + (gpu-state-set! *vertex-array-state* null-vertex-array) + (let ((vb (gpu-guard + (%make-vertex-buffer (generate-vertex-buffer-gl) + type + usage + bv)))) + (gpu-state-set! *vertex-buffer-state* vb) + (gl-buffer-data (vertex-buffer-target-gl vb) + (bytevector-length bv) + (bytevector->pointer bv) + (vertex-buffer-usage-gl vb)) + (gpu-state-set! *vertex-buffer-state* null-vertex-buffer) + vb)) + +(define (make-streaming-vertex-buffer type length) + "Return a new vertex buffer of LENGTH elements suitable for +streaming data to the GPU every frame. TYPE is a symbol specifying +the element type, either 'float', 'index', 'vec2', 'vec3', or 'vec4'." + (make-vertex-buffer type 'stream + ;; TODO: Don't assume all numbers are 32-bit. + (make-bytevector (* (type-size type) length 4)))) + +(define (map-vertex-buffer! vb) + "Map the memory space for VB from the GPU to the CPU, allowing the +vertex buffer to be updated with new vertex data. The +'unmap-vertex-buffer!' procedure must be called to submit the new +vertex buffer data back to the GPU." + (let ((target (vertex-buffer-target-gl vb)) + (length (vertex-buffer-length vb)) + (usage (vertex-buffer-usage-gl vb))) + (gpu-state-set! *vertex-buffer-state* vb) + ;; Orphan the buffer to avoid implicit synchronization. + ;; See: https://www.opengl.org/wiki/Buffer_Object_Streaming#Buffer_re-specification + (gl-buffer-data target length %null-pointer usage) + (let ((ptr (gl-map-buffer target (version-1-5 read-write)))) + (set-vertex-buffer-data! vb (pointer->bytevector ptr length))))) + +(define (unmap-vertex-buffer! vb) + "Return the mapped vertex buffer data for VB to the GPU." + (gpu-state-set! *vertex-buffer-state* vb) + (gl-unmap-buffer (vertex-buffer-target-gl vb))) + +(define-syntax-rule (with-mapped-vertex-buffer vb body ...) + (dynamic-wind + (lambda () + (map-vertex-buffer! vb)) + (lambda () body ...) + (lambda () + (unmap-vertex-buffer! vb)))) + + +;;; +;;; Vertex Arrays +;;; + +(define-record-type <vertex-array> + (%make-vertex-array id index-buffer attribute-buffers) + vertex-array? + (id vertex-array-id) + (index-buffer vertex-array-index-buffer) + (attribute-buffers vertex-array-attribute-buffers)) + +(set-record-type-printer! <vertex-array> + (lambda (va port) + (format port + "#<vertex-array index-buffer: ~a attribute-buffers: ~a>" + (vertex-array-index-buffer va) + (vertex-array-attribute-buffers va)))) + +(define null-vertex-array (%make-vertex-array 0 #f '())) + +(define <<vertex-array>> (class-of null-vertex-array)) + +(define (generate-vertex-array) + (let ((bv (u32vector 1))) + (gl-gen-vertex-arrays 1 (bytevector->pointer bv)) + (u32vector-ref bv 0))) + +(define (free-vertex-array va) + (gl-delete-vertex-arrays 1 (u32vector (vertex-array-id va)))) + +(define-method (gpu-finalize (va <<vertex-array>>)) + (free-vertex-array va)) + +(define (apply-vertex-array va) + (gl-bind-vertex-array (vertex-array-id va))) + +(define *vertex-array-state* + (make-gpu-state apply-vertex-array null-vertex-array)) + +(define (make-vertex-array index-buffer . attribute-buffers) + (let ((va (gpu-guard + (%make-vertex-array (generate-vertex-array) + index-buffer + attribute-buffers)))) + (gpu-state-set! *vertex-array-state* va) + ;; Configure all attribute buffers starting from attribute + ;; location 0. + (let loop ((attrs attribute-buffers) + (index 0)) + (match attrs + (() #f) + ((attr . rest) + (gl-enable-vertex-attrib-array index) + (gpu-state-set! *vertex-buffer-state* attr) + (gl-vertex-attrib-pointer index + (vertex-buffer-attribute-size attr) + (data-type float) + #f + 0 + %null-pointer) + (loop rest (1+ index))))) + (gpu-state-set! *vertex-buffer-state* index-buffer) + (gpu-state-set! *vertex-array-state* null-vertex-array) + va)) + +(define* (render-vertices #:optional count) + (gl-draw-elements (begin-mode triangles) + (or count + (u32vector-length + (vertex-buffer-data + (vertex-array-index-buffer + (gpu-state-ref *vertex-array-state*))))) + (data-type unsigned-int) + %null-pointer)) diff --git a/chickadee/window.scm b/chickadee/window.scm new file mode 100644 index 0000000..0ca94e4 --- /dev/null +++ b/chickadee/window.scm @@ -0,0 +1,89 @@ +;;; 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 window) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module ((sdl2) #:prefix sdl2:) + #:use-module ((sdl2 events) #:prefix sdl2:) + #:use-module ((sdl2 video) #:prefix sdl2:) + #:export (open-window + close-window + window? + window-title + window-width + window-height + window-fullscreen? + with-window + swap-buffers)) + +(define-record-type <window> + (make-window sdl-window gl-context) + window? + (sdl-window unwrap-window) + (gl-context window-gl-context)) + +(define* (open-window #:key + (title "Chickadee") + (width 640) + (height 480) + fullscreen?) + (sdl2:set-gl-attribute! 'context-major-version 3) + (sdl2:set-gl-attribute! 'context-minor-version 3) + (sdl2:set-gl-attribute! 'double-buffer 1) + (sdl2:set-gl-attribute! 'depth-size 24) + (sdl2:set-gl-attribute! 'red-size 8) + (sdl2:set-gl-attribute! 'green-size 8) + (sdl2:set-gl-attribute! 'blue-size 8) + (sdl2:set-gl-attribute! 'alpha-size 8) + (sdl2:set-gl-attribute! 'stencil-size 8) + (sdl2:set-gl-attribute! 'retained-backing 0) + (sdl2:set-gl-attribute! 'framebuffer-srgb-capable 1) + (let* ((sdl-window (sdl2:make-window #:opengl? #t + #:title title + #:size (list width height) + #:fullscreen? fullscreen?)) + (gl-context (sdl2:make-gl-context sdl-window)) + (window (make-window sdl-window gl-context))) + (sdl2:set-gl-swap-interval! 'vsync) + window)) + +(define (close-window! window) + "Close WINDOW." + (sdl2:delete-gl-context! (window-gl-context window)) + (sdl2:close-window! (unwrap-window window))) + +(define (window-title window) + "Return the title of WINDOW." + (sdl2:window-title (unwrap-window window))) + +(define (set-window-title! window title) + "Set TITLE for WINDOW." + (sdl2:set-window-title! (unwrap-window window) title)) + +(define (set-window-size! window width height) + (sdl2:set-window-size! (unwrap-window window) (list width height))) + +(define-syntax-rule (with-window window body ...) + (dynamic-wind + (const #t) + (lambda () body ...) + (lambda () + (close-window! window)))) + +(define (swap-buffers window) + (sdl2:swap-gl-window (unwrap-window window))) |