diff options
Diffstat (limited to 'lisparuga')
| -rw-r--r-- | lisparuga/asset.scm | 200 | ||||
| -rw-r--r-- | lisparuga/config.scm | 34 | ||||
| -rw-r--r-- | lisparuga/gui.scm | 145 | ||||
| -rw-r--r-- | lisparuga/inotify.scm | 217 | ||||
| -rw-r--r-- | lisparuga/kernel.scm | 303 | ||||
| -rw-r--r-- | lisparuga/node-2d.scm | 638 | ||||
| -rw-r--r-- | lisparuga/node.scm | 281 | ||||
| -rw-r--r-- | lisparuga/repl.scm | 99 | ||||
| -rw-r--r-- | lisparuga/scene.scm | 198 | ||||
| -rw-r--r-- | lisparuga/transition.scm | 128 |
10 files changed, 2243 insertions, 0 deletions
diff --git a/lisparuga/asset.scm b/lisparuga/asset.scm new file mode 100644 index 0000000..b4969b0 --- /dev/null +++ b/lisparuga/asset.scm @@ -0,0 +1,200 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Abstraction for loading game data from the file system, including +;; automatically reloading the data when it changes. +;; +;;; Code: + +(define-module (lisparuga asset) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:use-module (lisparuga inotify) + #:export (<asset> + artifact + file-name + loader + args + watch-assets + watching-assets? + watch-asset-directory + reload-modified-assets + clear-asset-cache + asset-ref + define-asset)) + +(define-class <asset> () + (watch? #:allocation #:class #:init-form #f) + ;; class slots for asset cache and live reloading + (inotify #:allocation #:class #:init-form #f) + ;; file-name -> assets mapping + (asset-file-map #:allocation #:class #:init-form (make-hash-table)) + ;; args -> artifact mapping + (artifact-cache #:allocation #:class #:init-form (make-weak-value-hash-table)) + ;; asset -> artifact mapping + (asset-artifact-map #:allocation #:class #:init-form (make-weak-key-hash-table)) + (watches #:allocation #:class #:init-form '()) + ;; instance slots + (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)) + +(define (absolute-file-name file-name) + (if (absolute-file-name? file-name) + file-name + (string-append (getcwd) "/" file-name))) + +(define-method (initialize (asset <asset>) initargs) + (next-method) + ;; Convert file name to an absolute file name. + (slot-set! asset 'file-name (absolute-file-name (file-name asset))) + ;; Add asset to the file-name -> asset map + (let* ((asset-file-map (class-slot-ref <asset> 'asset-file-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-file-map (file-name asset)) + (let ((wt (make-weak-key-hash-table))) + (hash-set! asset-file-map (file-name asset) wt) + wt)))) + (hash-set! sub-table asset asset))) + +(define (asset-inotify) + (class-slot-ref <asset> 'inotify)) + +(define (asset-file-map) + (class-slot-ref <asset> 'asset-file-map)) + +(define (artifact-cache) + (class-slot-ref <asset> 'artifact-cache)) + +(define (asset-artifact-map) + (class-slot-ref <asset> 'asset-artifact-map)) + +(define (asset-watches) + (class-slot-ref <asset> 'watches)) + +(define (watch-assets watch?) + (let ((old-watch? (watching-assets?))) + (class-slot-set! <asset> 'watch? watch?) + (cond + ;; Watching is being turned on. + ((and watch? (not old-watch?)) + ;; Retroactively add watches for all existing assets. + (hash-for-each (lambda (file-name assets) + (watch-asset-directory (dirname file-name))) + (asset-file-map))) + ;; Watching is being turned off. + ((and (not watch?) old-watch?) + ;; Deactive inotify watches. + (for-each inotify-watch-remove! (inotify-watches (asset-inotify))))))) + +(define (watching-assets?) + (class-slot-ref <asset> 'watch?)) + +(define (directory-watched? dir) + (find (lambda (watch) + (string=? (inotify-watch-file-name watch) dir)) + (asset-watches))) + +(define (watch-asset-directory dir) + ;; Lazily activate inotify. + (unless (asset-inotify) + (class-slot-set! <asset> 'inotify (make-inotify))) + ;; Add watch if it doesn't already exist. + (unless (directory-watched? dir) + (class-slot-set! <asset> 'watches + (cons (inotify-add-watch! (asset-inotify) + dir + '(create close-write moved-to)) + (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-file-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)))))))) + +(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 (clear-asset-cache) + (hash-clear! (artifact-cache)) + (hash-clear! (asset-artifact-map))) + +(define (fetch-cached-artifact key) + (hash-ref (artifact-cache) key)) + +(define (load-artifact cache-key loader file-name loader-args add-watch?) + (or (fetch-cached-artifact cache-key) + (let ((artifact (apply loader file-name loader-args))) + (cache-artifact cache-key artifact) + (when (and add-watch? (watching-assets?)) + (watch-asset-directory (dirname file-name))) + artifact))) + +(define* (load! asset #:optional add-watch?) + (let ((thing (load-artifact (cache-key asset) + (loader asset) + (file-name asset) + (loader-args asset) + add-watch?))) + (hashq-set! (asset-artifact-map) asset thing) + thing)) + +(define-method (asset-ref (asset <asset>)) + ;; Assets are lazy-loaded upon first access. + (or (hashq-ref (asset-artifact-map) asset) + (load! asset #t))) + +;; Make assets that are outside of the cache "just work". +(define-method (asset-ref x) x) + +;; Handy syntax for defining new assets. +(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/lisparuga/config.scm b/lisparuga/config.scm new file mode 100644 index 0000000..322bf78 --- /dev/null +++ b/lisparuga/config.scm @@ -0,0 +1,34 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Global engine configuration. +;; +;;; Code: + +(define-module (lisparuga config) + #:export (developer-mode? + asset-dir + scope-asset)) + +(define developer-mode? + (equal? (getenv "LISPARGUA_DEV_MODE") "1")) + +(define asset-dir (getenv "LISPARUGA_ASSETDIR")) + +(define (scope-asset file-name) + (string-append asset-dir "/" file-name)) diff --git a/lisparuga/gui.scm b/lisparuga/gui.scm new file mode 100644 index 0000000..9f60526 --- /dev/null +++ b/lisparuga/gui.scm @@ -0,0 +1,145 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 2D Graphical User Interface +;; +;;; Code: + +(define-module (lisparuga gui) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (chickadee render color) + #:use-module (chickadee render font) + #:use-module (chickadee render shapes) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (lisparuga node) + #:use-module (lisparuga node-2d) + #:export (<widget> + width + height + + <label-widget> + + <margin-container> + left + right + bottom + top)) + + +;;; +;;; Base Widget +;;; + +(define *draw-bounding-boxes?* #t) +(define %bounding-box-color (make-color 1.0 0.0 1.0 0.2)) + +(define-class <widget> (<node-2d>) + (width #:accessor width #:init-keyword #:width #:init-form 0.0) + (height #:accessor height #:init-keyword #:height #:init-form 0.0) + (min-width #:accessor min-width #:init-keyword #:min-width #:init-form 0.0) + (min-height #:accessor min-height #:init-keyword #:min-height #:init-form 0.0) + (bounding-box #:getter bounding-box #:init-form (make-rect 0.0 0.0 0.0 0.0)) + (dirty-bounding-box? #:accessor dirty-bounding-box? #:init-form #t)) + +(define-method (dirty! (widget <widget>)) + (set! (dirty-bounding-box? widget) #t) + (next-method)) + +(define-method ((setter width) (widget <widget>) w) + (slot-set! widget 'width (pk 'new-width (max (min-width widget) w))) + (dirty! widget)) + +(define-method ((setter height) (widget <widget>) h) + (slot-set! widget 'height (max (min-height widget) h)) + (dirty! widget)) + +(define-method (update (widget <widget>) dt) + (when (dirty-bounding-box? widget) + (let ((bb (bounding-box widget)) + (w (width widget)) + (h (height widget))) + (set-rect-width! bb w) + (set-rect-height! bb h)) + (set! (dirty-bounding-box? widget) #f))) + +(define-method (render (widget <widget>) alpha) + (draw-filled-rect (bounding-box widget) %bounding-box-color + #:matrix (world-matrix widget)) + (next-method)) + + +;;; +;;; Text Label +;;; + +(define-class <label-widget> (<widget>) + (text #:accessor text #:init-keyword #:text #:init-form "")) + +(define-method ((setter text) (label <label-widget>) new-text) + (set! (text (& label label)) new-text) + (next-method)) + +(define-method (on-boot (label <label-widget>)) + (attach-to label + (make <label> + #:name 'label + #:text (text label)))) + + +;;; +;;; Margin Container +;;; + +(define-class <margin-container> (<widget>) + (left #:accessor left #:init-keyword #:left #:init-form 0.0) + (right #:accessor right #:init-keyword #:right #:init-form 0.0) + (bottom #:accessor bottom #:init-keyword #:bottom #:init-form 0.0) + (top #:accessor top #:init-keyword #:top #:init-form 0.0) + (needs-resize? #:accessor needs-resize? #:init-form #t)) + +(define-method (on-attach (container <margin-container>) (widget <widget>)) + (set! (needs-resize? container) #t)) + +(define-method (on-detach (container <margin-container>) (widget <widget>)) + (set! (needs-resize? container) #t)) + +(define-method (update (container <margin-container>) dt) + (when (needs-resize? container) + (let loop ((c (children container)) + (w 0.0) + (h 0.0)) + (match c + (() + (set! (width container) (pk 'new-width (+ w (left container) (right container)))) + (set! (height container) (+ h (bottom container) (top container))) + (for-each (lambda (child) + (when (is-a? child <widget>) + (set! (width child) w) + (set! (height child) h) + (teleport child (left container) (bottom container)))) + (children container))) + ((child . rest) + (if (is-a? child <widget>) + (loop rest + (max w (min-width child)) + (max h (min-height child))) + (loop rest w h))))) + (set! (needs-resize? container) #f)) + (next-method)) diff --git a/lisparuga/inotify.scm b/lisparuga/inotify.scm new file mode 100644 index 0000000..8d62562 --- /dev/null +++ b/lisparuga/inotify.scm @@ -0,0 +1,217 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Inotify bindings. +;; +;;; Code: + +(define-module (lisparuga 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) + ;; Sometimes an interrupt happens during the char-ready? call and an + ;; exception is thrown. Just return #f in that case and move on + ;; with life. + (false-if-exception (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/lisparuga/kernel.scm b/lisparuga/kernel.scm new file mode 100644 index 0000000..f94b832 --- /dev/null +++ b/lisparuga/kernel.scm @@ -0,0 +1,303 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This is the core of the game engine, the root node, that is +;; responsible for starting up the game loop and passing along render, +;; update, and input events to the other parts of the game. +;; +;;; Code: + +(define-module (lisparuga kernel) + #:use-module (chickadee audio) + #:use-module (chickadee game-loop) + #:use-module (chickadee render) + #:use-module (chickadee render gpu) + #:use-module (chickadee render viewport) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (sdl2) + #:use-module (sdl2 events) + #:use-module (sdl2 input game-controller) + #:use-module (sdl2 input joystick) + #:use-module (sdl2 input text) + #:use-module (sdl2 video) + #:use-module (lisparuga asset) + #:use-module (lisparuga config) + #:use-module (lisparuga node) + #:use-module (lisparuga repl) + #:use-module (lisparuga scene) + #:use-module (system repl command) + #:export (<window-config> + width + height + title + fullscreen? + + <kernel> + window-config + update-hz + window + gl-context + avg-frame-time + current-kernel + boot-kernel + elapsed-time + fps + reboot-current-scene) + #:re-export (abort-game)) + +(define-class <window-config> () + (width #:accessor width #:init-form 640 #:init-keyword #:width) + (height #:accessor height #:init-form 480 #:init-keyword #:height) + (title #:accessor title #:init-form "Lisparuga" + #:init-keyword #:title) + (fullscreen? #:accessor fullscreen? #:init-form #f + #:init-keyword #:fullscreen?)) + +(define-class <kernel> (<scene-mux>) + (name #:accessor name #:init-form "lisparuga-kernel" + #:init-keyword #:name) + (window-config #:accessor window-config #:init-form (make <window-config>) + #:init-keyword #:window-config) + (update-hz #:accessor update-hz #:init-form 60 + #:init-keyword #:update-hz) + (window #:accessor window) + (gl-context #:accessor gl-context) + (default-viewport #:accessor default-viewport) + (avg-frame-time #:accessor avg-frame-time #:init-form 0.0) + (controllers #:accessor controllers #:init-thunk make-hash-table) + (repl #:accessor repl)) + +(define current-kernel (make-parameter #f)) + +;; game controller bookkeeping. +(define (lookup-controller kernel joystick-id) + (hashv-ref (controllers kernel) joystick-id)) + +(define (add-controller kernel joystick-index) + (let ((controller (open-game-controller joystick-index))) + (hashv-set! (controllers kernel) + (joystick-instance-id + (game-controller-joystick controller)) + controller) + controller)) + +(define (remove-controller kernel joystick-id) + (hashv-remove! (controllers kernel) joystick-id)) + +(define (initialize-controllers kernel) + (let loop ((i 0)) + (when (< i (num-joysticks)) + (when (game-controller-index? i) + (add-controller kernel i)) + (loop (+ i 1))))) + +(define-method (on-boot (kernel <kernel>)) + (when developer-mode? + ;; Enable live asset reloading. + (watch-assets #t) + ;; Start REPL server. + (attach-to kernel (make <repl> #:name 'repl)))) + +(define-method (update-tree (kernel <kernel>) dt) + (define (invert-y y) + ;; SDL's origin is the top-left, but our origin is the bottom + ;; left so we need to invert Y coordinates that SDL gives us. + (match (window-size (window kernel)) + ((_ height) + (- height y)))) + (define (process-event event) + (cond + ((quit-event? event) + (on-quit kernel)) + ((keyboard-down-event? event) + (on-key-press kernel + (keyboard-event-key event) + (keyboard-event-scancode event) + (keyboard-event-modifiers event) + (keyboard-event-repeat? event))) + ((keyboard-up-event? event) + (on-key-release kernel + (keyboard-event-key event) + (keyboard-event-scancode event) + (keyboard-event-modifiers event))) + ((text-input-event? event) + (on-text-input kernel + (text-input-event-text event))) + ((mouse-button-down-event? event) + (on-mouse-press kernel + (mouse-button-event-button event) + (mouse-button-event-clicks event) + (mouse-button-event-x event) + (invert-y (mouse-button-event-y event)))) + ((mouse-button-up-event? event) + (on-mouse-release kernel + (mouse-button-event-button event) + (mouse-button-event-x event) + (invert-y (mouse-button-event-y event)))) + ((mouse-motion-event? event) + (on-mouse-move kernel + (mouse-motion-event-x event) + (invert-y (mouse-motion-event-y event)) + (mouse-motion-event-x-rel event) + (- (mouse-motion-event-y-rel event)) + (mouse-motion-event-buttons event))) + ((and (controller-device-event? event) + (eq? (controller-device-event-action event) 'added)) + (let ((controller + (add-controller kernel + (controller-device-event-which event)))) + (on-controller-add kernel controller))) + ((and (controller-device-event? event) + (eq? (controller-device-event-action event) 'removed)) + (let ((controller + (lookup-controller kernel + (controller-device-event-which event)))) + (on-controller-remove kernel controller) + (remove-controller kernel (controller-device-event-which event)) + (close-game-controller controller))) + ((controller-button-down-event? event) + (let ((controller + (lookup-controller kernel + (controller-button-event-which event)))) + (on-controller-press kernel + controller + (controller-button-event-button event)))) + ((controller-button-up-event? event) + (let ((controller + (lookup-controller kernel + (controller-button-event-which event)))) + (on-controller-release kernel + controller + (controller-button-event-button event)))) + ((controller-axis-event? event) + (let ((controller + (lookup-controller kernel + (controller-axis-event-which event)))) + (on-controller-move kernel + controller + (controller-axis-event-axis event) + (/ (controller-axis-event-value event) 32768.0)))))) + (define (poll-events) + (let ((event (poll-event))) + (when event + (process-event event) + (poll-events)))) + ;; Process all pending events before we update any other node. + (poll-events) + ;; Proceed with standard update procedure. + (next-method)) + +(define-method (update (kernel <kernel>) dt) + (update-audio) + (when developer-mode? + (reload-modified-assets)) + ;; Free any GPU resources that have been GC'd. + (gpu-reap!)) + +(define-method (render-tree (kernel <kernel>) alpha) + (let ((start-time (elapsed-time))) + ;; Switch to the null viewport to ensure that + ;; the default viewport will be re-applied and + ;; clear the screen. + (set-gpu-viewport! (current-gpu) null-viewport) + (with-viewport (default-viewport kernel) + (next-method)) + (swap-gl-window (window kernel)) + ;; Compute FPS. + (set! (avg-frame-time kernel) + (+ (* (- (elapsed-time) start-time) 0.1) + (* (avg-frame-time kernel) 0.9))))) + +(define-method (on-error (kernel <kernel>) stack key args) + (if developer-mode? + (let ((title (window-title (window kernel)))) + (set-window-title! (window kernel) (string-append "[ERROR] " title)) + (on-error (& kernel repl) stack key args) + (set-window-title! (window kernel) title)) + (apply throw key args))) + +(define-method (on-scenes-empty (kernel <kernel>)) + (abort-game)) + +(define (elapsed-time) + (sdl-ticks)) + +(define-method (fps kernel) + (/ 1000.0 (avg-frame-time kernel))) + +(define-method (boot-kernel (kernel <kernel>) thunk) + (sdl-init) + ;; This will throw an error if any audio subsystem is unavailable, + ;; but not every audio subsystem is needed so don't crash the + ;; program over it. + (start-text-input) + ;; Discover all game controllers that are already connected. New + ;; connections/disconnections will be handled by events as they occur. + (initialize-controllers kernel) + (init-audio) + (let ((wc (window-config kernel))) + (set! (window kernel) + (make-window #:opengl? #t + #:title (title wc) + #:size (list (width wc) (height wc)) + #:fullscreen? (fullscreen? wc))) + (set! (gl-context kernel) (make-gl-context (window kernel))) + (set! (default-viewport kernel) + (make-viewport 0 0 (width wc) (height wc))) + ;; Attempt to activate vsync, if possible. Some systems do + ;; not support setting the OpenGL swap interval. + (catch #t + (lambda () + (set-gl-swap-interval! 'vsync)) + (lambda args + (display "warning: could not enable vsync\n" + (current-error-port)))) + (dynamic-wind + (const #t) + (lambda () + (parameterize ((current-kernel kernel) + (current-gpu (make-gpu (gl-context kernel)))) + (activate kernel) + (push-scene kernel (thunk)) + (run-game* #:update (lambda (dt) (update-tree kernel dt)) + #:render (lambda (alpha) (render-tree kernel alpha)) + #:error (lambda (stack key args) + (on-error kernel stack key args)) + #:time elapsed-time + #:update-hz (update-hz kernel)))) + (lambda () + (deactivate kernel) + (quit-audio) + (delete-gl-context! (gl-context kernel)) + (close-window! (window kernel)))))) + +(define (reboot-current-scene) + "Reboot the currently active scene being managed by the game engine +kernel. A convenient procedure for developers." + (reboot (current-scene (current-kernel)))) + +(define-meta-command ((debug-game lisparuga) repl) + "debug-game +Enter a debugger for the current game loop error." + (debugger (& (current-kernel) repl))) + +(define-meta-command ((resume-game lisparuga) repl) + "resume-game +Resume the game loop without entering a debugger." + (set! (repl-debugging? (& (current-kernel) repl)) #f)) diff --git a/lisparuga/node-2d.scm b/lisparuga/node-2d.scm new file mode 100644 index 0000000..9397c77 --- /dev/null +++ b/lisparuga/node-2d.scm @@ -0,0 +1,638 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 2D game nodes. +;; +;;; Code: + +(define-module (lisparuga node-2d) + #:use-module (chickadee math bezier) + #:use-module (chickadee math easings) + #: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 particles) + #:use-module (chickadee render shapes) + #:use-module (chickadee render sprite) + #:use-module (chickadee render texture) + #:use-module (chickadee render tiled) + #:use-module (chickadee render viewport) + #:use-module (chickadee scripting) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (sdl2 video) + #:use-module (lisparuga asset) + #:use-module (lisparuga kernel) + #:use-module (lisparuga node) + #:use-module (lisparuga scene) + #:export (<camera-2d> + target + offset + position + width + height + + <view-2d> + camera + area + + <canvas> + views + + <scene-2d> + + <node-2d> + origin + position + rotation + scale + skew + local-matrix + world-matrix + dirty! + pivot + move-by + move-to + teleport + rotate-by + rotate-to + scale-by + scale-to + follow-bezier-path + + <sprite> + texture + texcoords + source-rect + blend-mode + tint + + <atlas-sprite> + atlas + index + + <animation> + frames + frame-duration + + <animated-sprite> + animations + frame-duration + current-animation + start-time + change-animation + + <sprite-batch> + batch + + <filled-rect> + region + color + + <label> + font + text + + <tile-map> + tile-map + layers + + <particles> + particles)) + + +;;; +;;; 2D Camera +;;; + +;; Cameras define a view into the scene. They are attached to a 2D +;; node and follow it around. + +(define-class <camera-2d> () + (target #:accessor target #:init-form #f #:init-keyword #:target) + (offset #:getter offset #:init-form #v(0.0 0.0) #:init-keyword #:offset) + (position #:getter position #:init-form #v(0.0 0.0)) + (last-position #:getter last-position #:init-form #v(0.0 0.0)) + (width #:getter width #:init-keyword #:width) + (height #:getter height #:init-keyword #:height) + (projection-matrix #:accessor projection-matrix) + ;; Combined projection/view matrix + (view-matrix #:getter view-matrix #:init-form (make-identity-matrix4)) + (framebuffer #:accessor framebuffer)) + +(define-method (initialize (camera <camera-2d>) initargs) + (next-method) + ;; Initialize framebuffer and orthographic projection matrix based + ;; on the resolution of the camera. + (set! (framebuffer camera) + (make-framebuffer (width camera) + (height camera) + #:min-filter 'nearest + #:mag-filter 'nearest)) + (set! (projection-matrix camera) + (orthographic-projection 0 (width camera) (height camera) 0 0 1))) + +;; This method can be overridden by subclasses to create custom camera +;; movement. +(define-method (follow-target (camera <camera-2d>) dt) + (let ((pos (position camera)) + (target-pos (position (target camera))) + (offset (offset camera))) + (set-vec2-x! pos (- (vec2-x offset) (vec2-x target-pos))) + (set-vec2-y! pos (- (vec2-y offset) (vec2-y target-pos))))) + +(define-method (update (camera <camera-2d>) dt) + (when (target camera) + (let ((pos (position camera)) + (last-pos (last-position camera)) + (m (view-matrix camera))) + (vec2-copy! pos last-pos) + (follow-target camera dt) + (unless (and (= (vec2-x pos) (vec2-x last-pos)) + (= (vec2-y pos) (vec2-y last-pos))) + (matrix4-translate! m pos) + (matrix4-mult! m m (projection-matrix camera)))))) + +(define-syntax-rule (with-camera camera body ...) + (with-framebuffer (framebuffer camera) + (with-projection (if (target camera) + (view-matrix camera) + (projection-matrix camera)) + body ...))) + + + +;;; +;;; 2D View +;;; + +;; Views render the output of a camera to a portion of the game +;; window. + +(define-class <view-2d> () + (camera #:accessor camera #:init-keyword #:camera) + (area #:getter area #:init-keyword #:area) + (viewport #:accessor viewport) + (projection-matrix #:accessor projection-matrix) + (sprite-rect #:accessor sprite-rect)) + +(define-method (initialize (view <view-2d>) initargs) + (next-method) + (let* ((area (area view)) + (x (rect-x area)) + (y (rect-y area)) + (w (rect-width area)) + (h (rect-height area))) + (set! (viewport view) + (make-viewport (inexact->exact x) + (inexact->exact y) + (inexact->exact w) + (inexact->exact h))) + (set! (sprite-rect view) (make-rect 0.0 0.0 w h)) + (set! (projection-matrix view) (orthographic-projection 0 w h 0 0 1)))) + +(define %identity-matrix (make-identity-matrix4)) + +(define-method (render (view <view-2d>)) + (with-viewport (viewport view) + (with-projection (projection-matrix view) + (draw-sprite* (framebuffer-texture (framebuffer (camera view))) + (sprite-rect view) + %identity-matrix)))) + + +;;; +;;; 2D Canvas +;;; + +;; The canvas is the root of a 2D scene. It handles rendering one or +;; more views. + +(define (make-default-views) + (match (window-size (window (current-kernel))) + ((width height) + (list + (make <view-2d> + #:camera (make <camera-2d> + #:width width + #:height height) + #:area (make-rect 0 0 width height)))))) + +(define-class <canvas> (<node>) + (views #:accessor views #:init-thunk make-default-views + #:init-keyword #:views)) + +(define-method (update (canvas <canvas>) dt) + (for-each (lambda (view) + (update (camera view) dt)) + (views canvas))) + +(define-method (render-tree (canvas <canvas>) alpha) + ;; Draw scene from the viewpoint of each camera. + (for-each (lambda (view) + (with-camera (camera view) + (for-each (lambda (child) + (render-tree child alpha)) + (children canvas)))) + (views canvas)) + (render canvas alpha)) + +(define-method (render (canvas <canvas>) alpha) + (for-each render (views canvas))) + + +;;; +;;; 2D Scene +;;; + +(define-class <scene-2d> (<scene> <canvas>)) + + +;;; +;;; 2D Game Node +;;; + +(define-class <node-2d> (<node>) + (origin #:getter origin #:init-form #v(0.0 0.0) #:init-keyword #:origin) + (position #:getter position #:init-form #v(0.0 0.0) #:init-keyword #:position) + (rotation #:accessor rotation #:init-form 0.0 #:init-keyword #:rotation) + (scale #:getter scale #:init-form #v(1.0 1.0) #:init-keyword #:scale) + (skew #:getter skew #:init-form #v(0.0 0.0) #:init-keyword #:skew) + ;; Some extra position vectors for defeating "temporal aliasing" + ;; when rendering. + (last-position #:getter last-position #:init-form #v(0.0 0.0)) + (render-position #:getter render-position #:init-form #v(0.0 0.0)) + ;; Lazily computed transformation matrices. + (local-matrix #:getter local-matrix #:init-form (make-identity-matrix4)) + (world-matrix #:getter world-matrix #:init-form (make-identity-matrix4)) + (dirty-matrix? #:accessor dirty-matrix? #:init-form #t)) + +(define-method (dirty! (node <node-2d>)) + (set! (dirty-matrix? node) #t)) + +(define-method (compute-matrices! (node <node-2d>)) + (let ((local (local-matrix node)) + (world (world-matrix node))) + (matrix4-2d-transform! local + #:origin (origin node) + #:position (render-position node) + #:rotation (rotation node) + #:scale (scale node) + #:skew (skew node)) + ;; Compute world matrix by multiplying by the parent node's + ;; matrix, if there is a 2D parent node, that is. + (if (and (parent node) (is-a? (parent node) <node-2d>)) + (matrix4-mult! world local (world-matrix (parent node))) + (begin + (matrix4-identity! world) + (matrix4-mult! world world local))))) + +;; Animation helpers + +(define-method (pivot (node <node-2d>) x y) + "Change origin of NODE to (X, Y)." + (let ((o (origin node))) + (set-vec2-x! o x) + (set-vec2-y! o y) + (dirty! node))) + +(define-method (move-to (node <node-2d>) x y) + (let ((p (position node))) + (set-vec2-x! p x) + (set-vec2-y! p y) + (dirty! node))) + +(define-method (move-to (node <node-2d>) x y duration ease) + (let ((p (position node))) + (move-by node (- x (vec2-x p)) (- y (vec2-y p)) duration ease))) + +(define-method (move-to (node <node-2d>) x y duration) + (move-to node x y duration smoothstep)) + +(define-method (move-by (node <node-2d>) dx dy) + (let ((p (position node))) + (move-to node (+ (vec2-x p) dx) (+ (vec2-y p) dy)))) + +(define-method (move-by (node <node-2d>) dx dy duration ease) + (let* ((p (position node)) + (start-x (vec2-x p)) + (start-y (vec2-y p))) + (tween duration 0.0 1.0 + (lambda (n) + (move-to node + (+ start-x (* dx n)) + (+ start-y (* dy n)))) + #:ease ease))) + +(define-method (move-by (node <node-2d>) dx dy duration) + (move-by node dx dy duration smoothstep)) + +(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-to (node <node-2d>) theta) + (set! (rotation node) theta) + (dirty! node)) + +(define-method (rotate-to (node <node-2d>) theta duration ease) + (tween duration (rotation node) theta + (lambda (r) + (rotate-to node r)) + #:ease ease)) + +(define-method (rotate-to (node <node-2d>) theta duration) + (rotate-to node theta duration smoothstep)) + +(define-method (rotate-by (node <node-2d>) dtheta) + (rotate-to node (+ (rotation node) dtheta))) + +(define-method (rotate-by (node <node-2d>) dtheta duration ease) + (rotate-to node (+ (rotation node) dtheta) duration ease)) + +(define-method (rotate-by (node <node-2d>) dtheta duration) + (rotate-by node dtheta duration smoothstep)) + +(define-method (scale-to (node <node-2d>) sx sy) + (let ((s (scale node))) + (set-vec2-x! s sx) + (set-vec2-y! s sy) + (dirty! node))) + +(define-method (scale-to (node <node-2d>) sx sy duration ease) + (let ((s (scale node))) + (scale-by node (- sx (vec2-x s)) (- sy (vec2-y s)) duration ease))) + +(define-method (scale-to (node <node-2d>) sx sy duration) + (scale-to node sx sy duration smoothstep)) + +(define-method (scale-by (node <node-2d>) dsx dsy) + (let ((s (scale node))) + (scale-to node (+ (vec2-x s) dsx) (+ (vec2-y s) dsy)))) + +(define-method (scale-by (node <node-2d>) dsx dsy duration ease) + (let* ((s (scale node)) + (start-x (vec2-x s)) + (start-y (vec2-y s))) + (tween duration 0.0 1.0 + (lambda (n) + (scale-to node + (+ start-x (* dsx n)) + (+ start-y (* dsy n)))) + #:ease ease))) + +(define-method (scale-by (node <node-2d>) dsx dsy duration) + (scale-by node dsx dsy duration smoothstep)) + +(define-method (follow-bezier-path (node <node-2d>) path duration forward?) + (let ((p (position node)) + (path (if forward? path (reverse path)))) + (for-each (lambda (bezier) + (tween duration + (if forward? 0.0 1.0) + (if forward? 1.0 0.0) + (lambda (t) + (bezier-curve-point-at! p bezier t) + (dirty! node)) + #:ease linear)) + path))) + +(define-method (follow-bezier-path (node <node-2d>) path duration) + (follow-bezier-path node path duration #t)) + +;; Events + +(define-method (update-tree (node <node-2d>) dt) + (vec2-copy! (position node) (last-position node)) + (next-method)) + +(define-method (render-tree (node <node-2d>) alpha) + (when (visible? node) + ;; Compute the linearly interpolated rendering position, in the case + ;; that node has moved since the last update. + (let ((p (position node)) + (lp (last-position node)) + (rp (render-position node)) + (beta (- 1.0 alpha))) + (unless (and (= (vec2-x lp) (vec2-x rp)) + (= (vec2-y lp) (vec2-y rp))) + (set-vec2-x! rp (+ (* (vec2-x p) alpha) (* (vec2-x lp) beta))) + (set-vec2-y! rp (+ (* (vec2-y p) alpha) (* (vec2-y lp) beta))) + (set! (dirty-matrix? node) #t))) + ;; Recompute dirty matrices. + (when (dirty-matrix? node) + (compute-matrices! node) + (set! (dirty-matrix? node) #f) + ;; If the parent is dirty, all the children need to be marked as + ;; dirty, too. + (for-each (lambda (node) + (set! (dirty-matrix? node) #t)) + (children node)))) + (next-method)) + +(define-method (activate (node <node-2d>)) + (set! (dirty-matrix? node) #t) + ;; Set the initial last position to the same as the initial position + ;; to avoid a brief flash where the node appears at (0, 0). + (vec2-copy! (position node) (last-position node)) + (next-method)) + + +;;; +;;; Base Sprite +;;; + +(define-class <base-sprite> (<node-2d>) + (batch #:accessor batch + #:init-keyword #:batch + #:init-form #f) + (tint #:accessor tint + #:init-keyword #:tint + #:init-form white) + (blend-mode #:accessor blend-mode + #:init-keyword #:blend-mode + #:init-form 'alpha)) + +(define-generic texture) + +(define-method (texcoords (sprite <base-sprite>)) + (texture-gl-tex-rect (asset-ref (texture sprite)))) + +(define-method (source-rect (sprite <base-sprite>)) + (texture-gl-rect (asset-ref (texture sprite)))) + +(define-method (render (sprite <base-sprite>) alpha) + (let* ((tex (asset-ref (texture sprite))) + (rect (source-rect sprite)) + (batch (batch sprite)) + (tint (tint sprite)) + (matrix (world-matrix sprite))) + (if batch + (sprite-batch-add* batch rect matrix + #:tint tint + #:texture-region tex) + (draw-sprite* tex rect matrix + #:tint tint + #:texcoords (texcoords sprite))))) + + +;;; +;;; Static Sprite +;;; + +(define-class <sprite> (<base-sprite>) + (texture #:getter texture #:init-keyword #:texture) + (texcoords #:init-keyword #:texcoords #:init-form #f) + (source-rect #:init-keyword #:source-rect #:init-form #f)) + +(define-method (texcoords (sprite <sprite>)) + (or (slot-ref sprite 'texcoords) + (next-method))) + +(define-method (source-rect (sprite <sprite>)) + (or (slot-ref sprite 'source-rect) + (next-method))) + + +;;; +;;; Texture Atlas Sprite +;;; + +(define-class <atlas-sprite> (<base-sprite>) + (atlas #:accessor atlas #:init-keyword #:atlas) + (index #:accessor index #:init-keyword #:index)) + +(define-method (texture (sprite <atlas-sprite>)) + (texture-atlas-ref (asset-ref (atlas sprite)) (index sprite))) + + +;;; +;;; Animated Sprite +;;; + +(define-class <animation> () + (frames #:getter frames #:init-keyword #:frames) + (frame-duration #:getter frame-duration #:init-keyword #:frame-duration + #:init-form 250)) + +(define-class <animated-sprite> (<atlas-sprite>) + (animations #:accessor animations #:init-keyword #:animations) + (current-animation #:accessor current-animation + #:init-keyword #:default-animation + #:init-form 'default) + (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 anim)) + (frames (frames anim)) + (anim-duration (* frame-duration (vector-length frames))) + (time (modulo (- (elapsed-time) (start-time sprite)) anim-duration)) + (frame (vector-ref frames (floor (/ time frame-duration))))) + (set! (index sprite) frame) + (next-method))) + +(define-method (change-animation (sprite <animated-sprite>) name) + (set! (current-animation sprite) name) + (set! (start-time sprite) (elapsed-time))) + + +;;; +;;; Sprite Batch +;;; + +(define-class <sprite-batch> (<node-2d>) + (batch #:accessor batch #:init-keyword #:batch) + (blend-mode #:accessor blend-mode + #:init-keyword #:blend-mode + #:init-form 'alpha) + (clear-after-draw? #:accessor clear-after-draw? + #:init-keyword #:clear-after-draw? + #:init-form #t) + (batch-matrix #:accessor batch-matrix #:init-thunk make-identity-matrix4)) + +(define-method (render (sprite-batch <sprite-batch>) alpha) + (let ((batch (batch sprite-batch))) + (draw-sprite-batch* batch (batch-matrix sprite-batch) + #:blend-mode (blend-mode sprite-batch)) + (when (clear-after-draw? sprite-batch) + (sprite-batch-clear! batch)))) + + +;;; +;;; Filled Rectangle +;;; + +(define-class <filled-rect> (<node-2d>) + (region #:accessor region #:init-keyword #:region) + (color #:accessor color #:init-form black #:init-keyword #:color)) + +(define-method (render (r <filled-rect>) alpha) + (draw-filled-rect (region r) (color r) #:matrix (world-matrix r))) + + +;;; +;;; Text +;;; + +(define-class <label> (<node-2d>) + (font #:accessor font #:init-keyword #:font #:init-thunk default-font) + (text #:accessor text #:init-form "" #:init-keyword #:text)) + +(define-method (render (label <label>) alpha) + (draw-text* (asset-ref (font label)) (text label) (world-matrix label))) + + +;;; +;;; Tiled Map +;;; + +(define-class <tile-map> (<node-2d>) + (tile-map #:accessor tile-map #:init-keyword #:map) + (layers #:accessor layers #:init-keyword #:layers #:init-form #f)) + +(define-method (initialize (node <tile-map>) initargs) + (next-method)) + +(define-method (render (node <tile-map>) alpha) + (let ((m (asset-ref (tile-map node)))) + (draw-tile-map* m (world-matrix node) (tile-map-rect m) + #:layers (layers node)))) + + +;;; +;;; Particles +;;; + +(define-class <particles> (<node-2d>) + (particles #:accessor particles #:init-keyword #:particles)) + +(define-method (update (node <particles>) dt) + (update-particles (particles node))) + +(define-method (render (node <particles>) alpha) + (draw-particles* (particles node) (world-matrix node))) diff --git a/lisparuga/node.scm b/lisparuga/node.scm new file mode 100644 index 0000000..2dbbd41 --- /dev/null +++ b/lisparuga/node.scm @@ -0,0 +1,281 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Base class for all game objects. +;; +;;; Code: + +(define-module (lisparuga node) + #:use-module (chickadee scripting) + #:use-module (oop goops) + #:use-module (lisparuga config) + #:export (<node> + name + rank + parent + children + agenda + booted? + active? + visible? + paused? + on-boot + on-enter + on-exit + reboot + activate + deactivate + show + hide + pause + resume + update + update-tree + render + render-tree + child-ref + & + on-attach + on-detach + attach-to + detach + run-script + stop-scripts + blink) + #:replace (pause)) + +(define-class <node> () + ;; Symbolic name. Used for easy lookup of children within a parent. + (name #:accessor name #:init-form (gensym "anonymous-") #:init-keyword #:name) + ;; An integer value that determines priority order for + ;; updating/rendering. + (rank #:accessor rank #:init-value 0 #:init-keyword #:rank) + ;; The node that this node is attached to. A node may only have one + ;; parent. + (parent #:accessor parent #:init-form #f) + ;; List of children ordered by rank. + (children #:accessor children #:init-form '()) + ;; Children indexed by name for fast lookup. + (children-map #:getter children-map #:init-form (make-hash-table)) + ;; Script scheduler. + (agenda #:getter agenda #:init-form (make-agenda)) + ;; Flips to #t upon first entering a scene. + (booted? #:accessor booted? #:init-form #f) + ;; Flips to #t when node is part of current scene. + (active? #:accessor active? #:init-form #f) + ;; Determines whether or not the node and all of its children are + ;; rendered. + (visible? #:accessor visible? #:init-form #t #:init-keyword #:visible?) + ;; Determines whether or not updates happen. + (paused? #:accessor paused? #:init-form #f #:init-keyword #:paused?) + ;; Use redefinable classes when in dev mode. + #:metaclass (if developer-mode? + <redefinable-class> + <class>)) + +(define (for-each-child proc node) + (for-each proc (children node))) + + +;;; +;;; Life cycle event handlers +;;; + +(define-method (update (node <node>) dt) + "Advance simulation of NODE by the time delta DT." + #t) + +(define-method (update-tree (node <node>) dt) + "Update NODE and all of its children. DT is the amount of time +passed since the last update, in milliseconds." + (unless (paused? node) + ;; Update children first, recursively. + (for-each-child (lambda (child) (update-tree child dt)) node) + ;; Scripts take precedence over the update method. + (with-agenda (agenda node) + (update-agenda 1) + (update node dt)))) + +(define-method (render (node <node>) alpha) + "Render NODE. ALPHA is the distance between the previous update and +the next update represented as a ratio in the range [0, 1]." + #t) + +(define-method (render-tree (node <node>) alpha) + "Render NODE and all of its children, recursively. +ALPHA is the distance between the previous update and the next update +represented as a ratio in the range [0, 1]." + (when (visible? node) + (render node alpha) + (for-each-child (lambda (child) (render-tree child alpha)) node))) + +(define-method (on-boot (node <node>)) + "Perform initialization tasks for NODE." + #t) + +(define-method (on-enter (node <node>)) + "Perform task now that NODE has entered the current scene." + #t) + +(define-method (on-exit (node <node>)) + "Perform task now that NODE has left the current scene." + #t) + + +;;; +;;; Life cycle state management +;;; + +(define-method (boot (node <node>)) + "Prepare NODE to enter the game world for the first time." + (set! (booted? node) #t) + (on-boot node)) + +(define-method (reboot (node <node>)) + (define (do-reboot) + (for-each detach (children node)) + (with-agenda (agenda node) (reset-agenda)) + (on-boot node)) + (cond + ;; Never booted before, so do nothing. + ((not (booted? node)) + #t) + ;; Currently active, so reactivate after reboot. + ((active? node) + (do-reboot) + (activate node)) + ;; Not active. + (else + (do-reboot)))) + +(define-method (activate (node <node>)) + "Mark NODE and all of its children as active." + ;; First time activating? We must boot! + (unless (booted? node) (boot node)) + (set! (active? node) #t) + (on-enter node) + (for-each-child activate node)) + +(define-method (deactivate (node <node>)) + "Mark NODE and all of its children as inactive." + (set! (active? node) #f) + (on-exit node) + (for-each-child deactivate node)) + +(define-method (show (node <node>)) + "Mark NODE as visible." + (set! (visible? node) #t)) + +(define-method (hide (node <node>)) + "Mark NODE as invisible." + (set! (visible? node) #f)) + +(define-method (pause (node <node>)) + (set! (paused? node) #t)) + +(define-method (resume (node <node>)) + (set! (paused? node) #f)) + + +;;; +;;; Child management +;;; + +(define-method (child-ref (parent <node>) name) + "Return the child node of PARENT whose name is NAME." + (hashq-ref (children-map parent) name)) + +(define-syntax & + (syntax-rules () + ((_ parent child-name) + (child-ref parent 'child-name)) + ((_ parent child-name . rest) + (& (child-ref parent 'child-name) . rest)))) + +(define-method (on-attach (parent <node>) (child <node>)) + #t) + +(define-method (on-detach (parent <node>) (child <node>)) + #t) + +(define-method (attach-to (new-parent <node>) . new-children) + "Attach NEW-CHILDREN to NEW-PARENT." + ;; Validate all children first. The whole operation will fail if + ;; any of them cannot be attached. + (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) + ;; Adopt the children and sort them by their rank so that + ;; updating/rendering happens in the desired order. + (set! (children new-parent) + (sort (append new-children (children new-parent)) + (lambda (a b) + (< (rank a) (rank b))))) + ;; Mark the children as having parents and add them to the name + ;; index for quick lookup later. + (for-each (lambda (child) + (set! (parent child) new-parent) + (hashq-set! (children-map new-parent) (name child) child) + ;; If the parent is active, that means the new children + ;; must also be active. + (when (active? new-parent) + (activate child))) + new-children) + ;; Notify parent of attach event. + (for-each (lambda (child) + (on-attach new-parent child)) + new-children)) + +(define-method (detach (node <node>)) + "Detach NODE from its parent." + (let ((p (parent node))) + (when p + (set! (children p) (delq node (children p))) + (hashq-remove! (children-map p) (name node)) + ;; Detaching deactives the node and all of its children. + (when (active? node) + (deactivate node)) + (set! (parent node) #f) + (on-detach p node)))) + +(define-method (detach . nodes) + "Detach all NODES from their respective parents." + (for-each detach nodes)) + + +;;; +;;; Scripting +;;; + +(define-syntax-rule (run-script node body ...) + (with-agenda (agenda node) (script body ...))) + +(define-method (stop-scripts node) + (with-agenda (agenda node) (clear-agenda))) + +(define-method (blink (node <node>) times interval) + (let loop ((i 0)) + (when (< i times) + (set! (visible? node) #f) + (sleep interval) + (set! (visible? node) #t) + (sleep interval) + (loop (+ i 1))))) diff --git a/lisparuga/repl.scm b/lisparuga/repl.scm new file mode 100644 index 0000000..8951793 --- /dev/null +++ b/lisparuga/repl.scm @@ -0,0 +1,99 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; REPL for live hacking and debugging. +;; +;;; Code: + +(define-module (lisparuga repl) + #:use-module (oop goops) + #:use-module (ice-9 match) + #:use-module (lisparuga node) + #:use-module (system repl coop-server) + #:use-module (system repl debug) + #:use-module (system repl repl) + #:export (<repl> + repl-server + repl-debug + repl-debugging? + on-error + debugger)) + +(define-class <repl> (<node>) + (repl-server #:accessor repl-server) + (repl-debug #:accessor repl-debug #:init-form #f) + (repl-debugging? #:accessor repl-debugging? #:init-form #f)) + +(define-method (on-boot (repl <repl>)) + (set! (repl-server repl) (spawn-coop-repl-server))) + +(define-method (on-error (repl <repl>) stack key args) + ;; Display backtrace. + (let ((port (current-error-port))) + (display "an error has occurred!\n\n" port) + (display "Backtrace:\n" port) + (display-backtrace stack port) + (newline port) + (match args + ((subr message . args) + (display-error (stack-ref stack 0) port subr message args '()))) + (newline port)) + ;; Setup the REPL debug object. + (let* ((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) + )) + (error-string (call-with-output-string + (lambda (port) + (let ((frame (and (< 0 (vector-length stack)) + (vector-ref stack 0)))) + (print-exception port frame key args)))))) + (set! (repl-debug repl) (make-debug stack 0 error-string)) + (set! (repl-debugging? repl) #t) + ;; Wait for the user to exit the debugger. + (display "waiting for developer to debug..." (current-error-port)) + (while (repl-debugging? repl) + (poll-coop-repl-server (repl-server repl)) + (usleep 160000) + #t) + (set! (repl-debug repl) #f) + (display " done!\n"))) + +(define-method (update (repl <repl>) dt) + (poll-coop-repl-server (repl-server repl))) + +(define-method (debugger (repl <repl>)) + (if (repl-debug repl) + (begin + (format #t "~a~%" (debug-error-message (repl-debug repl))) + (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 repl)) + (set! (repl-debugging? repl) #f)) + (display "nothing to debug!\n"))) diff --git a/lisparuga/scene.scm b/lisparuga/scene.scm new file mode 100644 index 0000000..04874f2 --- /dev/null +++ b/lisparuga/scene.scm @@ -0,0 +1,198 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Scenes are the main state machine abstraction. A scene represents +;; a distinct portion of a game: main menu, overworld map, inventory +;; screen, etc. The kernel tracks the currently active scene. +;; +;;; Code: + +(define-module (lisparuga scene) + #:use-module (chickadee) + #:use-module (chickadee audio) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (lisparuga node) + #:export (<scene> + background-music + background-music-volume + background-music-loop? + on-quit + on-key-press + on-key-release + on-text-input + on-mouse-press + on-mouse-release + on-mouse-move + on-controller-add + on-controller-remove + on-controller-press + on-controller-release + on-controller-move + + <scene-mux> + current-scene + previous-scene + push-scene + replace-scene + pop-scene + on-scenes-empty)) + +(define-class <scene> (<node>) + (background-music-source #:getter background-music-source + #:init-form (make-source #:loop? #t)) + (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>)) + (when (audio? (background-music scene)) + (set-source-volume! (background-music-source scene) + (background-music-volume scene)) + (set-source-audio! (background-music-source scene) + (background-music scene)) + (source-play (background-music-source scene)))) + +(define-method (on-exit (scene <scene>)) + (source-stop (background-music-source scene))) + +;; Input event handler methods +(define-method (on-quit (scene <scene>)) + (abort-game)) + +(define-method (on-key-press (scene <scene>) key scancode modifiers repeat?) + #t) + +(define-method (on-key-release (scene <scene>) key scancode modifiers) + #t) + +(define-method (on-text-input (scene <scene>) text) + #t) + +(define-method (on-mouse-press (scene <scene>) button clicks x y) + #t) + +(define-method (on-mouse-release (scene <scene>) button x y) + #t) + +(define-method (on-mouse-move (scene <scene>) x y x-rel y-rel buttons) + #t) + +(define-method (on-controller-add (scene <scene>) controller) + #t) + +(define-method (on-controller-remove (scene <scene>) controller) + #t) + +(define-method (on-controller-press (scene <scene>) controller button) + #t) + +(define-method (on-controller-release (scene <scene>) controller button) + #t) + +(define-method (on-controller-move (scene <scene>) controller axis value) + #t) + + +;;; +;;; Scene Multiplexer +;;; + +(define-class <scene-mux> (<node>) + (scenes #:accessor scenes #:init-form '())) + +(define-method (current-scene (mux <scene-mux>)) + (match (scenes mux) + ((s . _) s) + (() #f))) + +(define-method (previous-scene (mux <scene-mux>)) + (match (scenes mux) + ((_ s . _) s) + (_ #f))) + +(define-method (push-scene (mux <scene-mux>) (scene <scene>)) + (let ((old (current-scene mux))) + (set! (scenes mux) (cons scene (scenes mux))) + (when old (detach old)) + (attach-to mux scene))) + +(define-method (replace-scene (mux <scene-mux>) (scene <scene>)) + (match (scenes mux) + ((old . rest) + (set! (scenes mux) (cons scene rest)) + (detach old) + (attach-to mux scene)) + (() + (error "no scene to replace!" mux)))) + +(define-method (pop-scene (mux <scene-mux>)) + (match (scenes mux) + ((old) + (set! (scenes mux) '()) + (detach old) + (on-scenes-empty mux)) + ((and (old new . _) + (_ . rest)) + (set! (scenes mux) rest) + (detach old) + (attach-to mux new)) + (() + (error "no scene to pop!" mux)))) + +(define-method (on-scenes-empty (mux <scene-mux>)) + #t) + +(define-method (on-quit (mux <scene-mux>)) + (on-quit (current-scene mux))) + +(define-method (on-key-press (mux <scene-mux>) key scancode modifiers repeat?) + (on-key-press (current-scene mux) key scancode modifiers repeat?)) + +(define-method (on-key-release (mux <scene-mux>) key scancode modifiers) + (on-key-release (current-scene mux) key scancode modifiers)) + +(define-method (on-text-input (mux <scene-mux>) text) + (on-text-input (current-scene mux) text)) + +(define-method (on-mouse-press (mux <scene-mux>) button clicks x y) + (on-mouse-press (current-scene mux) button clicks x y)) + +(define-method (on-mouse-release (mux <scene-mux>) button x y) + (on-mouse-release (current-scene mux) button x y)) + +(define-method (on-mouse-move (mux <scene-mux>) x y x-rel y-rel buttons) + (on-mouse-move (current-scene mux) x y x-rel y-rel buttons)) + +(define-method (on-controller-add (mux <scene-mux>) controller) + (on-controller-add (current-scene mux) controller)) + +(define-method (on-controller-remove (mux <scene-mux>) controller) + (on-controller-remove (current-scene mux) controller)) + +(define-method (on-controller-press (mux <scene-mux>) controller button) + (on-controller-press (current-scene mux) controller button)) + +(define-method (on-controller-release (mux <scene-mux>) controller button) + (on-controller-release (current-scene mux) controller button)) + +(define-method (on-controller-move (mux <scene-mux>) controller axis value) + (on-controller-move (current-scene mux) controller axis value)) diff --git a/lisparuga/transition.scm b/lisparuga/transition.scm new file mode 100644 index 0000000..9129372 --- /dev/null +++ b/lisparuga/transition.scm @@ -0,0 +1,128 @@ +;;; Lisparuga +;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu> +;;; +;;; Lisparuga 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. +;;; +;;; Lisparuga 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 Lisparuga. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Scene transitions. +;; +;;; Code: + +(define-module (lisparuga transition) + #:use-module (chickadee math rect) + #:use-module ((chickadee render color) #:select (make-color)) + #:use-module (chickadee scripting) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (lisparuga kernel) + #:use-module (lisparuga node) + #:use-module (lisparuga node-2d) + #:use-module (lisparuga scene) + #:export (<sequence-scene> + scenes + last-scene + transition + + <transition> + scene-from + scene-to + duration + + <fade-transition>)) + + +;;; +;;; Sequence +;;; + +;; Not a transition like all the others, but still a form of +;; transitioning scenes. + +(define-class <sequence-scene> (<scene>) + (scenes #:accessor scenes #:init-keyword #:scenes) + (last-scene #:accessor last-scene #:init-form #f) + (transition #:accessor transition #:init-keyword #:transition + #:init-form default-sequence-transition)) + +(define (default-sequence-transition from to) + ;; Return the 'to' scene as-is, which means there is no transition + ;; at all. + to) + +(define-method (on-enter (sequence <sequence-scene>)) + (define (next-scene-transition scene) + (let ((last (last-scene sequence))) + (if last + ((transition sequence) last scene) + scene))) + (match (scenes sequence) + ((scene) + ;; If we've reached the last scene, we're done! + (replace-scene (next-scene-transition scene))) + ((scene . rest) + (let ((next-scene (next-scene-transition scene))) + (set! (scenes sequence) rest) + (set! (last-scene sequence) scene) + (push-scene next-scene))))) + + +;;; +;;; Transitions +;;; + +(define-class <transition> (<scene>) + (scene-from #:getter scene-from #:init-keyword #:from + #:init-thunk current-scene) + (scene-to #:getter scene-to #:init-keyword #:to + #:init-thunk previous-scene) + (duration #:getter duration #:init-keyword #:duration)) + +(define-generic do-transition) + +(define-method (on-boot (transition <transition>)) + (attach-to transition (make <canvas> #:name 'canvas))) + +(define-method (on-enter (transition <transition>)) + (script + (attach-to (& transition canvas) + (scene-from transition) + (scene-to transition)) + (do-transition transition) + (detach (scene-from transition)) + (detach (scene-to transition)) + (replace-scene (scene-to transition)))) + +(define-class <fade-transition> (<transition>)) + +(define-method (on-boot (fade <fade-transition>)) + (next-method) + (attach-to (& fade canvas) + (make <filled-rect> + #:name 'rect + #:region (make-rect 0.0 0.0 640.0 480.0) + #:rank 9999))) + +(define-method (do-transition (fade <fade-transition>)) + (let ((half-duration (inexact->exact (round (/ (duration fade) 2)))) + (rect (& fade canvas rect))) + (define (set-alpha! alpha) + (set! (color rect) (make-color 0 0 0 alpha))) + (hide (scene-to fade)) + (show (scene-from fade)) + (tween half-duration 0.0 1.0 set-alpha!) + (hide (scene-from fade)) + (show (scene-to fade)) + (tween half-duration 1.0 0.0 set-alpha!) + (show (scene-from fade)))) |