diff options
Diffstat (limited to 'lisparuga/node-2d.scm')
-rw-r--r-- | lisparuga/node-2d.scm | 638 |
1 files changed, 638 insertions, 0 deletions
diff --git a/lisparuga/node-2d.scm b/lisparuga/node-2d.scm new file mode 100644 index 0000000..9397c77 --- /dev/null +++ b/lisparuga/node-2d.scm @@ -0,0 +1,638 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 2D game nodes. +;; +;;; Code: + +(define-module (lisparuga node-2d) + #:use-module (chickadee math bezier) + #:use-module (chickadee math easings) + #: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 particles) + #:use-module (chickadee render shapes) + #:use-module (chickadee render sprite) + #:use-module (chickadee render texture) + #:use-module (chickadee render tiled) + #:use-module (chickadee render viewport) + #:use-module (chickadee scripting) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (sdl2 video) + #:use-module (lisparuga asset) + #:use-module (lisparuga kernel) + #:use-module (lisparuga node) + #:use-module (lisparuga scene) + #:export (<camera-2d> + target + offset + position + width + height + + <view-2d> + camera + area + + <canvas> + views + + <scene-2d> + + <node-2d> + origin + position + rotation + scale + skew + local-matrix + world-matrix + dirty! + pivot + move-by + move-to + teleport + rotate-by + rotate-to + scale-by + scale-to + follow-bezier-path + + <sprite> + texture + texcoords + source-rect + blend-mode + tint + + <atlas-sprite> + atlas + index + + <animation> + frames + frame-duration + + <animated-sprite> + animations + frame-duration + current-animation + start-time + change-animation + + <sprite-batch> + batch + + <filled-rect> + region + color + + <label> + font + text + + <tile-map> + tile-map + layers + + <particles> + particles)) + + +;;; +;;; 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) + (projection-matrix #:accessor projection-matrix) + (sprite-rect #:accessor sprite-rect)) + +(define-method (initialize (view <view-2d>) initargs) + (next-method) + (let* ((area (area view)) + (x (rect-x area)) + (y (rect-y area)) + (w (rect-width area)) + (h (rect-height area))) + (set! (viewport view) + (make-viewport (inexact->exact x) + (inexact->exact y) + (inexact->exact w) + (inexact->exact h))) + (set! (sprite-rect view) (make-rect 0.0 0.0 w h)) + (set! (projection-matrix view) (orthographic-projection 0 w h 0 0 1)))) + +(define %identity-matrix (make-identity-matrix4)) + +(define-method (render (view <view-2d>)) + (with-viewport (viewport view) + (with-projection (projection-matrix view) + (draw-sprite* (framebuffer-texture (framebuffer (camera view))) + (sprite-rect view) + %identity-matrix)))) + + +;;; +;;; 2D Canvas +;;; + +;; The canvas is the root of a 2D scene. It handles rendering one or +;; more views. + +(define (make-default-views) + (match (window-size (window (current-kernel))) + ((width height) + (list + (make <view-2d> + #:camera (make <camera-2d> + #:width width + #:height height) + #:area (make-rect 0 0 width height)))))) + +(define-class <canvas> (<node>) + (views #:accessor views #:init-thunk make-default-views + #:init-keyword #:views)) + +(define-method (update (canvas <canvas>) dt) + (for-each (lambda (view) + (update (camera view) dt)) + (views canvas))) + +(define-method (render-tree (canvas <canvas>) alpha) + ;; Draw scene from the viewpoint of each camera. + (for-each (lambda (view) + (with-camera (camera view) + (for-each (lambda (child) + (render-tree child alpha)) + (children canvas)))) + (views canvas)) + (render canvas alpha)) + +(define-method (render (canvas <canvas>) alpha) + (for-each render (views canvas))) + + +;;; +;;; 2D Scene +;;; + +(define-class <scene-2d> (<scene> <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-method (dirty! (node <node-2d>)) + (set! (dirty-matrix? node) #t)) + +(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))))) + +;; Animation helpers + +(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-to (node <node-2d>) x y) + (let ((p (position node))) + (set-vec2-x! p x) + (set-vec2-y! p y) + (dirty! node))) + +(define-method (move-to (node <node-2d>) x y duration ease) + (let ((p (position node))) + (move-by node (- x (vec2-x p)) (- y (vec2-y p)) duration ease))) + +(define-method (move-to (node <node-2d>) x y duration) + (move-to node x y duration smoothstep)) + +(define-method (move-by (node <node-2d>) dx dy) + (let ((p (position node))) + (move-to node (+ (vec2-x p) dx) (+ (vec2-y p) dy)))) + +(define-method (move-by (node <node-2d>) dx dy duration ease) + (let* ((p (position node)) + (start-x (vec2-x p)) + (start-y (vec2-y p))) + (tween duration 0.0 1.0 + (lambda (n) + (move-to node + (+ start-x (* dx n)) + (+ start-y (* dy n)))) + #:ease ease))) + +(define-method (move-by (node <node-2d>) dx dy duration) + (move-by node dx dy duration smoothstep)) + +(define-method (teleport (node <node-2d>) x y) + (move-to node x y) + (let ((lp (last-position node))) + (set-vec2-x! lp x) + (set-vec2-y! lp y))) + +(define-method (rotate-to (node <node-2d>) theta) + (set! (rotation node) theta) + (dirty! node)) + +(define-method (rotate-to (node <node-2d>) theta duration ease) + (tween duration (rotation node) theta + (lambda (r) + (rotate-to node r)) + #:ease ease)) + +(define-method (rotate-to (node <node-2d>) theta duration) + (rotate-to node theta duration smoothstep)) + +(define-method (rotate-by (node <node-2d>) dtheta) + (rotate-to node (+ (rotation node) dtheta))) + +(define-method (rotate-by (node <node-2d>) dtheta duration ease) + (rotate-to node (+ (rotation node) dtheta) duration ease)) + +(define-method (rotate-by (node <node-2d>) dtheta duration) + (rotate-by node dtheta duration smoothstep)) + +(define-method (scale-to (node <node-2d>) sx sy) + (let ((s (scale node))) + (set-vec2-x! s sx) + (set-vec2-y! s sy) + (dirty! node))) + +(define-method (scale-to (node <node-2d>) sx sy duration ease) + (let ((s (scale node))) + (scale-by node (- sx (vec2-x s)) (- sy (vec2-y s)) duration ease))) + +(define-method (scale-to (node <node-2d>) sx sy duration) + (scale-to node sx sy duration smoothstep)) + +(define-method (scale-by (node <node-2d>) dsx dsy) + (let ((s (scale node))) + (scale-to node (+ (vec2-x s) dsx) (+ (vec2-y s) dsy)))) + +(define-method (scale-by (node <node-2d>) dsx dsy duration ease) + (let* ((s (scale node)) + (start-x (vec2-x s)) + (start-y (vec2-y s))) + (tween duration 0.0 1.0 + (lambda (n) + (scale-to node + (+ start-x (* dsx n)) + (+ start-y (* dsy n)))) + #:ease ease))) + +(define-method (scale-by (node <node-2d>) dsx dsy duration) + (scale-by node dsx dsy duration smoothstep)) + +(define-method (follow-bezier-path (node <node-2d>) path duration forward?) + (let ((p (position node)) + (path (if forward? path (reverse path)))) + (for-each (lambda (bezier) + (tween duration + (if forward? 0.0 1.0) + (if forward? 1.0 0.0) + (lambda (t) + (bezier-curve-point-at! p bezier t) + (dirty! node)) + #:ease linear)) + path))) + +(define-method (follow-bezier-path (node <node-2d>) path duration) + (follow-bezier-path node path duration #t)) + +;; Events + +(define-method (update-tree (node <node-2d>) dt) + (vec2-copy! (position node) (last-position node)) + (next-method)) + +(define-method (render-tree (node <node-2d>) alpha) + (when (visible? node) + ;; 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) + ;; Set the initial last position to the same as the initial position + ;; to avoid a brief flash where the node appears at (0, 0). + (vec2-copy! (position node) (last-position node)) + (next-method)) + + +;;; +;;; Base Sprite +;;; + +(define-class <base-sprite> (<node-2d>) + (batch #:accessor batch + #:init-keyword #:batch + #:init-form #f) + (tint #:accessor tint + #:init-keyword #:tint + #:init-form white) + (blend-mode #:accessor blend-mode + #:init-keyword #:blend-mode + #:init-form 'alpha)) + +(define-generic texture) + +(define-method (texcoords (sprite <base-sprite>)) + (texture-gl-tex-rect (asset-ref (texture sprite)))) + +(define-method (source-rect (sprite <base-sprite>)) + (texture-gl-rect (asset-ref (texture sprite)))) + +(define-method (render (sprite <base-sprite>) alpha) + (let* ((tex (asset-ref (texture sprite))) + (rect (source-rect sprite)) + (batch (batch sprite)) + (tint (tint sprite)) + (matrix (world-matrix sprite))) + (if batch + (sprite-batch-add* batch rect matrix + #:tint tint + #:texture-region tex) + (draw-sprite* tex rect matrix + #:tint tint + #:texcoords (texcoords sprite))))) + + +;;; +;;; Static Sprite +;;; + +(define-class <sprite> (<base-sprite>) + (texture #:getter texture #:init-keyword #:texture) + (texcoords #:init-keyword #:texcoords #:init-form #f) + (source-rect #:init-keyword #:source-rect #:init-form #f)) + +(define-method (texcoords (sprite <sprite>)) + (or (slot-ref sprite 'texcoords) + (next-method))) + +(define-method (source-rect (sprite <sprite>)) + (or (slot-ref sprite 'source-rect) + (next-method))) + + +;;; +;;; Texture Atlas Sprite +;;; + +(define-class <atlas-sprite> (<base-sprite>) + (atlas #:accessor atlas #:init-keyword #:atlas) + (index #:accessor index #:init-keyword #:index)) + +(define-method (texture (sprite <atlas-sprite>)) + (texture-atlas-ref (asset-ref (atlas sprite)) (index sprite))) + + +;;; +;;; Animated Sprite +;;; + +(define-class <animation> () + (frames #:getter frames #:init-keyword #:frames) + (frame-duration #:getter frame-duration #:init-keyword #:frame-duration + #:init-form 250)) + +(define-class <animated-sprite> (<atlas-sprite>) + (animations #:accessor animations #:init-keyword #:animations) + (current-animation #:accessor current-animation + #:init-keyword #:default-animation + #:init-form 'default) + (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 anim)) + (frames (frames anim)) + (anim-duration (* frame-duration (vector-length frames))) + (time (modulo (- (elapsed-time) (start-time sprite)) anim-duration)) + (frame (vector-ref frames (floor (/ time frame-duration))))) + (set! (index sprite) frame) + (next-method))) + +(define-method (change-animation (sprite <animated-sprite>) name) + (set! (current-animation sprite) name) + (set! (start-time sprite) (elapsed-time))) + + +;;; +;;; Sprite Batch +;;; + +(define-class <sprite-batch> (<node-2d>) + (batch #:accessor batch #:init-keyword #:batch) + (blend-mode #:accessor blend-mode + #:init-keyword #:blend-mode + #:init-form 'alpha) + (clear-after-draw? #:accessor clear-after-draw? + #:init-keyword #:clear-after-draw? + #:init-form #t) + (batch-matrix #:accessor batch-matrix #:init-thunk make-identity-matrix4)) + +(define-method (render (sprite-batch <sprite-batch>) alpha) + (let ((batch (batch sprite-batch))) + (draw-sprite-batch* batch (batch-matrix sprite-batch) + #:blend-mode (blend-mode sprite-batch)) + (when (clear-after-draw? sprite-batch) + (sprite-batch-clear! batch)))) + + +;;; +;;; 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 #:init-thunk default-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))) + + +;;; +;;; Tiled Map +;;; + +(define-class <tile-map> (<node-2d>) + (tile-map #:accessor tile-map #:init-keyword #:map) + (layers #:accessor layers #:init-keyword #:layers #:init-form #f)) + +(define-method (initialize (node <tile-map>) initargs) + (next-method)) + +(define-method (render (node <tile-map>) alpha) + (let ((m (asset-ref (tile-map node)))) + (draw-tile-map* m (world-matrix node) (tile-map-rect m) + #:layers (layers node)))) + + +;;; +;;; Particles +;;; + +(define-class <particles> (<node-2d>) + (particles #:accessor particles #:init-keyword #:particles)) + +(define-method (update (node <particles>) dt) + (update-particles (particles node))) + +(define-method (render (node <particles>) alpha) + (draw-particles* (particles node) (world-matrix node))) |