From b057acbc3b06d1e815bb1b9d43241ac35b058d1e Mon Sep 17 00:00:00 2001
From: Ricardo Wurmus <rekado@elephly.net>
Date: Mon, 25 Jun 2018 10:56:18 +0200
Subject: Initial commit.

---
 engine/README      |   6 +
 engine/assets.scm  | 170 +++++++++++++++++++++++++
 engine/inotify.scm | 209 +++++++++++++++++++++++++++++++
 engine/node-2d.scm | 359 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 engine/node.scm    | 251 +++++++++++++++++++++++++++++++++++++
 engine/scene.scm   |  44 +++++++
 engine/shell.scm   | 236 +++++++++++++++++++++++++++++++++++
 7 files changed, 1275 insertions(+)
 create mode 100644 engine/README
 create mode 100644 engine/assets.scm
 create mode 100644 engine/inotify.scm
 create mode 100644 engine/node-2d.scm
 create mode 100644 engine/node.scm
 create mode 100644 engine/scene.scm
 create mode 100644 engine/shell.scm

(limited to 'engine')

diff --git a/engine/README b/engine/README
new file mode 100644
index 0000000..ad10b3c
--- /dev/null
+++ b/engine/README
@@ -0,0 +1,6 @@
+The engine has been extracted from git://dthompson.us/lisp-game-jam-2018.git
+
+These changes have been made:
+
+* exported "origin" in engine/node-2d.scm
+* let <scene> inherit from <node-2d> instead of <node>
diff --git a/engine/assets.scm b/engine/assets.scm
new file mode 100644
index 0000000..73a9785
--- /dev/null
+++ b/engine/assets.scm
@@ -0,0 +1,170 @@
+;;; 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 assets)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match)
+  #:use-module (engine inotify)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-1)
+  #:export (<asset>
+            artifact
+            file-name
+            loader
+            args
+            watch-asset-directory
+            reload-modified-assets
+            asset-ref
+            define-asset))
+
+(define-class <asset> ()
+  ;; class slots for asset cache and live reloading
+  (inotify #:allocation #:class #:init-form #f)
+  ;; file-name -> assets mapping
+  (asset-map #:allocation #:class #:init-form (make-hash-table))
+  ;; args -> artifact mapping
+  (artifact-cache #:allocation #:class #:init-form (make-weak-value-hash-table))
+  (watches #:allocation #:class #:init-form '())
+  ;; instance slots
+  (artifact #:accessor artifact #:init-form #f)
+  (file-name #:getter file-name #:init-keyword #:file-name)
+  (loader #:getter loader #:init-keyword #:loader)
+  (loader-args #:getter loader-args #:init-form '()
+               #:init-keyword #:loader-args)
+  (watch #:accessor watch #:init-form #f))
+
+(define (absolute-file-name file-name)
+  (if (absolute-file-name? file-name)
+      file-name
+      (string-append (getcwd) "/" file-name)))
+
+(define-method (initialize (asset <asset>) args)
+  (next-method)
+  (slot-set! asset 'file-name (absolute-file-name (file-name asset)))
+  (let* ((asset-map (class-slot-ref <asset> 'asset-map))
+         ;; Using a weak key hash table instead of a list to keep
+         ;; track of all the assets that are associated with a file.
+         ;; This way, their presence in the cache won't save them from
+         ;; the GC.
+         (sub-table (or (hash-ref asset-map (file-name asset))
+                        (let ((wt (make-weak-key-hash-table)))
+                          (hash-set! asset-map (file-name asset) wt)
+                          wt))))
+    (hash-set! sub-table asset asset)))
+
+(define (asset-inotify)
+  (class-slot-ref <asset> 'inotify))
+
+(define (asset-map)
+  (class-slot-ref <asset> 'asset-map))
+
+(define (artifact-cache)
+  (class-slot-ref <asset> 'artifact-cache))
+
+(define (asset-watches)
+  (class-slot-ref <asset> 'watches))
+
+(define (directory-watched? dir)
+  (find (lambda (watch)
+          (string=? (inotify-watch-file-name watch) dir))
+        (asset-watches)))
+
+(define (watch-recursively dir)
+  (let ((inotify (asset-inotify)))
+    (file-system-fold (const #t) ; enter?
+                      (lambda (name stat result) result) ; leaf
+                      (lambda (name stat result) ; down
+                        (cons (inotify-add-watch! inotify name '(create close-write moved-to))
+                              result))
+                      (lambda (name stat result) result) ; up
+                      (lambda (name stat result) result) ; skip
+                      (lambda (name stat errno result) result) ; error
+                      '()
+                      dir)))
+
+(define (watch-asset-directory dir)
+  ;; Lazily activate inotify.
+  (unless (asset-inotify)
+    (class-slot-set! <asset> 'inotify (make-inotify)))
+  (unless (directory-watched? dir)
+    (class-slot-set! <asset> 'watches
+                     (append (watch-recursively dir)
+                             (asset-watches)))))
+
+(define (reload-modified-assets)
+  (let ((inotify (asset-inotify)))
+    (when inotify
+      (while (inotify-pending-events? inotify)
+        (let* ((event (inotify-read-event inotify))
+               (type (inotify-event-type event))
+               (file-name (string-append (inotify-watch-file-name
+                                          (inotify-event-watch event))
+                                         "/"
+                                         (inotify-event-file-name event)))
+               (assets (hash-ref (asset-map) file-name)))
+          (cond
+           ((and assets (or (eq? type 'close-write) (eq? type 'moved-to)))
+            ;; Expire everything from cache, then reload.
+            (hash-for-each (lambda (key asset)
+                             (expire-cached-artifact (cache-key asset)))
+                           assets)
+            (hash-for-each (lambda (key asset)
+                             (load! asset))
+                           assets))
+           ;; ooh, a new directory to watch!
+           ((eq? type 'create)
+            (watch-recursively file-name))))))))
+
+(define (cache-key asset)
+  (list (loader asset) (file-name asset) (loader-args asset)))
+
+(define (cache-artifact key artifact)
+  (hash-set! (artifact-cache) key artifact))
+
+(define (expire-cached-artifact key)
+  (hash-remove! (artifact-cache) key))
+
+(define (fetch-cached-artifact key)
+  (hash-ref (artifact-cache) key))
+
+(define (load-artifact cache-key loader file-name loader-args)
+  (or (fetch-cached-artifact cache-key)
+      (let ((artifact (apply loader file-name loader-args)))
+        (cache-artifact cache-key artifact)
+        artifact)))
+
+(define (load! asset)
+  (let ((thing (load-artifact (cache-key asset)
+                              (loader asset)
+                              (file-name asset)
+                              (loader-args asset))))
+    (set! (artifact asset) thing)
+    thing))
+
+(define-method (asset-ref (asset <asset>))
+  (or (artifact asset) (load! asset)))
+
+(define-method (asset-ref anything)
+  anything)
+
+(define-syntax-rule (define-asset name
+                      (loader file-name loader-args ...))
+  (define name
+    (make <asset>
+      #:file-name file-name
+      #:loader loader
+      #:loader-args (list loader-args ...))))
diff --git a/engine/inotify.scm b/engine/inotify.scm
new file mode 100644
index 0000000..b5fb8d8
--- /dev/null
+++ b/engine/inotify.scm
@@ -0,0 +1,209 @@
+;;; 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 inotify)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (system foreign)
+  #:export (make-inotify
+            inotify?
+            inotify-watches
+            inotify-add-watch!
+            inotify-pending-events?
+            inotify-read-event
+            inotify-watch?
+            inotify-watch-id
+            inotify-watch-file-name
+            inotify-watch-remove!
+            inotify-event?
+            inotify-event-watch
+            inotify-event-type
+            inotify-event-cookie
+            inotify-event-file-name))
+
+(define libc (dynamic-link))
+
+(define inotify-init
+  (pointer->procedure int (dynamic-func "inotify_init" libc) '()))
+
+(define inotify-add-watch
+  (pointer->procedure int (dynamic-func "inotify_add_watch" libc)
+                      (list int '* uint32)))
+
+(define inotify-rm-watch
+  (pointer->procedure int (dynamic-func "inotify_rm_watch" libc)
+                      (list int int)))
+
+(define IN_ACCESS #x00000001) ; file was accessed.
+(define IN_MODIFY #x00000002) ; file was modified.
+(define IN_ATTRIB #x00000004) ; metadata changed
+(define IN_CLOSE_WRITE #x00000008) ; file opened for writing closed
+(define IN_CLOSE_NOWRITE #x00000010) ; file not opened for writing closed
+(define IN_OPEN #x00000020) ; file was opened
+(define IN_MOVED_FROM #x00000040) ; file was moved from X
+(define IN_MOVED_TO #x00000080) ; file was moved to Y
+(define IN_CREATE #x00000100) ; subfile was created
+(define IN_DELETE #x00000200) ; subfile was deleted
+(define IN_DELETE_SELF #x00000400) ; self was deleted
+(define IN_MOVE_SELF #x00000800) ; self was moved
+;; Kernel flags
+(define IN_UNMOUNT #x00002000) ; backing fs was unmounted
+(define IN_Q_OVERFLOW #x00004000) ; event queue overflowed
+(define IN_IGNORED #x00008000) ; file was ignored
+;; Special flags
+(define IN_ONLYDIR #x01000000) ; only watch if directory
+(define IN_DONT_FOLLOW #x02000000) ; do not follow symlink
+(define IN_EXCL_UNLINK #x04000000) ; exclude events on unlinked objects
+(define IN_MASK_ADD #x20000000) ; add to the mask of an existing watch
+(define IN_ISDIR #x40000000) ; event occurred against directory
+(define IN_ONESHOT #x80000000) ; only send event once
+
+(define mask/symbol (make-hash-table))
+(define symbol/mask (make-hash-table))
+
+(for-each (match-lambda
+            ((sym mask)
+             (hashq-set! symbol/mask sym mask)
+             (hashv-set! mask/symbol mask sym)))
+          `((access ,IN_ACCESS)
+            (modify ,IN_MODIFY)
+            (attrib ,IN_ATTRIB)
+            (close-write ,IN_CLOSE_WRITE)
+            (close-no-write ,IN_CLOSE_NOWRITE)
+            (open ,IN_OPEN)
+            (moved-from ,IN_MOVED_FROM)
+            (moved-to ,IN_MOVED_TO)
+            (create ,IN_CREATE)
+            (delete ,IN_DELETE)
+            (delete-self ,IN_DELETE_SELF)
+            (move-self ,IN_MOVE_SELF)
+            (only-dir ,IN_ONLYDIR)
+            (dont-follow ,IN_DONT_FOLLOW)
+            (exclude-unlink ,IN_EXCL_UNLINK)
+            (is-directory ,IN_ISDIR)
+            (once ,IN_ONESHOT)))
+
+(define (symbol->mask sym)
+  (hashq-ref symbol/mask sym))
+
+(define (mask->symbol sym)
+  (hashq-ref mask/symbol sym))
+
+(define-record-type <inotify>
+  (%make-inotify port buffer buffer-pointer watches)
+  inotify?
+  (port inotify-port)
+  (buffer inotify-buffer)
+  (buffer-pointer inotify-buffer-pointer)
+  (watches inotify-watches))
+
+(define-record-type <inotify-watch>
+  (make-inotify-watch id file-name owner)
+  inotify-watch?
+  (id inotify-watch-id)
+  (file-name inotify-watch-file-name)
+  (owner inotify-watch-owner))
+
+(define-record-type <inotify-event>
+  (make-inotify-event watch type cookie file-name)
+  inotify-event?
+  (watch inotify-event-watch)
+  (type inotify-event-type)
+  (cookie inotify-event-cookie)
+  (file-name inotify-event-file-name))
+
+(define (display-inotify inotify port)
+  (format port "#<inotify port: ~a>" (inotify-port inotify)))
+
+(define (display-inotify-watch watch port)
+  (format port "#<inotify-watch id: ~d file-name: ~a>"
+          (inotify-watch-id watch)
+          (inotify-watch-file-name watch)))
+
+(define (display-inotify-event event port)
+  (format port "#<inotify-event type: ~s cookie: ~d file-name: ~a watch: ~a>"
+          (inotify-event-type event)
+          (inotify-event-cookie event)
+          (inotify-event-file-name event)
+          (inotify-event-watch event)))
+
+(set-record-type-printer! <inotify> display-inotify)
+(set-record-type-printer! <inotify-watch> display-inotify-watch)
+(set-record-type-printer! <inotify-event> display-inotify-event)
+
+(define (make-inotify)
+  (let ((fd (inotify-init))
+        (buffer (make-bytevector 4096)))
+    (%make-inotify (fdopen fd "r")
+                   buffer
+                   (bytevector->pointer buffer)
+                   (make-hash-table))))
+
+(define (inotify-fd inotify)
+  (port->fdes (inotify-port inotify)))
+
+(define (absolute-file-name file-name)
+  (if (absolute-file-name? file-name)
+      file-name
+      (string-append (getcwd) "/" file-name)))
+
+(define (inotify-add-watch! inotify file-name modes)
+  (let* ((abs-file-name (absolute-file-name file-name))
+         (wd (inotify-add-watch (inotify-fd inotify)
+                                (string->pointer abs-file-name)
+                                (apply logior (map symbol->mask modes))))
+         (watch (make-inotify-watch wd abs-file-name inotify)))
+    (hashv-set! (inotify-watches inotify) wd watch)
+    watch))
+
+(define (inotify-watch-remove! watch)
+  (inotify-rm-watch (inotify-fd (inotify-watch-owner watch))
+                    (inotify-watch-id watch))
+  (hashv-remove! (inotify-watches (inotify-watch-owner watch))
+                 (inotify-watch-id watch)))
+
+(define (inotify-pending-events? inotify)
+  (char-ready? (inotify-port inotify)))
+
+(define (read-int port buffer)
+  (get-bytevector-n! port buffer 0 (sizeof int))
+  (bytevector-sint-ref buffer 0 (native-endianness) (sizeof int)))
+
+(define (read-uint32 port buffer)
+  (get-bytevector-n! port buffer 0 (sizeof uint32))
+  (bytevector-uint-ref buffer 0 (native-endianness) (sizeof uint32)))
+
+(define (read-string port buffer buffer-pointer length)
+  (and (> length 0)
+       (begin
+         (get-bytevector-n! port buffer 0 length)
+         (pointer->string buffer-pointer))))
+
+(define (inotify-read-event inotify)
+  (let* ((port (inotify-port inotify))
+         (buffer (inotify-buffer inotify))
+         (wd (read-int port buffer))
+         (event-mask (read-uint32 port buffer))
+         (cookie (read-uint32 port buffer))
+         (len (read-uint32 port buffer))
+         (name (read-string port buffer (inotify-buffer-pointer inotify) len)))
+    (make-inotify-event (hashv-ref (inotify-watches inotify) wd)
+                        (mask->symbol event-mask) cookie name)))
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)))
diff --git a/engine/node.scm b/engine/node.scm
new file mode 100644
index 0000000..d95cfd9
--- /dev/null
+++ b/engine/node.scm
@@ -0,0 +1,251 @@
+;;; 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)
+  #:use-module (chickadee)
+  #:use-module (chickadee math matrix)
+  #:use-module (chickadee math quaternion)
+  #:use-module (chickadee math vector)
+  #:use-module (chickadee scripting)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:use-module ((srfi srfi-1) #:prefix srfi-1:)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:export (<node>
+            name
+            parent
+            children
+            started?
+            active?
+            visible?
+            agenda
+            rank
+            each-child
+            activate
+            deactivate
+            update
+            update/children
+            draw
+            draw/children
+            on-start
+            on-enter
+            on-exit
+            on-quit
+            on-key-press
+            on-text-edit
+            child-ref
+            node-let
+            attach
+            detach
+            populate
+            root-node
+            set-root-node!
+            reset-root-node!
+            run-node))
+
+(define-syntax-rule (cons! item var)
+  (set! var (cons item var)))
+
+(define-class <node> ()
+  (name #:accessor name #:init-form (gensym "anonymous-") #:init-keyword #:name)
+  (parent #:accessor parent #:init-form #f)
+  (children #:accessor children #:init-form '())
+  (children-map #:getter children-map #:init-form (make-hash-table))
+  (started? #:accessor started? #:init-form #f)
+  (active? #:accessor active? #:init-form #f)
+  (visible? #:accessor visible? #:init-form #t #:init-keyword #:visible?)
+  (agenda #:getter agenda #:init-form (make-agenda))
+  (rank #:getter rank #:init-value 0 #:init-keyword #:rank))
+
+(define (visit proc node)
+  "Apply PROC to NODE and all child nodes, recursively."
+  (with-agenda (agenda node) (proc node))
+  (for-each (cut visit proc <>) (children node)))
+
+(define (visit-while proc node)
+  "Apply PROC to NODE and all child nodes, recursively, stopping when
+PROC returns #f."
+  (and (with-agenda (agenda node) (proc node))
+       (let loop ((children (children node)))
+         (match children
+           (() #t)
+           ((head . tail)
+            (and (visit-while proc head)
+                 (loop tail)))))))
+
+(define (each-child proc node)
+  "Apply PROC to each child of NODE."
+  (for-each proc (children node)))
+
+(define-method (update/children (node <node>) dt)
+  "Update NODE, then update all children.  DT is the time-delta since
+the last update."
+  ;; Update children first.
+  (each-child (cut update/children <> dt) node)
+  ;; Update script, then "physics" (or whatever the update method is
+  ;; doing).
+  (with-agenda (agenda node)
+    (update-agenda 1)
+    (update node dt)))
+
+(define-method (draw/children (node <node>) alpha)
+  "Draw NODE, then draw all children.  ALPHA is a number between 0 and
+1 representing how far in between two updates the drawing is taking
+place."
+  (when (visible? node)
+    (draw node alpha)
+    (each-child (cut draw/children <> alpha) node)))
+
+(define-method (activate (node <node>))
+  "Start scripts for NODE and all its children."
+  (with-agenda (agenda node)
+    (unless (started? node)
+      (on-start node)
+      (set! (started? node) #t))
+    (on-enter node)
+    (set! (active? node) #t))
+  (each-child activate node))
+
+(define-method (deactivate (node <node>))
+  "Stop scripts for NODE and all its children."
+  (on-exit node)
+  (set! (active? node) #f)
+  (with-agenda (agenda node)
+    (reset-agenda))
+  (each-child deactivate node))
+
+(define-method (update (node <node>) dt) #t)
+(define-method (draw (node <node>) alpha) #t)
+(define-method (on-start (node <node>)) #t)
+(define-method (on-enter (node <node>)) #t)
+(define-method (on-exit (node <node>)) #t)
+(define-method (on-quit (node <node>)) #t)
+(define-method (on-key-press (node <node>) key modifiers repeat?) #t)
+(define-method (on-text-edit (node <node>) text) #t)
+
+(define-method (child-ref (node <node>) child-path)
+  "Return child node of NODE named CHILD-NAME, or #f if there isn't
+one."
+  (define (lookup node child-name)
+    (hashq-ref (children-map node) child-name))
+  (match child-path
+    ((or (child-name) (? symbol? child-name))
+     (lookup node child-name))
+    ((child-name . rest)
+     (child-ref (lookup node child-name) rest))))
+
+(define-syntax-rule (node-let node ((var child-name) ...) body ...)
+  (let ((var (child-ref node 'child-name)) ...)
+    body ...))
+
+(define-method (attach (new-parent <node>) . new-children)
+  "Attach NEW-CHILDREN to NEW-PARENT."
+  ;; Validate all children first, then add them to the parent node.
+  (for-each (lambda (child)
+              (when (parent child)
+                (error "node already has a parent:" child))
+              (when (child-ref new-parent (name child))
+                (error "node name taken:" (name child))))
+            new-children)
+  (set! (children new-parent)
+        (sort (append new-children (children new-parent))
+              (lambda (a b)
+                (< (rank a) (rank b)))))
+  (for-each (lambda (child)
+              (set! (parent child) new-parent)
+              (when (active? new-parent)
+                (activate child))
+              (hashq-set! (children-map new-parent) (name child) child))
+            new-children))
+
+(define-method (detach . nodes)
+  "Detach NODE from its parent."
+  (for-each (lambda (node)
+              (let ((parent (parent node)))
+                (unless parent
+                  (error "node has no parent" node))
+                (set! (children parent) (delq node (children parent)))
+                (hashq-remove! (children-map parent) (name node))
+                (when (active? node)
+                  (deactivate node)))
+              (set! (parent node) #f))
+            nodes))
+
+(define-method (populate (node <node>))
+  '())
+
+(define-method (initialize (node <node>) args)
+  (let ((children (let loop ((args args))
+                    (match args
+                      (() '())
+                      ((#:children children . _)
+                       children)
+                      ((key value . rest)
+                       (loop rest))))))
+    (next-method)
+    (apply attach node (append (populate node) children))))
+
+
+;;;
+;;; State management
+;;;
+
+(define *root-node* #f)
+
+(define (root-node)
+  "Return the current root node."
+  *root-node*)
+
+(define (set-root-node! new-root)
+  "Change the root node to NEW-ROOT."
+  (set! *root-node* new-root)
+  (activate new-root))
+
+(define (reset-root-node!)
+  "Restart the currently active node."
+  (deactivate (root-node))
+  (set-root-node! (root-node)))
+
+(define* (run-node make-root-node
+                   #:key
+                   (window-title "Chickadee Engine")
+                   (window-width 640)
+                   (window-height 480)
+                   window-fullscreen?
+                   (update-hz 60))
+  (add-hook! load-hook
+             (lambda ()
+               (set-root-node! (make-root-node))))
+  (add-hook! draw-hook (cut draw/children *root-node* <>))
+  (add-hook! update-hook (cut update/children *root-node* <>))
+  (add-hook! quit-hook
+             (lambda ()
+               (visit-while (cut on-quit <>) *root-node*)))
+  (add-hook! key-press-hook
+             (lambda (key sc mods repeat?)
+               (visit-while (cut on-key-press <> key mods repeat?)
+                            *root-node*)))
+  (add-hook! text-input-hook
+             (lambda (text)
+               (visit-while (cut on-text-edit <> text)
+                            *root-node*)))
+  (run-game #:window-title window-title
+            #:window-width window-width
+            #:window-height window-height
+            #:window-fullscreen? window-fullscreen?
+            #:update-hz update-hz))
diff --git a/engine/scene.scm b/engine/scene.scm
new file mode 100644
index 0000000..b47a30e
--- /dev/null
+++ b/engine/scene.scm
@@ -0,0 +1,44 @@
+;;; 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 scene)
+  #:use-module (chickadee audio)
+  #:use-module (engine node-2d)
+  #:use-module (oop goops)
+  #:export (<scene>
+            background-music
+            background-music-volume
+            background-music-loop?))
+
+(define-class <scene> (<node-2d>)
+  (background-music #:accessor background-music #:init-form #f
+                    #:init-keyword #:music)
+  (background-music-volume #:accessor background-music-volume #:init-form 1.0
+                           #:init-keyword #:music-volume)
+  (background-music-loop? #:accessor background-music-loop? #:init-form #t
+                          #:init-keyword #:music-loop?))
+
+(define-method (on-enter (scene <scene>))
+  (if (music? (background-music scene))
+      (begin
+        (set-music-volume! (background-music-volume scene))
+        (play-music (background-music scene)
+                    #:loop? (background-music-loop? scene)))
+      (stop-music)))
+
+(define-method (on-exit (scene <scene>))
+  (stop-music))
diff --git a/engine/shell.scm b/engine/shell.scm
new file mode 100644
index 0000000..12f6699
--- /dev/null
+++ b/engine/shell.scm
@@ -0,0 +1,236 @@
+;;; 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 shell)
+  #: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 font)
+  #:use-module (chickadee render framebuffer)
+  #:use-module (chickadee render sprite)
+  #:use-module (chickadee scripting)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (engine assets)
+  #:use-module (engine node)
+  #:use-module (engine node-2d)
+  #:use-module (oop goops)
+  #:use-module (sdl2)
+  #:use-module (srfi srfi-26)
+  #:use-module (system repl command)
+  #:use-module (system repl coop-server)
+  #:use-module (system repl debug)
+  #:use-module (system repl repl)
+  #:export (make-shell
+            current-scene
+            switch-scene))
+
+(define-asset shell-font
+  (load-tile-font "assets/fonts/bubblemad_8x8.png" 8 8
+                  " !\"©_%❤'()*+,-./0123456789:←<=>?@abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))
+
+(define %height 240)
+(define %width 320)
+
+(define-class <shell> (<node>)
+  (debug? #:allocation #:virtual
+          #:accessor debug?
+          #:slot-ref (lambda (shell)
+                       (visible? (child-ref shell 'debug-overlay)))
+          #:slot-set! (lambda (shell show?)
+                        (set! (visible? (child-ref shell 'debug-overlay))
+                              show?)))
+  (repl #:accessor repl #:init-form #f)
+  (repl-debug #:accessor repl-debug #:init-form #f)
+  (repl-debugging? #:accessor repl-debugging? #:init-form #f)
+  (current-scene #:accessor current-scene #:init-form #f
+                 #:init-keyword #:current-scene)
+  (reset #:getter reset-thunk #:init-form #f #:init-keyword #:reset)
+  (framebuffer #:getter framebuffer
+               #:init-form (make-framebuffer %width %height
+                                             #:min-filter 'nearest
+                                             #:mag-filter 'nearest))
+  (fb-region #:getter fb-region
+             #:init-form (make-rect 0.0 0.0 (* 2 %width) (* 2 %height)))
+  (projection #:getter projection
+              #:init-form (orthographic-projection 0 %width %height 0 0 1))
+  (frame-start-time #:accessor frame-start-time)
+  (avg-frame-time #:accessor avg-frame-time #:init-value 0.0)
+  (eval-prompt #:accessor eval-prompt
+               #:init-form (make <node-2d>
+                             #:name 'eval-prompt
+                             #:children
+                             (list
+                              (make <label>
+                                #:name 'prompt
+                                #:font shell-font
+                                #:text ">"
+                                #:position (vec2 0.0 0.0))
+                              (make <label>
+                                #:name 'source
+                                #:font shell-font
+                                #:text "(+ 1 2 3)"
+                                #:position (vec2 16.0 0.0))))))
+
+(define (error-string stack key args)
+  (call-with-output-string
+   (lambda (port)
+     (let ((frame (and (< 0 (vector-length stack)) (vector-ref stack 0))))
+       (print-exception port frame key args)))))
+
+(define-method (handle-error stack key args)
+  (let* ((shell (root-node))
+         (tag (and (pair? (fluid-ref %stacks))
+                   (cdr (fluid-ref %stacks))))
+         (stack (narrow-stack->vector
+                 stack
+                 ;; Take the stack from the given frame, cutting 0
+                 ;; frames.
+                 0
+                 ;; Narrow the end of the stack to the most recent
+                 ;; start-stack.
+                 tag
+                 ;; And one more frame, because %start-stack
+                 ;; invoking the start-stack thunk has its own frame
+                 ;; too.
+                 0 (and tag 1))))
+    (set! (repl-debug shell)
+          (make-debug stack 0 (error-string stack key args)))
+    (set! (repl-debugging? shell) #t)
+    (while (repl-debugging? shell)
+      (poll-coop-repl-server (repl shell)))))
+
+;(add-hook! error-hook handle-error)
+
+(define-meta-command ((debug-game chickadee) repl)
+  "debug-game
+Enter a debugger for the current game loop error."
+  (let ((shell (root-node)))
+    (format #t "~a~%" (debug-error-message (repl-debug shell)))
+    (format #t "Entering a new prompt.  ")
+    (format #t "Type `,bt' for a backtrace or `,q' to resume the game loop.\n")
+    (start-repl #:debug (repl-debug shell))
+    (set! (repl-debugging? shell) #f)))
+
+(define-method (before-draw)
+  (set! (frame-start-time (root-node)) (sdl-ticks)))
+
+(define-method (after-draw)
+  (let ((end (sdl-ticks))
+        (start (frame-start-time (root-node)))
+        (last (avg-frame-time (root-node))))
+    (set! (avg-frame-time (root-node))
+          (+ (* (- end start) 0.1) (* last 0.9)))))
+
+(add-hook! before-draw-hook before-draw)
+(add-hook! after-draw-hook after-draw)
+
+(define (switch-scene shell new-scene)
+  (detach (current-scene shell))
+  (set! (current-scene shell) new-scene)
+  (attach shell new-scene))
+
+(define-method (fps (shell <shell>))
+  (exact->inexact (/ 1000 (avg-frame-time shell))))
+
+(define-method (populate (shell <shell>))
+  (list
+   (make <node-2d>
+     #:name 'debug-overlay
+     #:visible? #f
+     #:children
+     (list
+      (make <label>
+        #:name 'fps-label
+        #:font shell-font
+        #:text "0.0"
+        #:position (vec2 0.0 232.0))))))
+
+(define-method (on-start (shell <shell>))
+  (set! (repl shell) (spawn-coop-repl-server)))
+
+(define-method (on-enter (shell <shell>))
+  (attach shell (current-scene shell))
+  (script
+   (forever
+    (sleep 60)
+    (set! (text (child-ref shell '(debug-overlay fps-label)))
+          (format #f "~1,2f" (fps shell))))))
+
+(define (reset-game)
+  (switch-scene (root-node) ((reset-thunk (root-node)))))
+
+(define-method (on-quit (shell <shell>))
+  (abort-game))
+
+(define-method (toggle-debug-mode (shell <shell>))
+  (set! (debug? shell) (not (debug? shell))))
+
+(define-method (toggle-eval-prompt (shell <shell>))
+  (let ((eval-prompt (eval-prompt shell)))
+    (if (active? eval-prompt)
+        (detach eval-prompt)
+        (attach (child-ref shell 'debug-overlay)
+                eval-prompt))))
+
+(define-method (on-key-press (shell <shell>) key mods repeat?)
+  (match mods
+    ((or ('left-control) ('right-control) ('caps-lock))
+     (match key
+       ('d
+        (toggle-debug-mode shell)
+        #f)
+       ('q (abort-game))
+       ('r
+        (reset-game)
+        #f)
+       (_ #t)))
+    ((or ('left-alt) ('right-alt))
+     (match key
+       ('x
+        (if (debug? shell)
+            (begin
+              (toggle-eval-prompt shell)
+              #f)
+            #t))
+       (_ #t)))
+    (_ #t)))
+
+(define-method (update (shell <shell>) dt)
+  (poll-coop-repl-server (repl shell))
+  (reload-modified-assets))
+
+(define %origin (vec2 0.0 0.0))
+
+(define-method (draw (shell <shell>) alpha)
+  (draw-sprite (framebuffer-texture (framebuffer shell))
+               %origin
+               #:rect (fb-region shell)))
+
+(define-method (draw/children (shell <shell>) alpha)
+  ;; Render children before self so that we populate the framebuffer.
+  (with-framebuffer (framebuffer shell)
+    (with-projection (projection shell)
+      (each-child (cut draw/children <> alpha) shell)))
+  (draw shell alpha))
+
+(define (make-shell initial-scene-thunk)
+  (watch-asset-directory "assets")
+  (make <shell> #:name 'shell #:current-scene (initial-scene-thunk)
+        #:reset initial-scene-thunk))
-- 
cgit v1.2.3