summaryrefslogtreecommitdiff
path: root/engine
diff options
context:
space:
mode:
authorRicardo Wurmus <rekado@elephly.net>2018-06-25 10:56:18 +0200
committerRicardo Wurmus <rekado@elephly.net>2018-07-27 17:15:43 +0200
commitb057acbc3b06d1e815bb1b9d43241ac35b058d1e (patch)
tree8e1d02f241b7b9b6456157ac8c7385f8074da1ed /engine
Initial commit.
Diffstat (limited to 'engine')
-rw-r--r--engine/README6
-rw-r--r--engine/assets.scm170
-rw-r--r--engine/inotify.scm209
-rw-r--r--engine/node-2d.scm359
-rw-r--r--engine/node.scm251
-rw-r--r--engine/scene.scm44
-rw-r--r--engine/shell.scm236
7 files changed, 1275 insertions, 0 deletions
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))