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)))