Initial commit.

1 files changed, 359 insertions, 0 deletions

diff --git a/engine/node-2d.scm b/engine/node-2d.scm
new file mode 100644
index 0000000..d5d9234
--- /dev/null
+++ b/engine/node-2d.scm
@@ -0,0 +1,359 @@
+;;; Lisp Game Jam 2018
+;;; 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 this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (engine node-2d)
+  #:use-module (chickadee)
+  #: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 scripting)
+  #:use-module (ice-9 match)
+  #:use-module (engine assets)
+  #:use-module (engine node)
+  #:use-module (oop goops)
+  #:export (<camera-2d>
+            target
+            view-matrix
+            projection-matrix
+            framebuffer
+
+            <view>
+            camera
+            area
+
+            <canvas>
+            cameras
+            views
+
+            <node-2d>
+            origin
+            position
+            rotation
+            scale
+            z
+            render-position
+            local-matrix
+            world-matrix
+            dirty-matrix?
+            set-origin
+            move
+            move-to
+            teleport
+            rotate
+            rotate-to
+            zoom
+            zoom-to
+
+            <sprite>
+            texture
+            offset
+
+            <animated-sprite>
+            atlas
+            animations
+            frame-duration
+            current-animation
+            start-time
+            change-animation
+
+            <filled-rect>
+            region
+            color
+
+            <label>
+            font
+            text))
+
+
+;;;
+;;; 2D canvas
+;;;
+
+;; 2D scenes are drawn on a canvas. A canvas renders the view of the
+;; scene from one or more cameras.  To display the camera output, one
+;; or more views are used to display the camera output on a region of
+;; the screen.  Cameras follow their target nodes around the scene.
+
+(define-class <camera-2d> ()
+  (target #:accessor target #:init-form #f #:init-keyword #:target)
+  (offset #:getter offset #:init-form (vec2 0.0 0.0) #:init-keyword #:offset)
+  (position #:getter position #:init-form (vec2 0.0 0.0))
+  (last-position #:getter last-position #:init-form (vec2 0.0 0.0))
+  (projection-matrix #:getter projection-matrix
+                     #:init-form (orthographic-projection 0 320 240 0 0 1)
+                     #:init-keyword #:projection)
+  ;; Combined projection/view matrix
+  (view-matrix #:getter view-matrix #:init-form (make-identity-matrix4))
+  (framebuffer #:getter framebuffer
+               #:init-form (make-framebuffer 320 240
+                                             #:min-filter 'nearest
+                                             #:mag-filter 'nearest)
+               #:init-keyword #:framebuffer))
+
+(define-method (update (camera <camera-2d>))
+  (when (target camera)
+    (let ((pos (position camera))
+          (last-pos (last-position camera))
+          (offset (offset camera))
+          (target-pos (position (target camera)))
+          (m (view-matrix camera)))
+      (vec2-copy! pos last-pos)
+      ;; TODO: Allow subclasses to define their own camera movement
+      (set-vec2-x! pos (- (vec2-x offset) (vec2-x target-pos)))
+      (set-vec2-y! pos (- (vec2-y offset) (vec2-y target-pos)))
+      (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-method (draw (camera <camera-2d>) node alpha)
+  (set-current-camera! camera)
+  (with-framebuffer (framebuffer camera)
+    (with-projection (if (target camera)
+                         (view-matrix camera)
+                         (projection-matrix camera))
+      (each-child (lambda (child)
+                    (draw/children child alpha))
+                  node))))
+
+(define-class <view> ()
+  (camera #:accessor camera #:init-form #f #:init-keyword #:camera)
+  (area #:getter area #:init-form (make-rect 0.0 0.0 320.0 240.0)
+        #:init-keyword #:area)
+  (matrix #:getter matrix #:init-form (make-identity-matrix4)))
+
+(define-method (draw (view <view>))
+  (draw-sprite* (framebuffer-texture (framebuffer (camera view)))
+                (area view)
+                (matrix view)))
+
+(define-class <canvas> (<node>)
+  (cameras #:accessor cameras #:init-form '() #:init-keyword #:cameras)
+  (views #:accessor views #:init-form '() #:init-keyword #:views)
+  (current-camera #:allocation #:class #:init-form #f))
+
+(define (current-camera)
+  (class-slot-ref <canvas> 'current-camera))
+
+(define (set-current-camera! camera)
+  (class-slot-set! <canvas> 'current-camera camera))
+
+(define-method (update (canvas <canvas>) dt)
+  (for-each update (cameras canvas)))
+
+(define-method (draw/children (canvas <canvas>) alpha)
+  ;; Draw children from the viewpoint of each camera.
+  (when (visible? canvas)
+    (for-each (lambda (camera)
+                (draw camera canvas alpha))
+              (cameras canvas))
+    (set-current-camera! #f)
+    (draw canvas alpha)))
+
+(define-method (draw (canvas <canvas>) alpha)
+  (for-each draw (views canvas)))
+
+
+
+;;;
+;;; 2D nodes
+;;;
+
+(define-class <node-2d> (<node>)
+  (origin #:getter origin #:init-form (vec2 0.0 0.0)
+          #:init-keyword #:origin)
+  (position #:getter position #:init-form (vec2 0.0 0.0)
+            #:init-keyword #:position)
+  (rotation #:accessor rotation #:init-form 0.0 #:init-keyword #:rotation)
+  (scale #:getter scale #:init-form (vec2 1.0 1.0) #:init-keyword #:scale)
+  (skew #:getter skew #:init-form (vec2 0.0 0.0) #:init-keyword #:skew)
+  ;; Some extra position vectors for defeating "temporal aliasing"
+  ;; when rendering.
+  (last-position #:getter last-position #:init-form (vec2 0.0 0.0))
+  (render-position #:getter render-position #:init-form (vec2 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 (set-origin (node <node-2d>) 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)
+  (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)
+  (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-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)
+  (set! (rotation node) (+ (rotation node) dtheta))
+  (dirty! node))
+
+(define-method (rotate-to (node <node-2d>) theta)
+  (set! (rotation node) theta)
+  (dirty! node))
+
+(define-method (zoom (node <node-2d>) 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)
+  (zoom node ds ds))
+
+(define-method (zoom-to (node <node-2d>) 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)
+  (zoom-to node s s))
+
+(define (compute-matrices! node)
+  (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/children (node <node-2d>) dt)
+  (vec2-copy! (position node) (last-position node))
+  (next-method))
+
+(define-method (draw/children (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.
+    (each-child (lambda (node) (set! (dirty-matrix? node) #t)) node))
+  (next-method))
+
+(define-method (activate (node <node-2d>))
+  (set! (dirty-matrix? node) #t)
+  (next-method))
+
+
+;;;
+;;; Sprites
+;;;
+
+(define-class <sprite> (<node-2d>)
+  (texture #:accessor texture #:init-keyword #:texture))
+
+(define-method (draw (sprite <sprite>) alpha)
+  (draw-sprite* (asset-ref (texture sprite))
+                (texture-gl-rect (texture sprite))
+                (world-matrix 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))))
+
+
+;;;
+;;; Shapes
+;;;
+
+(define-class <filled-rect> (<node-2d>)
+  (region #:accessor region #:init-keyword #:region)
+  (color #:accessor color #:init-form black #:init-keyword #:color))
+
+(define-method (draw (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 (draw (label <label>) alpha)
+  (draw-text* (asset-ref (font label)) (text label) (world-matrix label)))