diff options
Diffstat (limited to 'engine')
| -rw-r--r-- | engine/README | 6 | ||||
| -rw-r--r-- | engine/assets.scm | 170 | ||||
| -rw-r--r-- | engine/inotify.scm | 209 | ||||
| -rw-r--r-- | engine/node-2d.scm | 359 | ||||
| -rw-r--r-- | engine/node.scm | 251 | ||||
| -rw-r--r-- | engine/scene.scm | 44 | ||||
| -rw-r--r-- | engine/shell.scm | 236 |
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)) |