diff options
| -rw-r--r-- | starling/node-2d.scm | 406 |
1 files changed, 406 insertions, 0 deletions
diff --git a/starling/node-2d.scm b/starling/node-2d.scm new file mode 100644 index 0000000..293b227 --- /dev/null +++ b/starling/node-2d.scm @@ -0,0 +1,406 @@ +;;; Starling Game Engine +;;; Copyright © 2018 David Thompson <davet@gnu.org> +;;; +;;; This program is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Starling. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 2D game nodes. +;; +;;; Code: + +(define-module (starling node-2d) + #:use-module (chickadee math matrix) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (chickadee render) + #:use-module (chickadee render color) + #:use-module (chickadee render font) + #:use-module (chickadee render framebuffer) + #:use-module (chickadee render shapes) + #:use-module (chickadee render sprite) + #:use-module (chickadee render texture) + #:use-module (chickadee render viewport) + #:use-module (chickadee scripting) + #:use-module (oop goops) + #:use-module (starling node) + #:export (<camera-2d> + target + offset + position + width + height + + <view-2d> + camera + area + + <canvas> + views + + <node-2d> + origin + position + rotation + skew + pivot + move + move-to + teleport + rotate + rotate-to + zoom + zoom-to + + <sprite> + texture + + <animated-sprite> + atlas + animations + frame-duration + current-animation + start-time + change-animation + + <filled-rect> + region + color + + <label> + font + text)) + + +;;; +;;; 2D Camera +;;; + +;; Cameras define a view into the scene. They are attached to a 2D +;; node and follow it around. + +(define-class <camera-2d> () + (target #:accessor target #:init-form #f #:init-keyword #:target) + (offset #:getter offset #:init-form #v(0.0 0.0) #:init-keyword #:offset) + (position #:getter position #:init-form #v(0.0 0.0)) + (last-position #:getter last-position #:init-form #v(0.0 0.0)) + (width #:getter width #:init-keyword #:width) + (height #:getter height #:init-keyword #:height) + (projection-matrix #:accessor projection-matrix) + ;; Combined projection/view matrix + (view-matrix #:getter view-matrix #:init-form (make-identity-matrix4)) + (framebuffer #:accessor framebuffer)) + +(define-method (initialize (camera <camera-2d>) initargs) + (next-method) + ;; Initialize framebuffer and orthographic projection matrix based + ;; on the resolution of the camera. + (set! (framebuffer camera) + (make-framebuffer (width camera) + (height camera) + #:min-filter 'nearest + #:mag-filter 'nearest)) + (set! (projection-matrix camera) + (orthographic-projection 0 (width camera) (height camera) 0 0 1))) + +;; This method can be overridden by subclasses to create custom camera +;; movement. +(define-method (follow-target (camera <camera-2d>) dt) + (let ((pos (position camera)) + (target-pos (position (target camera))) + (offset (offset camera))) + (set-vec2-x! pos (- (vec2-x offset) (vec2-x target-pos))) + (set-vec2-y! pos (- (vec2-y offset) (vec2-y target-pos))))) + +(define-method (update (camera <camera-2d>) dt) + (when (target camera) + (let ((pos (position camera)) + (last-pos (last-position camera)) + (m (view-matrix camera))) + (vec2-copy! pos last-pos) + (follow-target camera dt) + (unless (and (= (vec2-x pos) (vec2-x last-pos)) + (= (vec2-y pos) (vec2-y last-pos))) + (matrix4-translate! m pos) + (matrix4-mult! m m (projection-matrix camera)))))) + +(define-syntax-rule (with-camera camera body ...) + (with-framebuffer (framebuffer camera) + (with-projection (if (target camera) + (view-matrix camera) + (projection-matrix camera)) + body ...))) + + + +;;; +;;; 2D View +;;; + +;; Views render the output of a camera to a portion of the game +;; window. + +(define-class <view-2d> () + (camera #:accessor camera #:init-keyword #:camera) + (area #:getter area #:init-keyword #:area) + (viewport #:accessor viewport)) + +(define-method (initialize (view <view-2d>) initargs) + (define (to-int x) + (inexact->exact (round x))) + (next-method) + (let ((r (area view))) + (set! (viewport view) + (make-viewport (to-int (rect-x r)) + (to-int (rect-y r)) + (to-int (rect-width r)) + (to-int (rect-height r)))))) + +(define %identity-matrix (make-identity-matrix4)) + +(define-method (render (view <view-2d>)) + (with-viewport (viewport view) + (with-projection (projection-matrix (camera view)) + (draw-sprite* (framebuffer-texture (framebuffer (camera view))) + (area view) + %identity-matrix)))) + + +;;; +;;; 2D Canvas +;;; + +;; The canvas is the root of a 2D scene. It handles rendering one or +;; more views. + +(define-class <canvas> (<node>) + (views #:accessor views #:init-form '() #:init-keyword #:views)) + +(define-method (update (canvas <canvas>) dt) + (for-each (lambda (view) + (update (camera view) dt)) + (views canvas))) + +(define-method (render* (canvas <canvas>) alpha) + ;; Draw scene from the viewpoint of each camera. + (for-each (lambda (view) + (with-camera (camera view) + (for-each (lambda (child) + (render* child alpha)) + (children canvas)))) + (views canvas)) + (render canvas alpha)) + +(define-method (render (canvas <canvas>) alpha) + (for-each render (views canvas))) + + +;;; +;;; 2D Game Node +;;; + +(define-class <node-2d> (<node>) + (origin #:getter origin #:init-form #v(0.0 0.0) #:init-keyword #:origin) + (position #:getter position #:init-form #v(0.0 0.0) #:init-keyword #:position) + (rotation #:accessor rotation #:init-form 0.0 #:init-keyword #:rotation) + (scale #:getter scale #:init-form #v(1.0 1.0) #:init-keyword #:scale) + (skew #:getter skew #:init-form #v(0.0 0.0) #:init-keyword #:skew) + ;; Some extra position vectors for defeating "temporal aliasing" + ;; when rendering. + (last-position #:getter last-position #:init-form #v(0.0 0.0)) + (render-position #:getter render-position #:init-form #v(0.0 0.0)) + ;; Lazily computed transformation matrices. + (local-matrix #:getter local-matrix #:init-form (make-identity-matrix4)) + (world-matrix #:getter world-matrix #:init-form (make-identity-matrix4)) + (dirty-matrix? #:accessor dirty-matrix? #:init-form #t)) + +(define (dirty! node) + (set! (dirty-matrix? node) #t)) + +(define-method (pivot (node <node-2d>) x y) + "Change origin of NODE to (X, Y)." + (let ((o (origin node))) + (set-vec2-x! o x) + (set-vec2-y! o y) + (dirty! node))) + +(define-method (move (node <node-2d>) dx dy) + "Move NODE by (DX, DY)." + (let ((p (position node))) + (set-vec2-x! p (+ (vec2-x p) dx)) + (set-vec2-y! p (+ (vec2-y p) dy)) + (dirty! node))) + +(define-method (move-to (node <node-2d>) x y) + "Move NODE to (X, Y)." + (let ((p (position node))) + (set-vec2-x! p x) + (set-vec2-y! p y) + (dirty! node))) + +(define-method (teleport (node <node-2d>) x y) + "Move NODE to (X, Y) without applying animation smoothing." + (move-to node x y) + (let ((lp (last-position node))) + (set-vec2-x! lp x) + (set-vec2-y! lp y))) + +(define-method (rotate (node <node-2d>) dtheta) + "Rotate NODE about the Z axis by DTHETA radians." + (set! (rotation node) (+ (rotation node) dtheta)) + (dirty! node)) + +(define-method (rotate-to (node <node-2d>) theta) + "Rotate NODE to THETA radians about the Z axis." + (set! (rotation node) theta) + (dirty! node)) + +(define-method (zoom (node <node-2d>) dsx dsy) + "Scale NODE by the scaling factor (DSX, DSY)." + (let ((s (scale node))) + (set-vec2-x! s (+ (vec2-x s) dsx)) + (set-vec2-y! s (+ (vec2-y s) dsy)) + (dirty! node))) + +(define-method (zoom (node <node-2d>) ds) + "Scale NODE by the scaling factor (DS, DS)." + (zoom node ds ds)) + +(define-method (zoom-to (node <node-2d>) sx sy) + "Set the scaling factor for NODE to (SX, SY)." + (let ((s (scale node))) + (set-vec2-x! s sx) + (set-vec2-y! s sy) + (dirty! node))) + +(define-method (zoom-to (node <node-2d>) s) + "Set the scaling factor for node to (S, S)." + (zoom-to node s s)) + +(define-method (compute-matrices! (node <node-2d>)) + (let ((local (local-matrix node)) + (world (world-matrix node))) + (matrix4-2d-transform! local + #:origin (origin node) + #:position (render-position node) + #:rotation (rotation node) + #:scale (scale node) + #:skew (skew node)) + ;; Compute world matrix by multiplying by the parent node's + ;; matrix, if there is a 2D parent node, that is. + (if (and (parent node) (is-a? (parent node) <node-2d>)) + (matrix4-mult! world local (world-matrix (parent node))) + (begin + (matrix4-identity! world) + (matrix4-mult! world world local))))) + +(define-method (update* (node <node-2d>) dt) + (vec2-copy! (position node) (last-position node)) + (next-method)) + +(define-method (render* (node <node-2d>) alpha) + ;; Compute the linearly interpolated rendering position, in the case + ;; that node has moved since the last update. + (let ((p (position node)) + (lp (last-position node)) + (rp (render-position node)) + (beta (- 1.0 alpha))) + (unless (and (= (vec2-x lp) (vec2-x rp)) + (= (vec2-y lp) (vec2-y rp))) + (set-vec2-x! rp (+ (* (vec2-x p) alpha) (* (vec2-x lp) beta))) + (set-vec2-y! rp (+ (* (vec2-y p) alpha) (* (vec2-y lp) beta))) + (set! (dirty-matrix? node) #t))) + ;; Recompute dirty matrices. + (when (dirty-matrix? node) + (compute-matrices! node) + (set! (dirty-matrix? node) #f) + ;; If the parent is dirty, all the children need to be marked as + ;; dirty, too. + (for-each (lambda (node) + (set! (dirty-matrix? node) #t)) + (children node))) + (next-method)) + +(define-method (activate (node <node-2d>)) + (set! (dirty-matrix? node) #t)) + +;; TODO: Add live asset reload +(define-method (asset-ref x) x) + + +;;; +;;; Static Sprite +;;; + +(define-class <sprite> (<node-2d>) + (texture #:accessor texture #:init-keyword #:texture)) + +(define-method (render (sprite <sprite>) alpha) + (draw-sprite* (asset-ref (texture sprite)) + (texture-gl-rect (texture sprite)) + (world-matrix sprite))) + + +;;; +;;; Animated Sprite +;;; + +(define-class <animated-sprite> (<sprite>) + (atlas #:accessor atlas #:init-keyword #:atlas) + (animations #:accessor animations #:init-keyword #:animations) + (frame-duration #:accessor frame-duration #:init-keyword #:frame-duration) + (current-animation #:accessor current-animation + #:init-keyword #:current-animation) + (start-time #:accessor start-time #:init-form 0)) + +(define-method (on-enter (sprite <animated-sprite>)) + (update sprite 0)) + +(define-method (update (sprite <animated-sprite>) dt) + (let* ((anim (assq-ref (animations sprite) (current-animation sprite))) + (frame-duration (frame-duration sprite)) + (anim-duration (* frame-duration (vector-length anim))) + (time (modulo (- (agenda-time) (start-time sprite)) anim-duration)) + (frame (vector-ref anim (floor (/ time frame-duration)))) + (texture-region (texture-atlas-ref (asset-ref (atlas sprite)) frame))) + (set! (texture sprite) texture-region) + (next-method))) + +(define-method (change-animation (sprite <animated-sprite>) name) + (set! (current-animation sprite) name) + (set! (start-time sprite) (with-agenda (agenda sprite) (agenda-time)))) + + +;;; +;;; Filled Rectangle +;;; + +(define-class <filled-rect> (<node-2d>) + (region #:accessor region #:init-keyword #:region) + (color #:accessor color #:init-form black #:init-keyword #:color)) + +(define-method (render (r <filled-rect>) alpha) + (draw-filled-rect (region r) (color r) #:matrix (world-matrix r))) + + +;;; +;;; Text +;;; + +(define-class <label> (<node-2d>) + (font #:accessor font #:init-keyword #:font) + (text #:accessor text #:init-form "" #:init-keyword #:text)) + +(define-method (render (label <label>) alpha) + (draw-text* (asset-ref (font label)) (text label) (world-matrix label))) |