From 3a259726918364985b141b9a15493353bbbcb495 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sun, 26 Aug 2018 09:52:37 -0400
Subject: Add 2D node primitives.

---
 starling/node-2d.scm | 406 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 406 insertions(+)
 create mode 100644 starling/node-2d.scm

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)))
-- 
cgit v1.2.3