diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Makefile.am | 40 | ||||
| -rw-r--r-- | catbird/asset.scm | 241 | ||||
| -rw-r--r-- | catbird/cached-slots.scm | 88 | ||||
| -rw-r--r-- | catbird/camera.scm | 113 | ||||
| -rw-r--r-- | catbird/config.scm | 16 | ||||
| -rw-r--r-- | catbird/inotify.scm | 197 | ||||
| -rw-r--r-- | catbird/input-map.scm | 175 | ||||
| -rw-r--r-- | catbird/kernel.scm | 394 | ||||
| -rw-r--r-- | catbird/line-editor.scm | 312 | ||||
| -rw-r--r-- | catbird/minibuffer.scm | 157 | ||||
| -rw-r--r-- | catbird/mixins.scm | 195 | ||||
| -rw-r--r-- | catbird/mode.scm | 105 | ||||
| -rw-r--r-- | catbird/node-2d.scm | 939 | ||||
| -rw-r--r-- | catbird/node.scm | 160 | ||||
| -rw-r--r-- | catbird/observer.scm | 37 | ||||
| -rw-r--r-- | catbird/overlay.scm | 116 | ||||
| -rw-r--r-- | catbird/region.scm | 102 | ||||
| -rw-r--r-- | catbird/repl.scm | 349 | ||||
| -rw-r--r-- | catbird/ring-buffer.scm | 64 | ||||
| -rw-r--r-- | catbird/scene.scm | 147 | ||||
| -rw-r--r-- | configure.ac | 1 | ||||
| -rw-r--r-- | guix.scm | 4 | ||||
| -rw-r--r-- | pre-inst-env.in | 1 | ||||
| -rw-r--r-- | test-env.in | 5 | ||||
| -rw-r--r-- | tests/node.scm | 7 | ||||
| -rw-r--r-- | tests/scene.scm | 7 | ||||
| -rw-r--r-- | tests/utils.scm | 9 |
28 files changed, 3965 insertions, 17 deletions
@@ -9,3 +9,4 @@ /autom4te.cache/ /build-aux/ /Makefile +/test-env diff --git a/Makefile.am b/Makefile.am index 22c997f..2769022 100644 --- a/Makefile.am +++ b/Makefile.am @@ -38,20 +38,32 @@ moddir=$(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION) godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache SOURCES = \ - starling/config.scm \ - starling/ring-buffer.scm \ - starling/inotify.scm \ - starling/system.scm \ - starling/asset.scm \ - starling/node.scm \ - starling/scene.scm \ - starling/repl-server.scm \ - starling/repl.scm \ - starling/minibuffer.scm \ - starling/kernel.scm \ - starling/node-2d.scm \ - starling/gui.scm \ - starling/transition.scm + catbird/config.scm \ + catbird/inotify.scm \ + catbird/ring-buffer.scm \ + catbird/mixins.scm \ + catbird/cached-slots.scm \ + catbird/observer.scm \ + catbird/asset.scm \ + catbird/input-map.scm \ + catbird/mode.scm \ + catbird/camera.scm \ + catbird/node.scm \ + catbird/node-2d.scm \ + catbird/scene.scm \ + catbird/region.scm \ + catbird/kernel.scm \ + catbird/line-editor.scm \ + catbird/minibuffer.scm \ + catbird/repl.scm \ + catbird/overlay.scm + +TESTS = \ + tests/node.scm \ + tests/scene.scm + +TEST_EXTENSIONS = .scm +SCM_LOG_COMPILER = $(top_builddir)/test-env $(GUILE) EXTRA_DIST += \ COPYING diff --git a/catbird/asset.scm b/catbird/asset.scm new file mode 100644 index 0000000..a53048f --- /dev/null +++ b/catbird/asset.scm @@ -0,0 +1,241 @@ +(define-module (catbird asset) + #:use-module (catbird config) + #:use-module (catbird inotify) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:export (<asset> + file-names + loader + artifact + subscribers + load! + ->asset + subscribe + unsubscribe + on-asset-refresh + define-asset + reload-modified-assets + + <asset-container>)) + +(define (absolute-file-name file-name) + (if (absolute-file-name? file-name) + file-name + (string-append (getcwd) "/" file-name))) + + +;;; +;;; Base Asset +;;; + +(define-root-class <asset> () + (file-names #:getter file-names #:init-keyword #:file-names) + (loader #:getter loader #:init-keyword #:loader) + (artifact #:accessor %artifact #:init-value #f) + (subscribers #:getter subscribers #:init-form (make-weak-key-hash-table))) + +(define-method (initialize (asset <asset>) initargs) + (next-method) + ;; Convert relative file names to absolute file names for + ;; consistency and ease of use later. + (slot-set! asset 'file-names (map absolute-file-name (file-names asset)))) + +;; Allow any object to be wrapped in an asset. +(define-method (->asset x) + (make <asset> + #:file-names '() + #:loader (lambda () x))) + +(define-method (->asset (asset <asset>)) + asset) + +(define-method (subscribe (asset <asset>) obj context) + (let ((subs (subscribers asset))) + (hashq-set! subs obj (cons context (hashq-ref subs obj '()))))) + +(define-method (unsubscribe (asset <asset>) obj context) + (let* ((subs (subscribers asset)) + (contexts (delq context (hashq-ref subs obj '())))) + (if (null? contexts) + (hashq-remove! subs obj) + (hashq-set! subs obj contexts)))) + +(define-method (on-asset-refresh obj context) + #t) + +(define-method (notify-refresh (asset <asset>)) + (hash-for-each (lambda (subscriber contexts) + (for-each (lambda (context) + (on-asset-refresh subscriber context)) + contexts)) + (subscribers asset))) + +(define-method (load! (asset <asset>)) + (let ((value (apply (loader asset) (file-names asset)))) + (set! (%artifact asset) value) + (notify-refresh asset) + value)) + +(define-method (reload! (asset <asset>)) + (load! asset)) + +(define-method (unload! (asset <asset>)) + (set! (%artifact asset) #f)) + +(define-method (artifact (asset <asset>)) + (or (%artifact asset) + (load! asset))) + + +;;; +;;; Auto-reloading Asset +;;; + +(define-class <auto-reload-asset> (<asset>) + ;; Do not create inotify handle until it is needed. + (inotify #:allocation #:class #:init-form (delay (make-inotify))) + ;; List of all auto-reloadable assets stored as a weak key hash + ;; table + (assets #:allocation #:class #:init-thunk make-weak-key-hash-table)) + +(define (asset-inotify) + (force (class-slot-ref <auto-reload-asset> 'inotify))) + +(define (auto-reload-assets) + (class-slot-ref <auto-reload-asset> 'assets)) + +(define (register-auto-reload-asset! asset) + (hashq-set! (auto-reload-assets) asset #t)) + +(define-method (load! (asset <auto-reload-asset>)) + ;; These are both no-ops if the asset and file are already being + ;; watched. + (register-auto-reload-asset! asset) + (for-each (lambda (file-name) + (inotify-add-watch! (asset-inotify) file-name '(close-write))) + (file-names asset)) + (next-method)) + +(define (assets-for-event event) + (let ((f (inotify-watch-file-name (inotify-event-watch event)))) + (hash-fold (lambda (asset dummy-value memo) + (if (member f (file-names asset)) + (cons asset memo) + memo)) + '() + (auto-reload-assets)))) + +;; Needs to be called periodically in the game loop to reload modified +;; assets. +(define (reload-modified-assets) + "Reload all assets whose files have been modified." + (let ((inotify (asset-inotify))) + (while (inotify-pending-events? inotify) + (let* ((event (inotify-read-event inotify)) + (assets (assets-for-event event))) + (if (null? assets) + ;; There are no assets associated with this file anymore + ;; (they've been redefined with new file names or GC'd), + ;; so remove the watch. + (inotify-watch-remove! (inotify-event-watch event)) + ;; Reload all assets associated with the file. + (for-each reload! assets)))))) + + +;;; +;;; Syntax +;;; + +(define-syntax-rule (define-asset name ((var file-name) ...) body ...) + (define name + (let ((file-names (list file-name ...)) + (proc (lambda (var ...) body ...))) + (if (and (defined? 'name) (is-a? name <asset>)) + (begin + (initialize name + #:file-names file-names + #:loader proc) + name) + (make (if developer-mode? <auto-reload-asset> <asset>) + #:file-names file-names + #:loader proc))))) + + +;;; +;;; Asset Metaclass +;;; + +(define-class <asset-slot-class> (<catbird-metaclass>)) + +(define-method (asset-slot? (slot <slot>)) + (get-keyword #:asset? (slot-definition-options slot))) + +(define (slot-ref* obj slot-name) + (and (slot-bound? obj slot-name) + (slot-ref obj slot-name))) + +(define-method (compute-getter-method (class <asset-slot-class>) slot) + (if (asset-slot? slot) + ;; Wrap the original getter procedure with a new procedure that + ;; extracts the current value from the asset object. + (make <method> + #:specializers (list class) + #:procedure (let ((slot-name (slot-definition-name slot)) + (proc (method-procedure (next-method)))) + (lambda (obj) + (artifact (proc obj))))) + (next-method))) + +(define-method (compute-setter-method (class <asset-slot-class>) slot) + (if (asset-slot? slot) + ;; Wrap the original setter procedure with a new procedure that + ;; manages asset update notifications. + (make <method> + #:specializers (list class <top>) + #:procedure (let ((slot-name (slot-definition-name slot)) + (proc (method-procedure (next-method)))) + (lambda (obj new) + (let ((old (slot-ref* obj slot-name)) + (new* (->asset new))) + (unless (eq? old new) + (when old + (unsubscribe old obj slot-name)) + (subscribe new* obj slot-name) + (proc obj new*)))))) + (next-method))) + +(define (map-initargs proc initargs) + (let loop ((initargs initargs)) + (match initargs + (() '()) + ((slot-name value . rest) + (cons* slot-name (proc slot-name value) (loop rest)))))) + +(define (for-each-initarg proc initargs) + (let loop ((initargs initargs)) + (match initargs + (() '()) + ((slot-name value . rest) + (proc slot-name value) + (loop rest))))) + +(define (coerce-asset obj slot-name) + (let ((value (slot-ref* obj slot-name))) + (if (is-a? value <asset>) + value + (let ((asset (->asset value))) + (slot-set! obj slot-name asset) + asset)))) + +(define-class <asset-container> () + #:metaclass <asset-slot-class>) + +(define-method (initialize (instance <asset-container>) initargs) + (next-method) + ;; Subscribe for updates to all asset slots. + (for-each (lambda (slot) + (when (asset-slot? slot) + (let* ((slot-name (slot-definition-name slot)) + (value (coerce-asset instance slot-name))) + (subscribe value instance slot-name)))) + (class-slots (class-of instance)))) diff --git a/catbird/cached-slots.scm b/catbird/cached-slots.scm new file mode 100644 index 0000000..be77103 --- /dev/null +++ b/catbird/cached-slots.scm @@ -0,0 +1,88 @@ +(define-module (catbird cached-slots) + #:use-module (catbird config) + #:use-module (oop goops) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:export (<cacheable> + slot-expired? + expire-slot!)) + +(define-record-type <cached-value> + (%make-cached-value value expired? proc) + cached-value? + (value %cached-value-ref set-cached-value!) + (expired? cached-value-expired? set-cached-value-expired!) + (proc cached-value-proc)) + +(define (make-cached-value init proc) + (%make-cached-value init #t proc)) + +(define (refresh-cached-value! cache) + (let ((x ((cached-value-proc cache) (%cached-value-ref cache)))) + (set-cached-value! cache x) + (set-cached-value-expired! cache #f))) + +(define (cached-value-ref cache) + (when (cached-value-expired? cache) + (refresh-cached-value! cache)) + (%cached-value-ref cache)) + +(define (expire-cached-value! cache) + (set-cached-value-expired! cache #t)) + +(define (expire-slot! obj slot-name) + (expire-cached-value! (slot-ref obj slot-name))) + +(define (slot-expired? obj slot-name) + (cached-value-expired? (slot-ref obj slot-name))) + +(define-class <cached-slot-class> (<catbird-metaclass>)) + +(define (slot-ref* obj slot-name) + (and (slot-bound? obj slot-name) + (slot-ref obj slot-name))) + +(define-method (cached-slot? (slot <slot>)) + (get-keyword #:cached? (slot-definition-options slot))) + +(define-method (slot-refresh-proc (slot <slot>)) + (get-keyword #:refresh (slot-definition-options slot))) + +(define-method (compute-getter-method (class <cached-slot-class>) slot) + (if (cached-slot? slot) + ;; Wrap the original getter procedure with a new procedure that + ;; extracts the current value from the cached value, recomputing + ;; it if necessary. + (make <method> + #:specializers (list class) + #:procedure (let ((proc (method-procedure (next-method)))) + (lambda (obj) + (cached-value-ref (proc obj))))) + (next-method))) + +(define-method (compute-setter-method (class <cached-slot-class>) slot) + (if (cached-slot? slot) + (make <method> + #:specializers (list class <top>) + #:procedure (lambda (obj new) + (raise-exception + (make-exception-with-message "cached slots cannot be set")))) + (next-method))) + +(define-class <cacheable> () + #:metaclass <cached-slot-class>) + +(define-method (initialize (instance <cacheable>) initargs) + (next-method) + ;; Setup cached values. + (for-each (lambda (slot) + (when (cached-slot? slot) + (let* ((slot-name (slot-definition-name slot)) + (refresh-proc (slot-refresh-proc slot)) + (cached-value (make-cached-value + (slot-ref* instance slot-name) + (lambda (prev) + (refresh-proc instance prev))))) + (slot-set! instance slot-name cached-value)))) + (class-slots (class-of instance)))) diff --git a/catbird/camera.scm b/catbird/camera.scm new file mode 100644 index 0000000..ad7425c --- /dev/null +++ b/catbird/camera.scm @@ -0,0 +1,113 @@ +(define-module (catbird camera) + #:use-module (catbird config) + #:use-module (catbird mixins) + #:use-module (chickadee math) + #:use-module (chickadee math matrix) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (oop goops) + #:export (<camera> + projection-matrix + view-matrix + width + height + current-camera + + <camera-2d> + view-bounding-box + move-to + move-by + + <camera-3d> + field-of-vision + near-clip + far-clip + direction + up)) + +(define-root-class <camera> () + (width #:accessor width #:init-keyword #:width) + (height #:accessor height #:init-keyword #:height) + (projection-matrix #:getter projection-matrix #:init-thunk make-identity-matrix4) + (view-matrix #:getter view-matrix #:init-thunk make-identity-matrix4)) + +(define-generic refresh-projection) +(define-generic refresh-view) + +(define-method (initialize (camera <camera>) args) + (next-method) + (refresh-projection camera) + (refresh-view camera)) + +(define current-camera (make-parameter #f)) + + +;;; +;;; 2D Camera +;;; + +(define-class <camera-2d> (<camera> <movable-2d>) + (view-bounding-box #:accessor view-bounding-box #:init-thunk make-null-rect)) + +(define-method (initialize (camera <camera-2d>) initargs) + (next-method) + (let ((bb (view-bounding-box camera))) + (set-rect-width! bb (width camera)) + (set-rect-height! bb (height camera)))) + +(define-method (refresh-projection (camera <camera-2d>)) + (orthographic-projection! (projection-matrix camera) + 0.0 (width camera) + (height camera) 0.0 + 0.0 1.0)) + +(define-method (refresh-view (camera <camera-2d>)) + (let ((p (position camera)) + (bb (view-bounding-box camera))) + (matrix4-translate! (view-matrix camera) p) + (set-rect-x! bb (vec2-x p)) + (set-rect-y! bb (vec2-y p)))) + +(define-method (move-to (camera <camera-2d>) p) + (vec2-copy! p (position camera)) + (refresh-view camera)) + +(define-method (move-by (camera <camera-2d>) d) + (vec2-add! (position camera) d) + (refresh-view camera)) + + +;;; +;;; 3D Camera +;;; + +(define-class <camera-3d> (<camera> <movable-3d>) + (field-of-vision #:getter field-of-vision #:init-keyword #:field-of-vision + #:init-value (degrees->radians 60)) + (near-clip #:getter near-clip #:init-keyword #:near-clip #:init-value 0.1) + (far-clip #:getter far-clip #:init-keyword #:far-clip #:init-value 5.0) + (direction #:getter direction #:init-keyword #:direction + #:init-form (vec3 0.0 0.0 -1.0)) + (up #:getter up #:init-keyword #:up + #:init-form (vec3 0.0 1.0 0.0))) + +(define-method (refresh-projection (camera <camera-3d>)) + (perspective-projection! (projection-matrix camera) + (field-of-vision camera) + (/ (width camera) (height camera)) + (near-clip camera) + (far-clip camera))) + +(define-method (refresh-view (camera <camera-3d>)) + (look-at! (view-matrix camera) + (position camera) + (direction camera) + (up camera))) + +(define-method (move-to (camera <camera-3d>) p) + (vec3-copy! p (position camera)) + (refresh-view camera)) + +(define-method (move-by (camera <camera-3d>) d) + (vec3-add! (position camera) d) + (refresh-view camera)) diff --git a/catbird/config.scm b/catbird/config.scm new file mode 100644 index 0000000..a010bc1 --- /dev/null +++ b/catbird/config.scm @@ -0,0 +1,16 @@ +(define-module (catbird config) + #:use-module (oop goops) + #:export (developer-mode? + <catbird-metaclass> + define-root-class)) + +(define developer-mode? + (equal? (getenv "CATBIRD_DEV_MODE") "1")) + +(define <catbird-metaclass> + (if developer-mode? <redefinable-class> <class>)) + +(define-syntax-rule (define-root-class name (supers ...) args ...) + (define-class name (supers ...) + args ... + #:metaclass <catbird-metaclass>)) diff --git a/catbird/inotify.scm b/catbird/inotify.scm new file mode 100644 index 0000000..28a92b5 --- /dev/null +++ b/catbird/inotify.scm @@ -0,0 +1,197 @@ +(define-module (catbird 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* ((watches (inotify-watches inotify)) + (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))))) + (or (hashv-ref watches wd) + (let ((new-watch (make-inotify-watch wd abs-file-name inotify))) + (hashv-set! watches wd new-watch) + new-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/catbird/input-map.scm b/catbird/input-map.scm new file mode 100644 index 0000000..43ba57a --- /dev/null +++ b/catbird/input-map.scm @@ -0,0 +1,175 @@ +(define-module (catbird input-map) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (make-input-map + add-input + remove-input + key-press + key-release + text-input + mouse-press + mouse-release + mouse-move + mouse-wheel + controller-press + controller-release + controller-move + key-press-handler + key-release-handler + text-input-handler + mouse-press-handler + mouse-release-handler + mouse-move-handler + mouse-wheel-handler + controller-press-handler + controller-release-handler + controller-move-handler)) + +(define (make-input-map) + '()) + +(define (add-input input-map spec handler) + (cons (cons spec handler) + input-map)) + +(define (remove-input input-map spec) + (delete spec input-map + (match-lambda + ((s . _) (equal? s spec))))) + +(define* (key-press key #:optional (modifiers '())) + `(keyboard ,key ,modifiers down)) + +(define* (key-release key #:optional (modifiers '())) + `(keyboard ,key ,modifiers up)) + +(define (text-input) + '(text-input)) + +(define (mouse-press button) + `(mouse button ,button down)) + +(define (mouse-release button) + `(mouse button ,button up)) + +(define* (mouse-move #:optional (buttons '())) + `(mouse move ,buttons)) + +(define* (mouse-wheel) + '(mouse wheel)) + +(define (controller-press id button) + `(controller button ,id ,button down)) + +(define (controller-release id button) + `(controller button ,id ,button up)) + +(define (controller-move id axis) + `(controller axis ,id ,axis)) + +;; Chickadee is specific about which modifier keys are pressed and +;; makes distinctions between left and right ctrl, for example. For +;; convenience, we want users to be able to specify simply 'ctrl' and +;; it will match both left and right. +(define (modifiers-match? spec-modifiers modifiers) + (every (lambda (k) + (case k + ;; The specification is looking for a specific modifier + ;; key. + ((left-ctrl right-ctrl left-alt right-alt left-shift right-shift) + (memq k modifiers)) + ;; The specification is looking for either left/right + ;; modifier key. + ((ctrl) + (or (memq 'left-control modifiers) + (memq 'right-control modifiers))) + ((alt) + (or (memq 'left-alt modifiers) + (memq 'right-alt modifiers))) + ((shift) + (or (memq 'left-shift modifiers) + (memq 'right-shift modifiers))))) + spec-modifiers)) + +(define (key-press-handler input-map key modifiers) + (any (match-lambda + ((('keyboard key* modifiers* 'down) . handler) + (and (eq? key key*) + (modifiers-match? modifiers* modifiers) + handler)) + (_ #f)) + input-map)) + +(define (key-release-handler input-map key modifiers) + (any (match-lambda + ((('keyboard key* modifiers* 'up) . handler) + (and (eq? key key*) + (modifiers-match? modifiers modifiers*) + handler)) + (_ #f)) + input-map)) + +(define (text-input-handler input-map) + (any (match-lambda + ((('text-input) . handler) handler) + (_ #f)) + input-map)) + +(define (mouse-press-handler input-map button) + (any (match-lambda + ((('mouse 'button button* 'down) . handler) + (and (eq? button button*) + handler)) + (_ #f)) + input-map)) + +(define (mouse-release-handler input-map button) + (any (match-lambda + ((('mouse 'button button* 'up) . handler) + (and (eq? button button*) + handler)) + (_ #f)) + input-map)) + +(define (mouse-move-handler input-map buttons) + (any (match-lambda + ((('mouse 'move buttons*) . handler) + (and (= (length buttons) (length buttons*)) + (every (lambda (b) (memq b buttons*)) buttons) + handler)) + (_ #f)) + input-map)) + +(define (mouse-wheel-handler input-map) + (any (match-lambda + ((('mouse 'wheel) . handler) + handler) + (_ #f)) + input-map)) + +(define (controller-press-handler input-map controller-id button) + (any (match-lambda + ((('controller 'button controller-id* button* 'down) . handler) + (and (= controller-id controller-id*) + (eq? button button*) + handler)) + (_ #f)) + input-map)) + +(define (controller-release-handler input-map controller-id button) + (any (match-lambda + ((('controller 'button controller-id* button* 'up) . handler) + (and (= controller-id controller-id*) + (eq? button button*) + handler)) + (_ #f)) + input-map)) + +(define (controller-move-handler input-map controller-id axis) + (any (match-lambda + ((('controller 'axis controller-id* axis*) . handler) + (and (= controller-id controller-id*) + (eq? axis axis*) + handler)) + (_ #f)) + input-map)) diff --git a/catbird/kernel.scm b/catbird/kernel.scm new file mode 100644 index 0000000..4ed642a --- /dev/null +++ b/catbird/kernel.scm @@ -0,0 +1,394 @@ +(define-module (catbird kernel) + #:use-module (catbird asset) + #:use-module (catbird camera) + #:use-module (catbird config) + #:use-module (catbird input-map) + #:use-module (catbird mixins) + #:use-module (catbird mode) + #:use-module (catbird region) + #:use-module (catbird scene) + #:use-module (chickadee) + #:use-module (chickadee data array-list) + #:use-module (chickadee math rect) + #:use-module (ice-9 atomic) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:use-module (system repl coop-server) + #:export (all-regions + create-full-region + create-region + find-region-by-name + frames-per-second + kill-region + current-keyboard-focus + take-keyboard-focus + current-controller-focus + take-controller-focus + bind-input/global + unbind-input/global + run-catbird + exit-catbird)) + + +;;; +;;; Kernel +;;; + +(define-root-class <kernel> () + (controllers #:getter controllers #:init-thunk make-array-list) + (regions #:accessor regions #:init-value '()) + (input-map #:accessor input-map #:init-thunk make-input-map) + (keyboard-focus #:accessor keyboard-focus #:init-value #f) + (controller-focus #:getter controller-focus #:init-thunk make-hash-table) + (repl #:accessor repl #:init-value #f) + (frame-start-time #:accessor frame-start-time #:init-value 0.0) + (average-frame-time #:accessor average-frame-time #:init-value 0.0)) + +(define-method (load* (kernel <kernel>)) + (when developer-mode? + (set! (repl kernel) (spawn-coop-repl-server)))) + +;; Add the system notification and debugging overlay. +(define-method (add-overlay (kernel <kernel>)) + (let ((region (create-full-region #:name 'overlay #:rank 9999))) + (set! (camera region) + (make <camera-2d> + #:width (rect-width (area region)) + #:height (rect-height (area region)))) + ;; Use resolve-module to avoid a circular dependency. + (replace-scene region + ((module-ref (resolve-module '(catbird overlay)) + 'make-overlay))))) + +(define-method (overlay-scene (kernel <kernel>)) + (scene (lookup-region kernel 'overlay))) + +(define-method (notify (kernel <kernel>) message) + (let ((notify (module-ref (resolve-module '(catbird overlay)) 'notify))) + (notify (overlay-scene kernel) message))) + +(define-method (update (kernel <kernel>) dt) + (when developer-mode? + (poll-coop-repl-server (repl kernel)) + (reload-modified-assets)) + (for-each (lambda (region) (update/around region dt)) + (regions kernel))) + +(define-method (render (kernel <kernel>) alpha) + (for-each (lambda (region) + (render/around region alpha)) + (regions kernel)) + ;; Compute FPS. + (let ((current-time (elapsed-time))) + (set! (average-frame-time kernel) + (+ (* (- current-time (frame-start-time kernel)) 0.1) + (* (average-frame-time kernel) 0.9))) + (set! (frame-start-time kernel) current-time))) + +(define-method (lookup-region (kernel <kernel>) region-name) + (find (lambda (region) + (eq? (name region) region-name)) + (regions kernel))) + +(define-method (add-region (kernel <kernel>) (region <region>)) + (let ((r (regions kernel))) + ;; The first region added gets keyboard focus by default. + (when (null? r) + (set! (keyboard-focus kernel) region)) + (set! (regions kernel) + (sort-by-rank/ascending (cons region (regions kernel)))))) + +(define-method (bind-input (kernel <kernel>) spec handler) + (set! (input-map kernel) (add-input (input-map kernel) spec handler))) + +(define-method (unbind-input (kernel <kernel>) spec) + (set! (input-map kernel) (remove-input (input-map kernel) spec))) + + +;;; +;;; Keyboard +;;; + +(define-method (on-key-press (kernel <kernel>) key modifiers) + (or (let ((handler (key-press-handler (input-map kernel) key modifiers))) + (and handler (handler))) + (let* ((r (keyboard-focus kernel)) + (s (and r (scene r)))) + (and s (on-key-press s key modifiers))))) + +(define-method (on-key-release (kernel <kernel>) key modifiers) + (or (let ((handler (key-release-handler (input-map kernel) key modifiers))) + (and handler (handler))) + (let* ((r (keyboard-focus kernel)) + (s (and r (scene r)))) + (and s (on-key-release s key modifiers))))) + +(define-method (on-text-input (kernel <kernel>) text) + (or (let ((handler (text-input-handler (input-map kernel)))) + (and handler (handler text))) + (let* ((r (keyboard-focus kernel)) + (s (and r (scene r)))) + (and s (on-text-input s text))))) + + +;;; +;;; Mouse +;;; + +(define (mouse-search kernel proc) + (let loop ((regions* (regions kernel))) + (match regions* + (() #f) + ((r . rest) + (or (loop rest) + (let ((s (scene r))) + (and s (proc s)))))))) + +(define-method (on-mouse-press (kernel <kernel>) button x y) + (or (let ((handler (mouse-press-handler (input-map kernel) button))) + (and handler (handler x y))) + (mouse-search kernel + (lambda (s) + (on-mouse-press s button x y))))) + +(define-method (on-mouse-release (kernel <kernel>) button x y) + (or (let ((handler (mouse-release-handler (input-map kernel) button))) + (and handler (handler x y))) + (mouse-search kernel + (lambda (s) + (on-mouse-release s button x y))))) + +(define-method (on-mouse-move (kernel <kernel>) x y x-rel y-rel buttons) + (or (let ((handler (mouse-move-handler (input-map kernel) buttons))) + (and handler (handler x y x-rel y-rel))) + (mouse-search kernel + (lambda (s) + (on-mouse-move s x y x-rel y-rel buttons))))) + +(define-method (on-mouse-wheel (kernel <kernel>) x y) + (or (let ((handler (mouse-wheel-handler (input-map kernel)))) + (and handler (handler x y))) + (mouse-search kernel + (lambda (s) + (on-mouse-wheel s x y))))) + + +;;; +;;; Controllers +;;; + +(define-method (controller-focus (kernel <kernel>) slot) + (hashv-ref (controller-focus kernel) (controller-slot-id slot))) + +(define (make-controller-slot id) + (vector id #f)) + +(define (controller-slot-id slot) + (vector-ref slot 0)) + +(define (controller-slot-controller slot) + (vector-ref slot 1)) + +(define (controller-slot-empty? slot) + (not (controller-slot-controller slot))) + +(define (fill-controller-slot! slot controller) + (vector-set! slot 1 controller)) + +(define (clear-controller-slot! slot) + (fill-controller-slot! slot #f)) + +(define-method (empty-controller-slot (kernel <kernel>)) + (let* ((c (controllers kernel)) + (n (array-list-size c))) + (let loop ((i 0)) + (if (= i n) + (let ((slot (make-controller-slot i))) + (array-list-push! c slot) + slot) + (let ((slot (array-list-ref c i))) + (if (controller-slot-empty? slot) + slot + (loop (+ i 1)))))))) + +(define-method (find-controller-slot (kernel <kernel>) controller) + (let* ((c (controllers kernel)) + (n (array-list-size c))) + (let loop ((i 0)) + (if (= i n) + #f + (let ((slot (array-list-ref c i))) + (if (eq? (controller-slot-controller slot) controller) + slot + (loop (+ i 1)))))))) + +(define-method (on-controller-add (kernel <kernel>) controller) + (let ((slot (empty-controller-slot kernel))) + (notify kernel (string-append "Controller " + (number->string + (+ (controller-slot-id slot) 1)) + " connected: " + (controller-name controller))) + (fill-controller-slot! slot controller))) + +(define-method (on-controller-remove (kernel <kernel>) controller) + (let ((slot (find-controller-slot kernel controller))) + (notify kernel (string-append "Controller " + (number->string + (+ (controller-slot-id slot) 1)) + " disconnected: " + (controller-name controller))) + (clear-controller-slot! (find-controller-slot kernel controller)))) + +(define-method (on-controller-press (kernel <kernel>) controller button) + (let ((slot (find-controller-slot kernel controller))) + (or (let ((handler (controller-press-handler (input-map kernel) + (controller-slot-id slot) + button))) + (and handler (handler))) + (let* ((r (controller-focus kernel slot)) + (s (and r (scene r)))) + (and r (on-controller-press s + (controller-slot-id slot) + button)))))) + +(define-method (on-controller-release (kernel <kernel>) controller button) + (let ((slot (find-controller-slot kernel controller))) + (or (let ((handler (controller-release-handler (input-map kernel) + (controller-slot-id slot) + button))) + (and handler (handler))) + (let* ((r (controller-focus kernel slot)) + (s (and r (scene r)))) + (and s (on-controller-release s + (controller-slot-id slot) + button)))))) + +(define-method (on-controller-move (kernel <kernel>) controller axis value) + (let ((slot (find-controller-slot kernel controller))) + (or (let ((handler (controller-move-handler (input-map kernel) + (controller-slot-id slot) + axis))) + (and handler (handler value))) + (let* ((r (controller-focus kernel slot)) + (s (and r (scene r)))) + (and s (on-controller-move s + (controller-slot-id slot) + axis + value)))))) + + +;;; +;;; Global kernel API +;;; + +(define current-kernel (make-parameter #f)) + +(define (unique-region-name) + (gensym "region-")) + +(define* (create-region area #:key (rank 0) (name (unique-region-name))) + (let ((region (make-region area name rank))) + (add-region (current-kernel) region) + region)) + +(define* (create-full-region #:key (rank 0) (name (unique-region-name))) + (let ((w (window-width (current-window))) + (h (window-height (current-window)))) + (create-region (make-rect 0.0 0.0 w h) #:rank rank #:name name))) + +(define (kill-region region) + (let ((k (current-kernel))) + (set! (regions k) (delq region (regions k))))) + +(define (all-regions) + (regions (current-kernel))) + +(define (find-region-by-name name) + (lookup-region (current-kernel) name)) + +(define (current-keyboard-focus) + (keyboard-focus (current-kernel))) + +(define (take-keyboard-focus region) + (set! (keyboard-focus (current-kernel)) region)) + +(define (current-controller-focus controller-id) + (hashv-ref (controller-focus (current-kernel)) controller-id)) + +(define (take-controller-focus controller-id region) + (hashv-set! (controller-focus (current-kernel)) controller-id region)) + +(define (bind-input/global spec handler) + (bind-input (current-kernel) spec handler)) + +(define (unbind-input/global spec handler) + (unbind-input (current-kernel) spec handler)) + +(define (frames-per-second) + (/ 1.0 (average-frame-time (current-kernel)))) + +(define* (run-catbird thunk #:key (width 1366) (height 768) + (title "^~Catbird~^") (fullscreen? #f) + (resizable? #t) (update-hz 60)) + (let ((kernel (make <kernel>))) + (parameterize ((current-kernel kernel)) + (run-game #:window-title title + #:window-width width + #:window-height height + #:window-fullscreen? fullscreen? + #:window-resizable? resizable? + #:update-hz update-hz + #:load + (lambda () + (load* kernel) + (thunk) + (add-overlay kernel)) + #:draw + (lambda (alpha) + (render kernel alpha)) + #:update + (lambda (dt) + (update kernel dt)) + #:key-press + (lambda (key modifiers repeat?) + (on-key-press kernel key modifiers)) + #:key-release + (lambda (key modifiers) + (on-key-release kernel key modifiers)) + #:text-input + (lambda (text) + (on-text-input kernel text)) + #:mouse-press + ;; TODO: Handle click counter? + (lambda (button clicks x y) + (on-mouse-press kernel button x y)) + #:mouse-release + (lambda (button x y) + (on-mouse-release kernel button x y)) + #:mouse-move + (lambda (x y x-rel y-rel buttons) + (on-mouse-move kernel x y x-rel y-rel buttons)) + #:mouse-wheel + (lambda (x y) + (on-mouse-wheel kernel x y)) + #:controller-add + (lambda (controller) + (on-controller-add kernel controller)) + #:controller-remove + (lambda (controller) + (on-controller-remove kernel controller)) + #:controller-press + (lambda (controller button) + (on-controller-press kernel controller button)) + #:controller-release + (lambda (controller button) + (on-controller-release kernel controller button)) + #:controller-move + (lambda (controller axis value) + (on-controller-move kernel controller axis value)))))) + +(define (exit-catbird) + "Stop the Catbird engine." + (abort-game)) diff --git a/catbird/line-editor.scm b/catbird/line-editor.scm new file mode 100644 index 0000000..74ced0b --- /dev/null +++ b/catbird/line-editor.scm @@ -0,0 +1,312 @@ +(define-module (catbird line-editor) + #:use-module (catbird mode) + #:use-module (catbird node) + #:use-module (catbird node-2d) + #:use-module (catbird observer) + #:use-module (catbird region) + #:use-module (catbird ring-buffer) + #:use-module (catbird scene) + #:use-module (chickadee) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics path) + #:use-module (chickadee graphics text) + #:use-module (chickadee math vector) + #:use-module (chickadee scripting) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:export (<line-editor> + <line-edit-mode> + backward-char + backward-delete-char + forward-delete-char + backward-history + beginning-of-line + clear-line + end-of-line + forward-char + forward-history + get-line + history-enabled? + insert-char + invert-color + kill-line + overwrite + prompt + save-to-history) + #:re-export (color + font)) + +;; TODO: Matching paren/quote highlighting. +(define-class <line-editor> (<node-2d>) + (chars-before #:accessor chars-before #:init-value '()) + (chars-after #:accessor chars-after #:init-value '()) + (cached-line #:accessor cached-line #:init-value #f) + (prompt #:accessor prompt #:init-keyword #:prompt #:init-value "" + #:observe? #t) + ;; TODO: Allow customizable history length. + (history #:accessor history #:init-form (make-ring-buffer 128)) + (history-enabled? #:accessor history-enabled? + #:init-keyword #:history-enabled? #:init-value #t) + (history-index #:accessor history-index #:init-value 0) + (font #:accessor font #:init-keyword #:font #:init-thunk default-font + #:asset? #t) + (color #:accessor color #:init-keyword #:color #:init-value white) + (invert-color #:accessor invert-color #:init-keyword #:invert-color + #:init-value black) + (accepting-input? #:accessor accepting-input? #:init-value #t)) + +(define-method (on-change (editor <line-editor>) slot old new) + (update-visual editor)) + +(define-method (on-boot (editor <line-editor>)) + (attach-to editor + (make <label> + #:name 'prompt + #:font (font editor) + #:text (prompt editor) + #:color (color editor)) + (make <label> + #:name 'before-cursor + #:rank 1 + #:font (font editor) + #:color (color editor)) + (make <label> + #:name 'on-cursor + #:rank 1 + #:font (font editor)) + (make <label> + #:name 'after-cursor + #:rank 1 + #:font (font editor) + #:color (color editor)) + (make <canvas> + #:name 'cursor + #:painter + (with-style ((fill-color (color editor))) + (fill + (rectangle (vec2 0.0 0.0) + (font-line-width (font editor) "_") + (font-line-height (font editor))))))) + (discard-next-char editor) + (update-visual editor)) + +;; Whenever a command key sequence is pressed while the line editor is +;; active we have to stop accepting text input for one tick. +;; Otherwise, an errant character shows up. For example, if the user +;; presses alt+p, and that is bound to (backward-history editor 1), +;; the 'p' character shows up at the end of the line. This is due to +;; the fact that SDL generates a key event *and* an input event for +;; the same key press. +(define-method (discard-next-char (editor <line-editor>)) + (run-script editor + (set! (accepting-input? editor) #f) + (sleep (current-timestep)) + (set! (accepting-input? editor) #t))) + +(define-method (update-visual (editor <line-editor>)) + (let* ((lprompt (& editor prompt)) + (cursor (& editor cursor)) + (before (& editor before-cursor)) + (on (& editor on-cursor)) + (after (& editor after-cursor))) + (set! (cached-line editor) #f) + ;; Stop cursor blink. The cursor should only blink when the user + ;; is idle. + (stop-scripts cursor) + ;; Ensure the cursor is visible in case we stopped the script + ;; during a time when it was hidden. + (show cursor) + ;; Put the proper text in the proper labels + (set! (text lprompt) (prompt editor)) + (set! (text before) + (list->string (reverse (chars-before editor)))) + (set! (text on) + (match (chars-after editor) + (() "") + ((c . _) + (string c)))) + (set! (text after) + (match (chars-after editor) + (() "") + ((_ . chars) + (list->string chars)))) + ;; Line everything up. + (place-right lprompt before) + (place-right before on) + (place-right on after) + (align-left on cursor) + ;; Adjust size + (set! (width editor) + (+ (width lprompt) (width before) (width on) (width after))) + (set! (height editor) (height cursor)) + ;; Resume blinking cursor after a short idle timeout. + (run-script cursor + (forever + (set! (color on) (invert-color editor)) + (sleep 0.5) + (hide cursor) + (set! (color on) (color editor)) + (sleep 0.5) + (show cursor))))) + +(define-method (get-line (editor <line-editor>)) + (or (cached-line editor) + (let ((line (list->string + (append (reverse (chars-before editor)) + (chars-after editor))))) + (set! (cached-line editor) line) + line))) + +(define-method (overwrite (editor <line-editor>) str) + (set! (chars-before editor) (reverse (string->list str))) + (set! (chars-after editor) '()) + (update-visual editor)) + +(define-method (clear-line (editor <line-editor>)) + (discard-next-char editor) + (overwrite editor "") + (newest-history editor)) + +(define-method (insert-char (editor <line-editor>) char) + (when (accepting-input? editor) + (set! (chars-before editor) (cons char (chars-before editor))) + (update-visual editor))) + +(define-method (backward-delete-char (editor <line-editor>) n) + (unless (<= n 0) + (set! (chars-before editor) + (drop (chars-before editor) + (min n (length (chars-before editor)))))) + (discard-next-char editor) + (update-visual editor)) + +(define-method (forward-delete-char (editor <line-editor>) n) + (unless (<= n 0) + (set! (chars-after editor) + (drop (chars-after editor) + (min n (length (chars-after editor)))))) + (discard-next-char editor) + (update-visual editor)) + +(define-method (kill-line (editor <line-editor>)) + (forward-delete-char editor (length (chars-after editor)))) + +(define-method (backward-char (editor <line-editor>) n) + (let loop ((n n) + (before (chars-before editor)) + (after (chars-after editor))) + (if (or (<= n 0) (null? before)) + (begin + (set! (chars-before editor) before) + (set! (chars-after editor) after)) + (loop (- n 1) + (cdr before) + (cons (car before) after)))) + (discard-next-char editor) + (update-visual editor)) + +(define-method (forward-char (editor <line-editor>) n) + (let loop ((n n) + (before (chars-before editor)) + (after (chars-after editor))) + (if (or (<= n 0) (null? after)) + (begin + (set! (chars-before editor) before) + (set! (chars-after editor) after)) + (loop (- n 1) + (cons (car after) before) + (cdr after)))) + (discard-next-char editor) + (update-visual editor)) + +(define-method (beginning-of-line (editor <line-editor>)) + (backward-char editor (length (chars-before editor)))) + +(define-method (end-of-line (editor <line-editor>)) + (forward-char editor (length (chars-after editor)))) + +(define-method (save-to-history (editor <line-editor>)) + (ring-buffer-put! (history editor) (get-line editor))) + +(define-method (history-ref (editor <line-editor>) i) + (ring-buffer-ref (history editor) i)) + +(define-method (go-to-history (editor <line-editor>) i) + (when (and (history-enabled? editor) + (>= i 0) + (< i (ring-buffer-length (history editor)))) + (set! (history-index editor) i) + (overwrite editor (history-ref editor i)))) + +(define-method (backward-history (editor <line-editor>) n) + (discard-next-char editor) + (go-to-history editor (max (- (history-index editor) n) 0))) + +(define-method (forward-history (editor <line-editor>) n) + (discard-next-char editor) + (go-to-history editor + (min (+ (history-index editor) n) + (- (ring-buffer-length (history editor)) 1)))) + +(define-method (newest-history (editor <line-editor>)) + (set! (history-index editor) (ring-buffer-length (history editor)))) + + +;;; +;;; Line editing minor mode +;;; + +(define-class <line-edit-mode> (<minor-mode>) + (editor #:accessor editor #:init-keyword #:editor)) + +(define-method (insert-text (mode <line-edit-mode>) new-text) + (let ((e (editor mode))) + (string-for-each (lambda (char) + (insert-char e char)) + new-text))) + +(define-method (backward-delete-char (mode <line-edit-mode>)) + (backward-delete-char (editor mode) 1)) + +(define-method (forward-delete-char (mode <line-edit-mode>)) + (forward-delete-char (editor mode) 1)) + +(define-method (backward-char (mode <line-edit-mode>)) + (backward-char (editor mode) 1)) + +(define-method (forward-char (mode <line-edit-mode>)) + (forward-char (editor mode) 1)) + +(define-method (beginning-of-line (mode <line-edit-mode>)) + (beginning-of-line (editor mode))) + +(define-method (end-of-line (mode <line-edit-mode>)) + (end-of-line (editor mode))) + +(define-method (backward-history (mode <line-edit-mode>)) + (backward-history (editor mode) 1)) + +(define-method (forward-history (mode <line-edit-mode>)) + (forward-history (editor mode) 1)) + +(define-method (kill-line (mode <line-edit-mode>)) + (kill-line (editor mode))) + +(bind-input <line-edit-mode> (key-press 'backspace) backward-delete-char) +(bind-input <line-edit-mode> (key-press 'delete) forward-delete-char) +(bind-input <line-edit-mode> (key-press 'd '(ctrl)) forward-delete-char) +(bind-input <line-edit-mode> (key-press 'left) backward-char) +(bind-input <line-edit-mode> (key-press 'b '(ctrl)) backward-char) +(bind-input <line-edit-mode> (key-press 'right) forward-char) +(bind-input <line-edit-mode> (key-press 'f '(ctrl)) forward-char) +(bind-input <line-edit-mode> (key-press 'home) beginning-of-line) +(bind-input <line-edit-mode> (key-press 'a '(ctrl)) beginning-of-line) +(bind-input <line-edit-mode> (key-press 'end) end-of-line) +(bind-input <line-edit-mode> (key-press 'e '(ctrl)) end-of-line) +(bind-input <line-edit-mode> (key-press 'up) backward-history) +(bind-input <line-edit-mode> (key-press 'p '(alt)) backward-history) +(bind-input <line-edit-mode> (key-press 'down) forward-history) +(bind-input <line-edit-mode> (key-press 'n '(alt)) forward-history) +(bind-input <line-edit-mode> (key-press 'k '(ctrl)) kill-line) +(bind-input <line-edit-mode> (text-input) insert-text) diff --git a/catbird/minibuffer.scm b/catbird/minibuffer.scm new file mode 100644 index 0000000..d4ef244 --- /dev/null +++ b/catbird/minibuffer.scm @@ -0,0 +1,157 @@ +(define-module (catbird minibuffer) + #:use-module (catbird kernel) + #:use-module (catbird line-editor) + #:use-module (catbird mode) + #:use-module (catbird node) + #:use-module (catbird node-2d) + #:use-module (catbird region) + #:use-module (catbird scene) + #:use-module (chickadee) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics path) + #:use-module (chickadee graphics text) + #:use-module (chickadee math vector) + #:use-module (chickadee scripting) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:export (<minibuffer> + <minibuffer-mode> + define-minibuffer-command)) + +(define %background-color (make-color 0.0 0.0 0.0 0.8)) +(define %prompt "> ") +(define %padding 8.0) + +(define-class <minibuffer> (<node-2d>) + (commands #:accessor commands #:allocation #:class + #:init-thunk make-hash-table)) + +(define (minibuffer-commands) + (class-slot-ref <minibuffer> 'commands)) + +(define (lookup-minibuffer-command name) + (hash-ref (minibuffer-commands) name)) + +(define (add-minibuffer-command name thunk) + (hash-set! (minibuffer-commands) name thunk)) + +(define-syntax-rule (define-minibuffer-command name body ...) + (add-minibuffer-command (symbol->string 'name) (lambda () body ...))) + +(define-method (on-boot (minibuffer <minibuffer>)) + (attach-to minibuffer + (make <canvas> + #:name 'background) + (make <line-editor> + #:name 'editor + #:rank 1 + #:position (vec2 %padding %padding) + #:prompt %prompt))) + +(define-method (resize-minibuffer (minibuffer <minibuffer>) width) + (set! (painter (& minibuffer background)) + (with-style ((fill-color %background-color)) + (fill + (rectangle (vec2 0.0 0.0) + width + (+ (font-line-height (font (& minibuffer editor))) + (* %padding 2.0))))))) + +(define-method (clear-minibuffer (minibuffer <minibuffer>)) + (clear-line (& minibuffer editor))) + +;; TODO: The line editor should have a generic completion facility. +(define-method (autocomplete (minibuffer <minibuffer>)) + (let ((prefix (get-line (& minibuffer editor)))) + ;; Auto-complete if there is a single command name that starts + ;; with the characters the user has already typed. + (match (hash-fold (lambda (key value prev) + (if (string-prefix? prefix key) + (cons key prev) + prev)) + '() + (minibuffer-commands)) + ((name) + (overwrite (& minibuffer editor) name)) + ;; TODO: Display multiple completion options to user. + (_ #f)))) + +(define-method (get-command (minibuffer <minibuffer>)) + (lookup-minibuffer-command (get-line (& minibuffer editor)))) + +(define-method (valid-command? (minibuffer <minibuffer>)) + (procedure? (get-command minibuffer))) + +(define-method (run-command (minibuffer <minibuffer>)) + (let ((thunk (get-command minibuffer))) + (save-to-history (& minibuffer editor)) + (when (procedure? thunk) + (thunk)))) + + +;;; +;;; Minibuffer major mode +;;; + +(define-class <minibuffer-mode> (<major-mode>) + (prev-keyboard-focus #:accessor prev-keyboard-focus)) + +(define-method (on-enter (mode <minibuffer-mode>)) + (let* ((scene (parent mode)) + (region (car (regions scene))) + (minibuffer (or (& scene minibuffer) + (make <minibuffer> + #:name 'minibuffer + #:rank 999)))) + (if (parent minibuffer) + (begin + (clear-minibuffer minibuffer) + (show (& scene minibuffer))) + (attach-to (parent mode) minibuffer)) + (resize-minibuffer minibuffer (area-width region)) + (set! (prev-keyboard-focus mode) (current-keyboard-focus)) + (take-keyboard-focus region) + (add-minor-mode scene (make <line-edit-mode> + #:editor (& scene minibuffer editor))))) + +(define-method (on-exit (mode <minibuffer-mode>)) + (hide (& (parent mode) minibuffer)) + (remove-minor-mode (parent mode) <line-edit-mode>) + (take-keyboard-focus (prev-keyboard-focus mode))) + +(define-method (close-minibuffer (mode <minibuffer-mode>)) + (pop-major-mode (parent mode))) + +(define-method (autocomplete (mode <minibuffer-mode>)) + (autocomplete (& (parent mode) minibuffer))) + +(define-method (run-command (mode <minibuffer-mode>)) + ;; The minibuffer needs to be closed before running the command so + ;; that this mode is no longer active and we've had a chance to + ;; clean up the state of the overlay scene. + (let ((minibuffer (& (parent mode) minibuffer))) + (when (valid-command? minibuffer) + (close-minibuffer mode) + (run-command minibuffer)))) + +(bind-input <minibuffer-mode> (key-press 'escape) close-minibuffer) +(bind-input <minibuffer-mode> (key-press 'g '(ctrl)) close-minibuffer) +(bind-input <minibuffer-mode> (key-press 'tab) autocomplete) +(bind-input <minibuffer-mode> (key-press 'return) run-command) + + +;;; +;;; Basic minibuffer commands +;;; + +(define (for-each-user-scene proc) + (for-each (lambda (region) + (unless (eq? (name region) 'overlay) + (let ((s (scene region))) + (and s (proc s))))) + (all-regions))) + +;; General purpose built-in commands. +(define-minibuffer-command pause (for-each-user-scene pause)) +(define-minibuffer-command resume (for-each-user-scene resume)) +(define-minibuffer-command quit (exit-catbird)) diff --git a/catbird/mixins.scm b/catbird/mixins.scm new file mode 100644 index 0000000..8f4ec7c --- /dev/null +++ b/catbird/mixins.scm @@ -0,0 +1,195 @@ +(define-module (catbird mixins) + #:use-module (catbird config) + #:use-module (chickadee math vector) + #:use-module (chickadee scripting) + #:use-module (ice-9 exceptions) + #:use-module (oop goops) + #:use-module (srfi srfi-9) + #:export (<nameable> + name + + <rankable> + rank + sort-by-rank/ascending + + <containable> + parent + attach + detach + on-enter + on-exit + on-attach + on-detach + + <updatable> + update + update/around + + <scriptable> + agenda + on-pause + on-resume + paused? + pause + resume + run-script + stop-scripts + + <renderable> + visible? + on-show + on-hide + show + hide + render + render/around + render/before + + <movable-2d> + <movable-3d> + position) + #:replace (pause)) + +(define-class <nameable> () + (name #:accessor name #:init-keyword #:name #:init-value #f)) + +;; For Z sorting objects and such. +(define-class <rankable> () + (rank #:accessor rank #:init-keyword #:rank #:init-value 0)) + +(define (sort-by-rank/ascending lst) + (sort lst + (lambda (a b) + (< (rank a) (rank b))))) + + +;;; +;;; Containable +;;; + +(define-class <containable> () + (parent #:accessor parent #:init-form #f)) + +(define-method (on-enter (child <containable>)) + #t) + +(define-method (on-exit (child <containable>)) + #t) + +(define-method (on-attach parent (child <containable>)) + #t) + +(define-method (on-detach parent (child <containable>)) + #t) + +(define-method (attach (obj <containable>) container) + (when (parent obj) + (raise-exception + (make-exception-with-message "object already has a parent"))) + (set! (parent obj) container) + (on-enter obj) + (on-attach container obj)) + +(define-method (detach (obj <containable>)) + (unless (parent obj) + (raise-exception + (make-exception-with-message "object has no parent"))) + (on-detach (parent obj) obj) + (on-exit obj) + (set! (parent obj) #f)) + + +;;; +;;; Updatable +;;; + +(define-class <updatable> ()) + +(define-method (update (obj <updatable>) dt) + #t) + +(define-method (update/around (obj <updatable>) dt) + (update obj dt)) + + +;;; +;;; Scriptable +;;; + +(define-class <scriptable> (<updatable>) + (paused? #:accessor paused? #:init-form #f #:init-keyword #:paused?) + (agenda #:getter agenda #:init-thunk make-agenda)) + +(define-method (on-pause (obj <scriptable>)) + #t) + +(define-method (on-resume (obj <scriptable>)) + #t) + +(define-method (pause (obj <scriptable>)) + (unless (paused? obj) + (set! (paused? obj) #t) + (on-pause obj))) + +(define-method (resume (obj <scriptable>)) + (when (paused? obj) + (set! (paused? obj) #f) + (on-resume obj))) + +(define-method (update/around (obj <scriptable>) dt) + (unless (paused? obj) + (with-agenda (agenda obj) + (update-agenda dt) + (next-method)))) + +(define-syntax-rule (run-script obj body ...) + (with-agenda (agenda obj) (script body ...))) + +(define-method (stop-scripts obj) + (with-agenda (agenda obj) (clear-agenda))) + + +;;; +;;; Renderable +;;; + +(define-class <renderable> () + (visible? #:accessor visible? #:init-form #t #:init-keyword #:visible?)) + +(define-method (on-show (obj <renderable>)) + #t) + +(define-method (on-hide (obj <renderable>)) + #t) + +(define-method (show (obj <renderable>)) + (set! (visible? obj) #t) + (on-show obj)) + +(define-method (hide (obj <renderable>)) + (set! (visible? obj) #f) + (on-hide obj)) + +(define-method (render (obj <renderable>) alpha) + #t) + +(define-method (render/before (obj <renderable>) alpha) + #t) + +(define-method (render/around (obj <renderable>) alpha) + (when (visible? obj) + (render/before obj alpha) + (render obj alpha))) + + +;;; +;;; Movable +;;; + +(define-class <movable-2d> () + (position #:accessor position #:init-keyword #:position + #:init-form (vec2 0.0 0.0))) + +(define-class <movable-3d> () + (position #:accessor position #:init-keyword #:position + #:init-form (vec3 0.0 0.0 0.0))) diff --git a/catbird/mode.scm b/catbird/mode.scm new file mode 100644 index 0000000..e35146c --- /dev/null +++ b/catbird/mode.scm @@ -0,0 +1,105 @@ +(define-module (catbird mode) + #:use-module (catbird config) + #:use-module (catbird input-map) + #:use-module (catbird mixins) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:export (<major-mode> + <minor-mode> + bind-input + unbind-input + name-mode + clear-inputs + input-map + on-key-press + on-key-release + on-text-input + on-mouse-press + on-mouse-release + on-mouse-move + on-mouse-wheel + on-controller-press + on-controller-release + on-controller-move + <nothing-mode>) + #:re-export (controller-move + controller-press + controller-release + key-press + key-release + text-input + mouse-move + mouse-press + mouse-release + mouse-wheel + name + on-enter + on-exit + on-pause + on-resume + update)) + +(define-root-class <mode> (<scriptable> <containable> <nameable>) + (input-map #:accessor input-map #:allocation #:each-subclass + #:init-thunk make-input-map)) + +(define-method (input-map (mode-class <class>)) + (class-slot-ref mode-class 'input-map)) + +(define-method (bind-input mode-class spec handler) + (class-slot-set! mode-class 'input-map + (add-input (input-map mode-class) spec handler))) + +(define-method (unbind-input mode-class spec) + (class-slot-set! mode-class 'input-map + (remove-input (input-map mode-class) spec))) + +(define (clear-inputs mode-class) + (class-slot-set! mode-class 'input-map '())) + +(define-method (on-key-press (mode <mode>) key modifiers) + (let ((handler (key-press-handler (input-map mode) key modifiers))) + (and handler (handler mode)))) + +(define-method (on-key-release (mode <mode>) key modifiers) + (let ((handler (key-release-handler (input-map mode) key modifiers))) + (and handler (handler mode)))) + +(define-method (on-text-input (mode <mode>) text) + (let ((handler (text-input-handler (input-map mode)))) + (and handler (handler mode text)))) + +(define-method (on-mouse-press (mode <mode>) button x y) + (let ((handler (mouse-press-handler (input-map mode) button))) + (and handler (handler mode x y)))) + +(define-method (on-mouse-release (mode <mode>) button x y) + (let ((handler (mouse-release-handler (input-map mode) button))) + (and handler (handler mode x y)))) + +(define-method (on-mouse-move (mode <mode>) x y x-rel y-rel buttons) + (let ((handler (mouse-move-handler (input-map mode) buttons))) + (and handler (handler mode x y x-rel y-rel)))) + +(define-method (on-mouse-wheel (mode <mode>) x y) + (let ((handler (mouse-wheel-handler (input-map mode)))) + (and handler (handler mode x y)))) + +(define-method (on-controller-press (mode <mode>) controller-id button) + (let ((handler (controller-press-handler (input-map mode) controller-id button))) + (and handler (handler mode)))) + +(define-method (on-controller-release (mode <mode>) controller-id button) + (let ((handler (controller-release-handler (input-map mode) controller-id button))) + (and handler (handler mode)))) + +(define-method (on-controller-move (mode <mode>) controller-id axis value) + (let ((handler (controller-move-handler (input-map mode) controller-id axis))) + (and handler (handler mode value)))) + +(define-class <major-mode> (<mode>)) + +(define-class <minor-mode> (<mode>)) + +(define-class <nothing-mode> (<major-mode>)) diff --git a/catbird/node-2d.scm b/catbird/node-2d.scm new file mode 100644 index 0000000..fc579ba --- /dev/null +++ b/catbird/node-2d.scm @@ -0,0 +1,939 @@ +(define-module (catbird node-2d) + #:use-module (catbird asset) + #:use-module (catbird camera) + #:use-module (catbird cached-slots) + #:use-module (catbird mixins) + #:use-module (catbird node) + #:use-module (catbird observer) + #:use-module (chickadee) + #:use-module (chickadee math) + #: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 graphics 9-patch) + #:use-module (chickadee graphics blend) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics engine) + #:use-module (chickadee graphics framebuffer) + #:use-module (chickadee graphics particles) + #:use-module (chickadee graphics path) + #:use-module (chickadee graphics sprite) + #:use-module (chickadee graphics text) + #:use-module (chickadee graphics texture) + #:use-module (chickadee graphics tile-map) + #:use-module (chickadee graphics viewport) + #:use-module (chickadee scripting) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (rnrs base) + #:export (<node-2d> + aggregate-bounding-box + align-bottom + align-left + align-right + align-top + default-height + default-width + expire-local-matrix + follow-bezier-path + local-bounding-box + local-matrix + move-by + move-to + on-child-resize + origin + origin-x + origin-y + pick + place-above + place-below + place-left + place-right + position-x + position-y + resize + rotate-by + rotate-to + rotation + scale + scale-by + scale-to + scale-x + scale-y + shear + shear-x + shear-y + teleport + world-bounding-box + world-matrix + + <sprite> + texture + source-rect + blend-mode + tint + + <atlas-sprite> + atlas + index + + <animation> + frames + frame-duration + + <animated-sprite> + animations + frame-duration + current-animation + start-time + change-animation + + <9-patch> + top-margin + bottom-margin + left-margin + right-margin + + <sprite-batch> + batch + + <canvas> + painter + + <label> + font + text + color + align + vertical-align + + <tile-map> + tile-map + layers + + <particles> + particles) + #:re-export (height + position + width)) + +(define (refresh-local-matrix node local) + (matrix4-2d-transform! local + #:origin (origin node) + #:position (render-position node) + #:rotation (rotation node) + #:scale (scale node) + #:shear (shear node)) + local) + +(define (refresh-world-matrix node world) + (let ((p (parent node)) + (local (local-matrix node))) + (if (is-a? p <node-2d>) + (matrix4-mult! world local (world-matrix (parent node))) + (begin + (matrix4-identity! world) + (matrix4-mult! world world local))) + world)) + +(define (refresh-inverse-world-matrix node inverse) + (matrix4-inverse! (world-matrix node) inverse) + inverse) + +(define (refresh-local-bounding-box node bb) + (let ((p (position node)) + (o (origin node)) + (r (rotation node)) + (k (shear node)) + (s (size node))) + (if (and (= r 0.0) + (= (vec2-x k) 0.0) + (= (vec2-y k) 0.0)) + ;; Fast path: Node is axis-aligned and bounding box + ;; calculation is easy peasy. + (let ((s (scale node))) + (set-rect-x! bb (- (vec2-x p) (vec2-x o))) + (set-rect-y! bb (- (vec2-y p) (vec2-y o))) + (set-rect-width! bb (* (rect-width s) (vec2-x s))) + (set-rect-height! bb (* (rect-height s) (vec2-y s)))) + ;; Slow path: Node is rotated, sheared, or both. + (let* ((m (local-matrix node)) + (x0 0.0) + (y0 0.0) + (x1 (rect-width s)) + (y1 (rect-height s)) + (x2 (matrix4-transform-x m x0 y0)) + (y2 (matrix4-transform-y m x0 y0)) + (x3 (matrix4-transform-x m x1 y0)) + (y3 (matrix4-transform-y m x1 y0)) + (x4 (matrix4-transform-x m x1 y1)) + (y4 (matrix4-transform-y m x1 y1)) + (x5 (matrix4-transform-x m x0 y1)) + (y5 (matrix4-transform-y m x0 y1)) + (xmin (min x2 x3 x4 x5)) + (ymin (min y2 y3 y4 y5)) + (xmax (max x2 x3 x4 x5)) + (ymax (max y2 y3 y4 y5))) + (set-rect-x! bb xmin) + (set-rect-y! bb ymin) + (set-rect-width! bb (- xmax xmin)) + (set-rect-height! bb (- ymax ymin)))) + bb)) + +(define (refresh-world-bounding-box node bb) + (let* ((m (world-matrix node)) + (s (size node)) + (x0 0.0) + (y0 0.0) + (x1 (rect-width s)) + (y1 (rect-height s)) + (x2 (matrix4-transform-x m x0 y0)) + (y2 (matrix4-transform-y m x0 y0)) + (x3 (matrix4-transform-x m x1 y0)) + (y3 (matrix4-transform-y m x1 y0)) + (x4 (matrix4-transform-x m x1 y1)) + (y4 (matrix4-transform-y m x1 y1)) + (x5 (matrix4-transform-x m x0 y1)) + (y5 (matrix4-transform-y m x0 y1)) + (xmin (min x2 x3 x4 x5)) + (ymin (min y2 y3 y4 y5)) + (xmax (max x2 x3 x4 x5)) + (ymax (max y2 y3 y4 y5))) + (set-rect-x! bb xmin) + (set-rect-y! bb ymin) + (set-rect-width! bb (- xmax xmin)) + (set-rect-height! bb (- ymax ymin)) + bb)) + +(define (refresh-aggregate-bounding-box node bb) + ;; If the node has no children then the aggregate bounding box is + ;; the same as the world bounding box. + (rect-copy! (world-bounding-box node) bb) + (for-each-child (lambda (child) + (rect-union! bb (aggregate-bounding-box child))) + node) + bb) + +(define-class <node-2d> (<node> <movable-2d> <cacheable>) + ;; Translation of the origin. By default, the origin is at the + ;; bottom left corner of a node. + (origin #:accessor origin #:init-form (vec2 0.0 0.0) #:init-keyword #:origin + #:observe? #t) + (origin-x #:accessor origin-x #:allocation #:virtual + #:slot-ref (lambda (node) (vec2-x (origin node))) + #:slot-set! (lambda (node x) + (set-vec2-x! (origin node) x) + (expire-local-matrix node))) + (origin-y #:accessor origin-y #:allocation #:virtual + #:slot-ref (lambda (node) (vec2-y (origin node))) + #:slot-set! (lambda (node y) + (set-vec2-y! (origin node) y) + (expire-local-matrix node))) + ;; Translation + (position #:accessor position #:init-keyword #:position + #:init-form (vec2 0.0 0.0) #:observe? #t) + (position-x #:accessor position-x #:allocation #:virtual + #:slot-ref (lambda (node) (vec2-x (position node))) + #:slot-set! (lambda (node x) + (set-vec2-x! (position node) x) + (expire-local-matrix node))) + (position-y #:accessor position-y #:allocation #:virtual + #:slot-ref (lambda (node) (vec2-y (position node))) + #:slot-set! (lambda (node y) + (set-vec2-y! (position node) y) + (expire-local-matrix node))) + ;; Rotation around the Z-axis. + (rotation #:accessor rotation #:init-form 0.0 #:init-keyword #:rotation + #:observe? #t) + ;; Scaling + (scale #:accessor scale #:init-form (vec2 1.0 1.0) #:init-keyword #:scale + #:observe? #t) + (scale-x #:accessor scale-x #:allocation #:virtual + #:slot-ref (lambda (node) (vec2-x (scale node))) + #:slot-set! (lambda (node x) + (set-vec2-x! (scale node) x) + (expire-local-matrix node))) + (scale-y #:accessor scale-y #:allocation #:virtual + #:slot-ref (lambda (node) (vec2-y (scale node))) + #:slot-set! (lambda (node y) + (set-vec2-y! (scale node) y) + (expire-local-matrix node))) + ;; Shearing + (shear #:accessor shear #:init-form (vec2 0.0 0.0) #:init-keyword #:shear + #:observe? #t) + (shear-x #:accessor shear-x #:allocation #:virtual + #:slot-ref (lambda (node) (vec2-x (shear node))) + #:slot-set! (lambda (node x) + (set-vec2-x! (shear node) x) + (expire-local-matrix node))) + (shear-y #:accessor shear-y #:allocation #:virtual + #:slot-ref (lambda (node) (vec2-y (shear node))) + #:slot-set! (lambda (node y) + (set-vec2-y! (shear node) y) + (expire-local-matrix node))) + ;; 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)) + ;; Transformation matrices: + ;; + ;; The local matrix incorporates the node-specific translation, + ;; rotation, scale, and shear factors. + (local-matrix #:getter local-matrix #:init-thunk make-identity-matrix4 + #:cached? #t #:refresh refresh-local-matrix) + ;; The world matrix is defined by the multiplication of the parent's + ;; world matrix with the local matrix. + (world-matrix #:getter world-matrix #:init-thunk make-identity-matrix4 + #:cached? #t #:refresh refresh-world-matrix) + ;; The inverse world matrix is useful for translating world + ;; coordinates into local coordinates. Using this matrix it is + ;; possible to detect if the mouse is over a rotated and sheared + ;; node, for example. + (inverse-world-matrix #:getter inverse-world-matrix + #:init-form (make-identity-matrix4) + #:cached? #t #:refresh refresh-inverse-world-matrix) + ;; Node dimensions. Stored as a rectangle for convenience, so it + ;; can be used as a bounding box that doesn't take any + ;; transformation matrix into consideration. + (size #:getter size #:init-thunk make-null-rect) + (width #:accessor width #:init-keyword #:width #:watch? #t #:allocation #:virtual + #:slot-ref (lambda (node) (rect-width (size node))) + #:slot-set! (lambda (node w) + (set-rect-width! (size node) w) + (expire-local-bounding-box node))) + (height #:accessor height #:init-keyword #:height #:watch? #t #:allocation #:virtual + #:slot-ref (lambda (node) (rect-height (size node))) + #:slot-set! (lambda (node h) + (set-rect-height! (size node) h) + (expire-local-bounding-box node))) + ;; The local bounding box is the combination of the node's + ;; dimensions with the local transformation matrix. + (local-bounding-box #:getter local-bounding-box #:init-thunk make-null-rect + #:cached? #t #:refresh refresh-local-bounding-box) + ;; The world bounding box is the combination of the node's + ;; dimensions with the world transformation matrix. + (world-bounding-box #:getter world-bounding-box #:init-thunk make-null-rect + #:cached? #t #:refresh refresh-world-bounding-box) + ;; The aggregate bounding box is the union of the node's world + ;; bounding boxes and the aggregate bounding boxes of all its + ;; children. This bounding box is used to quickly determine if a + ;; point in world space might be within any node in a tree. This + ;; bounding box can be used for render culling, mouse selection, and + ;; render clipping. + (aggregate-bounding-box #:getter aggregate-bounding-box + #:init-thunk make-null-rect #:cached? #t + #:refresh refresh-aggregate-bounding-box)) + +(define-method (initialize (node <node-2d>) args) + (next-method) + ;; If scale is specified as a scalar value, convert it to a vector + ;; that applies identical scaling to both axes. + (let ((s (scale node))) + (when (number? s) + (slot-set! node 'scale (vec2 s s)))) + ;; If caller doesn't specify a custom width and height, let the node + ;; pick a reasonable default size. + (when (= (width node) 0.0) + (set! (width node) (default-width node))) + (when (= (height node) 0.0) + (set! (height node) (default-height node))) + ;; Build an initial bounding box. + (vec2-copy! (position node) (render-position node)) + ;; Set the initial last position to the same as the initial position + ;; to avoid a brief flash where the node appears at (0, 0). + (remember-position node)) + +(define (expire-local-matrix node) + (expire-slot! node 'local-matrix) + (expire-world-matrix node) + (expire-local-bounding-box node)) + +(define (expire-world-matrix node) + (unless (slot-expired? node 'world-matrix) + (expire-slot! node 'world-matrix) + (expire-slot! node 'inverse-world-matrix) + (for-each-child (lambda (child) + (expire-world-matrix child) + (expire-world-bounding-box child)) + node))) + +(define (expire-local-bounding-box node) + (expire-slot! node 'local-bounding-box) + (expire-world-bounding-box node)) + +(define (expire-world-bounding-box node) + (expire-slot! node 'world-bounding-box) + (expire-aggregate-bounding-box node)) + +(define (expire-aggregate-bounding-box node) + (unless (slot-expired? node 'aggregate-bounding-box) + (expire-slot! node 'aggregate-bounding-box) + (let ((p (parent node))) + (when (is-a? p <node-2d>) + (expire-aggregate-bounding-box p))))) + + +;;; +;;; Bounding boxes +;;; + +(define-method (default-width (node <node-2d>)) 0.0) + +(define-method (default-height (node <node-2d>)) 0.0) + +(define-method (on-child-resize node child) + #t) + +;; (define-method ((setter origin) (node <node-2d>)) +;; (dirty! node) +;; (next-method)) + +(define-method (on-change (node <node-2d>) slot old new) + (case slot + ((origin position rotation scale shear) + (expire-local-matrix node)))) + +(define-method (resize (node <node-2d>) w h) + (set! (width node) w) + (set! (height node) h) + (expire-local-bounding-box node)) + + +;;; +;;; Animation +;;; + +(define-method (remember-position (node <node-2d>)) + (vec2-copy! (position node) (last-position node))) + +(define-method (remember-position/recursive (node <node-2d>)) + (remember-position node) + (for-each-child remember-position/recursive node)) + +(define-method (move-to (node <node-2d>) x y) + (set! (position-x node) x) + (set! (position-y node) y)) + +(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) + ;; When teleporting, we want to avoid position interpolation and odd + ;; looking camera jumps. + ;; + ;; Interpolation is avoided by setting all 3 position vectors to the + ;; same values. This prevents a visual artifact where the player + ;; sees 1 frame where the node is somewhere in between its former + ;; position and the new position. + ;; + ;; The camera jump problem occurs when a camera has a node as its + ;; tracking target and that node teleports. Normally, the camera's + ;; view matrix is updated before any nodes are rendered, and thus + ;; *before* the node can recompute its world matrix based on the new + ;; position. This creates 1 frame where the camera is improperly + ;; positioned at the target's old location. This 1 frame lag is not + ;; an issue during normal movement, but when teleporting it causes a + ;; noticably unsmooth blip. Forcing the matrices to be recomputed + ;; immediately solves this issue. + (set-vec2! (position node) x y) + (set-vec2! (last-position node) x y) + (set-vec2! (render-position node) x y) + (expire-local-matrix node)) + +(define-method (rotate-to (node <node-2d>) theta) + (set! (rotation node) theta)) + +(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) + (set! (scale-x node) sx) + (set! (scale-y node) sy)) + +(define-method (scale-to (node <node-2d>) s) + (scale-to node s s)) + +(define-method (scale-to (node <node-2d>) sx sy duration ease) + (scale-by node (- sx (scale-x node)) (- sy (scale-y node)) 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) + (scale-to node (+ (scale-x node) dsx) (+ (scale-y node) dsy))) + +(define-method (scale-by (node <node-2d>) ds) + (scale-by node ds ds)) + +(define-method (scale-by (node <node-2d>) dsx dsy duration ease) + (let ((start-x (scale-x node)) + (start-y (scale-y node))) + (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 (scale-by (node <node-2d>) ds duration (ease <procedure>)) + (scale-by node ds ds duration ease)) + +(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) + (expire-local-matrix node)) + #:ease linear)) + path))) + +(define-method (follow-bezier-path (node <node-2d>) path duration) + (follow-bezier-path node path duration #t)) + +(define-method (pick (node <node-2d>) p pred) + (and (pred node) + (let loop ((kids (reverse (children node)))) + (match kids + (() + (let* ((m (inverse-world-matrix node)) + (x (vec2-x p)) + (y (vec2-y p)) + (tx (matrix4-transform-x m x y)) + (ty (matrix4-transform-y m x y))) + (and (>= tx 0.0) + (< tx (width node)) + (>= ty 0.0) + (< ty (height node)) + node))) + ((child . rest) + (let ((o (origin node))) + (or (pick child p pred) + (loop rest)))))))) + + +;;; +;;; Updating/rendering +;;; + +(define-method (update/around (node <node-2d>) dt) + (unless (paused? node) + (remember-position node)) + (next-method)) + +(define-method (pause (node <node-2d>)) + ;; We need to set the last position of all objects in the tree to + ;; their current position, otherwise any moving objects will + ;; experience this weird jitter while paused because the last + ;; position will never be updated during the duration of the pause + ;; event. + (next-method) + (remember-position/recursive node)) + +(define-method (tree-in-view? (node <node-2d>)) + (rect-intersects? (aggregate-bounding-box node) + (view-bounding-box (current-camera)))) + +(define-method (in-view? (node <node-2d>)) + (rect-intersects? (world-bounding-box node) + (view-bounding-box (current-camera)))) + +(define-method (render/around (node <node-2d>) alpha) + ;; Compute the linearly interpolated rendering position, in the case + ;; that node has moved since the last update. + (when (visible? node) + (let ((p (position node)) + (lp (last-position node)) + (rp (render-position node)) + (beta (- 1.0 alpha))) + (unless (and (vec2= rp p) (vec2= lp p)) + (set-vec2-x! rp (+ (* (vec2-x p) alpha) (* (vec2-x lp) beta))) + (set-vec2-y! rp (+ (* (vec2-y p) alpha) (* (vec2-y lp) beta))) + (expire-local-matrix node))) + (next-method))) + + +;;; +;;; Relative placement and alignment +;;; + +;; Placement and alignment of nodes is done under the assumption that +;; the nodes are in the same local coordinate space. If this is not +;; the case, the results will be garbage. + +(define* (place-right a b #:key (padding 0.0)) + "Adjust B's x position coordinate so that it is PADDING distance to +the right of A." + (set! (position-x b) (+ (position-x a) (width a) padding))) + +(define* (place-left a b #:key (padding 0.0)) + "Adjust B's x position coordinate so that it is PADDING distance to +the left of A." + (set! (position-x b) (- (position-x a) (width b) padding))) + +(define* (place-above a b #:key (padding 0.0)) + "Adjust B's y position coordinate so that it is PADDING distance above +A." + (set! (position-y b) (+ (position-y a) (height a) padding))) + +(define* (place-below a b #:key (padding 0.0)) + "Adjust B's y position coordinate so that it is PADDING distance below +A." + (set! (position-y b) (- (position-y a) (height b) padding))) + +(define (align-left a b) + "Align the left side of B with the left side of A." + (set! (position-x b) (position-x a))) + +(define (align-right a b) + "Align the right side of B with the right side of A." + (set! (position-x b) (+ (position-x a) (width a)))) + +(define (align-bottom a b) + "Align the bottom of B with the bottom of A." + (set! (position-y b) (position-y a))) + +(define (align-top a b) + "Align the top of B with the top of A." + (set! (position-y b) (+ (position-y a) (height a)))) + + +;;; +;;; Sprite +;;; + +(define-class <sprite> (<node-2d>) + (texture #:accessor texture #:init-keyword #:texture #:asset? #t + #:observe? #t) + (tint #:accessor tint #:init-keyword #:tint #:init-form white) + (blend-mode #:accessor blend-mode #:init-keyword #:blend-mode + #:init-form blend:alpha)) + +(define-method (default-width (sprite <sprite>)) + (texture-width (texture sprite))) + +(define-method (default-height (sprite <sprite>)) + (texture-height (texture sprite))) + +(define-method (on-change (sprite <sprite>) slot-name old new) + (case slot-name + ((texture) + (set! (width sprite) (texture-width new)) + (set! (height sprite) (texture-height new))))) + +(define-method (render (sprite <sprite>) alpha) + (let ((t (texture sprite))) + (with-graphics-state ((g:blend-mode (blend-mode sprite))) + (draw-sprite* t (size sprite) (world-matrix sprite) + #:tint (tint sprite) + #:texcoords (texture-gl-tex-rect t))))) + + +;;; +;;; Texture Atlas Sprite +;;; + +(define-class <atlas-sprite> (<sprite>) + (atlas #:accessor atlas #:init-keyword #:atlas #:asset? #t #:observe? #t) + (index #:accessor index #:init-keyword #:index #:init-value 0 #:observe? #t)) + +(define-method (sync-texture (sprite <atlas-sprite>)) + (let ((t (texture-atlas-ref (atlas sprite) (index sprite)))) + (set! (texture sprite) t))) + +(define-method (on-boot (sprite <atlas-sprite>)) + (sync-texture sprite)) + +(define-method (on-change (sprite <atlas-sprite>) slot-name old new) + (case slot-name + ((atlas index) + (sync-texture sprite)) + (else + (next-method)))) + + +;;; +;;; 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>) + (atlas #:accessor atlas #:init-keyword #:atlas #:asset? #t) + (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 (mod (- (elapsed-time) (start-time sprite)) anim-duration)) + (frame (vector-ref frames (inexact->exact + (floor (/ time frame-duration)))))) + (when (not (= frame (index sprite))) + (set! (index sprite) frame)))) + +(define-method (change-animation (sprite <animated-sprite>) name) + (set! (current-animation sprite) name) + (set! (start-time sprite) (elapsed-time))) + + +;;; +;;; 9-Patch +;;; + +(define-class <9-patch> (<node-2d>) + (texture #:accessor texture #:init-keyword #:texture #:asset? #t) + (left-margin #:accessor left-margin #:init-keyword #:left) + (right-margin #:accessor right-margin #:init-keyword #:right) + (bottom-margin #:accessor bottom-margin #:init-keyword #:bottom) + (top-margin #:accessor top-margin #:init-keyword #:top) + (mode #:accessor mode #:init-keyword #:mode #:init-value 'stretch) + (blend-mode #:accessor blend-mode #:init-keyword #:blend-mode + #:init-value blend:alpha) + (tint #:accessor tint #:init-keyword #:tint #:init-value white) + (render-rect #:getter render-rect #:init-form (make-rect 0.0 0.0 0.0 0.0))) + +(define-method (initialize (9-patch <9-patch>) initargs) + (let ((default-margin (get-keyword #:margin initargs 0.0))) + (slot-set! 9-patch 'left-margin default-margin) + (slot-set! 9-patch 'right-margin default-margin) + (slot-set! 9-patch 'bottom-margin default-margin) + (slot-set! 9-patch 'top-margin default-margin)) + (next-method) + (set-rect-width! (render-rect 9-patch) (width 9-patch)) + (set-rect-height! (render-rect 9-patch) (height 9-patch))) + +;; (define-method (on-change (9-patch <9-patch>) slot-name old new) +;; (case slot-name +;; ((width) +;; (set-rect-width! (render-rect 9-patch) new)) +;; ((height) +;; (set-rect-height! (render-rect 9-patch) new))) +;; (next-method)) + +(define-method (render (9-patch <9-patch>) alpha) + (draw-9-patch* (texture 9-patch) + (render-rect 9-patch) + (world-matrix 9-patch) + #:top-margin (top-margin 9-patch) + #:bottom-margin (bottom-margin 9-patch) + #:left-margin (left-margin 9-patch) + #:right-margin (right-margin 9-patch) + #:mode (mode 9-patch) + #:blend-mode (blend-mode 9-patch) + #:tint (tint 9-patch))) + + +;;; +;;; 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 blend: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)))) + + +;;; +;;; Vector Path +;;; + +(define-class <canvas> (<node-2d>) + (painter #:accessor painter #:init-keyword #:painter #:init-value #f + #:observe? #t) + (canvas #:accessor canvas #:init-thunk make-empty-canvas)) + +(define-method (refresh-painter (c <canvas>)) + (let* ((p (painter c))) + (when p + (let ((bb (painter-bounding-box p))) + (set-canvas-painter! (canvas c) p) + ;; (set! (origin-x canvas) (- (rect-x bb))) + ;; (set! (origin-y canvas) (- (rect-y bb))) + (set! (width c) (rect-width bb)) + (set! (height c) (rect-height bb)))))) + +(define-method (on-boot (c <canvas>)) + (refresh-painter c)) + +(define-method ((setter canvas) (c <canvas>)) + (next-method) + (set-canvas-painter! (canvas c) (painter c))) + +(define-method (on-change (c <canvas>) slot-name old new) + (case slot-name + ((painter) + (refresh-painter c)) + (else + (next-method)))) + +(define-method (render (c <canvas>) alpha) + (draw-canvas* (canvas c) (world-matrix c))) + + +;;; +;;; Label +;;; + +(define-class <label> (<node-2d>) + (font #:accessor font #:init-keyword #:font #:init-thunk default-font + #:asset? #t #:observe? #t) + (text #:accessor text #:init-value "" #:init-keyword #:text #:observe? #t) + (compositor #:accessor compositor #:init-thunk make-compositor) + (page #:accessor page #:init-thunk make-page) + (typeset #:accessor typeset #:init-value typeset-lrtb) + (align #:accessor align #:init-value 'left #:init-keyword #:align #:observe? #t) + (vertical-align #:accessor vertical-align #:init-value 'bottom + #:init-keyword #:vertical-align #:observe? #t) + (color #:accessor color #:init-keyword #:color #:init-value white #:observe? #t)) + +(define-method (realign (label <label>)) + (set! (origin-x label) + (case (align label) + ((left) 0.0) + ((right) (width label)) + ((center) (/ (width label) 2.0)))) + (set! (origin-y label) + (case (vertical-align label) + ((bottom) 0.0) + ((top) (height label)) + ((center) (+ (/ (height label) 2.0) (font-descent (font label))))))) + +(define-method (refresh-label (label <label>)) + (let ((c (compositor label)) + (p (page label))) + (compositor-reset! c) + ((typeset label) c (font label) (text label) (color label)) + (page-reset! p) + (page-write! p c) + (let ((bb (page-bounding-box p))) + (set! (width label) (rect-width bb)) + (set! (height label) (rect-height bb))))) + +(define-method (on-boot (label <label>)) + (refresh-label label) + (realign label)) + +(define-method (on-asset-reload (label <label>) slot-name asset) + (case slot-name + ((font) + (refresh-label label)))) + +(define-method (on-change (label <label>) slot-name old new) + (case slot-name + ((font text) + (refresh-label label) + (unless (eq? (align label) 'left) + (realign label))) + ((color) + (refresh-label label)) + ((align vertical-align) + (realign label)) + (else + (next-method)))) + +(define-method (render (label <label>) alpha) + (draw-page (page label) (world-matrix label))) + + +;;; +;;; Tiled Map +;;; + +(define-class <tile-map> (<node-2d>) + (tile-map #:accessor tile-map #:init-keyword #:map #:asset? #t) + (layers #:accessor layers #:init-keyword #:layers #:init-form #f)) + +(define-method (render (node <tile-map>) alpha) + (let ((m (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 (on-boot (particles <particles>)) + ;; Default bounding box size. + (when (zero? (width particles)) + (set! (width particles) 32.0)) + (when (zero? (height particles)) + (set! (height particles) 32.0))) + +(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/catbird/node.scm b/catbird/node.scm new file mode 100644 index 0000000..99a6da3 --- /dev/null +++ b/catbird/node.scm @@ -0,0 +1,160 @@ +(define-module (catbird node) + #:use-module (catbird asset) + #:use-module (catbird cached-slots) + #:use-module (catbird config) + #:use-module (catbird mixins) + #:use-module (catbird observer) + #:use-module (chickadee scripting) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 format) + #:use-module (oop goops) + #:export (<node> + in-view? + tree-in-view? + children + for-each-child + on-boot + reboot + child-ref & + attach-to + replace + blink) + #:re-export (agenda + detach + hide + name + parent + on-enter + on-hide + on-exit + on-pause + on-resume + on-show + pause + paused? + rank + render + resume + run-script + show + stop-scripts + visible? + update)) + +(define-class <node> + (<renderable> <scriptable> <containable> <nameable> <rankable> + <observer> <asset-container>) + ;; An integer value that determines priority order for + ;; updating/rendering. + (rank #:getter rank #:init-value 0 #:init-keyword #:rank) + ;; List of children, sorted by rank. + (children #:accessor children #:init-value '()) + ;; Children indexed by name for fast lookup. + (children-by-name #:getter children-by-name #:init-thunk make-hash-table)) + +(define-method (initialize (node <node>) initargs) + (next-method) + (on-boot node)) + +(define-method (on-boot (node <node>)) + #t) + +(define-method (reboot (node <node>)) + (for-each-child detach node) + (with-agenda (agenda node) (reset-agenda)) + (on-boot node)) + +(define-method (write (node <node>) port) + (define (strip-angle-brackets str) + (let ((start (if (string-prefix? "<" str) 1 0)) + (end (if (string-suffix? ">" str) + (- (string-length str) 1) + (string-length str)))) + (substring str start end))) + (format port "#<~a name: ~a>" + (strip-angle-brackets + (symbol->string + (class-name (class-of node)))) + (name node))) + +(define (for-each-child proc node) + (for-each proc (children node))) + +(define-method (update/around (node <node>) dt) + (unless (paused? node) + ;; Update children first, recursively. + (for-each-child (lambda (child) (update/around child dt)) node) + (next-method))) + +(define-method (tree-in-view? (node <node>)) + #t) + +(define-method (in-view? (node <node>)) + #t) + +(define-method (render/around (node <node>) alpha) + (when (and (visible? node) (tree-in-view? node)) + (next-method) + (for-each-child (lambda (child) (render/around child alpha)) node))) + +(define-method (child-ref (parent <node>) name) + (hashq-ref (children-by-name 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 (attach-to (new-parent <node>) . new-children) + ;; Validate all the nodes first. The whole operation will fail if + ;; any of them cannot be attached. + (for-each (lambda (child) + (when (parent child) + (raise-exception + (make-exception-with-message "node already has a parent"))) + (when (child-ref new-parent (name child)) + (raise-exception + (make-exception-with-message "node name taken")))) + new-children) + ;; Add named children to the name index for quick lookup later. + (for-each (lambda (child) + (when (name child) + (hashq-set! (children-by-name new-parent) (name child) child))) + new-children) + ;; Add the new children and sort them by their rank so that + ;; updating/rendering happens in the desired order. + (set! (children new-parent) + (sort-by-rank/ascending (append new-children (children new-parent)))) + ;; Attach children to the parent, triggering initial enter/attach + ;; hooks. + (for-each (lambda (child) + (attach child new-parent)) + new-children)) + +(define-method (replace (parent-node <node>) . replacements) + (for-each (lambda (replacement) + (let ((old (child-ref parent-node (name replacement)))) + (when old + (detach old)))) + replacements) + (apply attach-to parent-node replacements)) + +(define-method (detach (node <node>)) + (let ((p (parent node))) + ;; Remove child from parent. + (set! (children p) (delq node (children p))) + ;; Remove from name index. + (when (name node) + (hashq-remove! (children-by-name p) (name node))) + (next-method))) + +(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/catbird/observer.scm b/catbird/observer.scm new file mode 100644 index 0000000..0cf01c5 --- /dev/null +++ b/catbird/observer.scm @@ -0,0 +1,37 @@ +(define-module (catbird observer) + #:use-module (catbird config) + #:use-module (oop goops) + #:export (<observer> + on-change)) + +;; This is a hack to deal with the fact that specializing GOOPS +;; accessors does not compose with inheritance. +;; +;; See +;; https://dthompson.us/issues-with-object-oriented-programming-in-guile.html +;; for details. + +(define-class <observer-slot-class> (<catbird-metaclass>)) + +(define-generic on-change) + +(define-method (observer-slot? (slot <slot>)) + (get-keyword #:observe? (slot-definition-options slot))) + +(define-method (compute-setter-method (class <observer-slot-class>) slot) + (if (observer-slot? slot) + ;; Wrap the original setter procedure with a new procedure that + ;; calls the on-change method. + (make <method> + #:specializers (list class <top>) + #:procedure (let ((slot-name (slot-definition-name slot)) + (proc (method-procedure (next-method)))) + (lambda (obj new) + (let ((old (and (slot-bound? obj slot-name) + (slot-ref obj slot-name)))) + (proc obj new) + (on-change obj slot-name old new))))) + (next-method))) + +(define-class <observer> () + #:metaclass <observer-slot-class>) diff --git a/catbird/overlay.scm b/catbird/overlay.scm new file mode 100644 index 0000000..31a1442 --- /dev/null +++ b/catbird/overlay.scm @@ -0,0 +1,116 @@ +(define-module (catbird overlay) + #:use-module (catbird kernel) + #:use-module (catbird input-map) + #:use-module (catbird minibuffer) + #:use-module (catbird node) + #:use-module (catbird node-2d) + #:use-module (catbird region) + #:use-module (catbird repl) + #:use-module (catbird scene) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics path) + #:use-module (chickadee graphics text) + #:use-module (chickadee math vector) + #:use-module (chickadee scripting) + #:use-module (ice-9 format) + #:use-module (oop goops) + #:export (make-overlay + notify + open-minibuffer)) + +(define %background-color (make-color 0.2 0.2 0.2 0.8)) + +(define-class <overlay> (<scene>)) + +(define (make-overlay) + (make <overlay>)) + +(define-method (notify (scene <overlay>) message) + (run-script scene + (let* ((padding 8.0) + (label (make <label> + #:name 'message + #:rank 1 + #:position (vec2 padding padding) + #:text message)) + (region (car (regions scene))) + (bg (make <canvas> + #:name 'background + #:painter + (with-style ((fill-color %background-color)) + (fill + (rounded-rectangle (vec2 0.0 0.0) + (+ (width label) padding padding) + (+ (height label) padding) + #:radius 2.0))))) + (notification (make <node-2d> + #:position (vec2 padding + (- (height (camera region)) + (height bg) + padding))))) + (attach-to notification bg label) + (attach-to scene notification) + (sleep 5.0) + (detach notification)))) + +(define-method (open-minibuffer) + (let ((r (find-region-by-name 'overlay))) + (push-major-mode (scene r) (make <minibuffer-mode>)))) + +(define-class <fps-display> (<node-2d>)) + +(define-method (on-boot (fps-display <fps-display>)) + (let* ((font (default-font)) + (padding 4.0) + (box-width (+ (font-line-width font "999.9") + (* padding 2.0))) + (box-height (+ (font-line-height font) padding))) + (attach-to fps-display + (make <canvas> + #:name 'background + #:painter + (with-style ((fill-color (make-color 0 0 0 0.5))) + (fill + (rectangle (vec2 0.0 0.0) + box-width + box-height)))) + (make <label> + #:name 'label + #:rank 1 + #:font font + #:position (vec2 padding padding))) + (set! (width fps-display) box-width) + (set! (height fps-display) box-height) + (set! (origin-y fps-display) box-height) + (update-fps fps-display) + (run-script fps-display + (forever + (sleep 1.0) + (update-fps fps-display))))) + +(define-method (update-fps (fps-display <fps-display>)) + (set! (text (& fps-display label)) + (format #f "~1,1f" (frames-per-second)))) + +(define-minibuffer-command show-fps + (let* ((r (find-region-by-name 'overlay)) + (s (and r (scene r)))) + (when (and s (not (& s fps-display))) + (attach-to s (make <fps-display> + #:name 'fps-display + #:rank 99 + #:position (vec2 0.0 (area-height r))))))) + +(define-minibuffer-command hide-fps + (let* ((r (find-region-by-name 'overlay)) + (s (and r (scene r))) + (f (and s (& s fps-display)))) + (when f (detach f)))) + +(define-minibuffer-command repl + (let* ((r (find-region-by-name 'overlay)) + (s (and r (scene r)))) + (when s + (push-major-mode s (make <repl-mode>))))) + +(bind-input/global (key-press 'x '(alt)) open-minibuffer) diff --git a/catbird/region.scm b/catbird/region.scm new file mode 100644 index 0000000..4ae4bc9 --- /dev/null +++ b/catbird/region.scm @@ -0,0 +1,102 @@ +(define-module (catbird region) + #:use-module (catbird camera) + #:use-module (catbird config) + #:use-module (catbird mixins) + #:use-module (catbird node) + #:use-module (catbird scene) + #:use-module (chickadee) + #:use-module (chickadee data array-list) + #:use-module (chickadee graphics engine) + #:use-module (chickadee graphics viewport) + #:use-module (chickadee math rect) + #:use-module (ice-9 exceptions) + #:use-module (oop goops) + #:export (<region> + make-region + area + area-x + area-y + area-width + area-height + camera + scene + replace-scene + push-scene + pop-scene) + #:re-export (name + rank + render + update)) + +(define-root-class <region> (<renderable> <updatable> <nameable> <rankable>) + (area #:accessor area #:init-keyword #:area) + (camera #:accessor camera #:init-keyword #:camera #:init-value #f) + (scene #:accessor scene #:init-keyword #:scene #:init-value #f) + (scene-stack #:getter scene-stack #:init-thunk make-array-list) + (viewport #:accessor viewport)) + +(define-method (area-x (region <region>)) + (rect-x (area region))) + +(define-method (area-y (region <region>)) + (rect-y (area region))) + +(define-method (area-width (region <region>)) + (rect-width (area region))) + +(define-method (area-height (region <region>)) + (rect-height (area region))) + +(define (float->int x) + (inexact->exact (round x))) + +(define-method (initialize (region <region>) args) + (next-method) + (let ((r (area region))) + (set! (viewport region) + (make-viewport (float->int (rect-x r)) + (float->int (rect-y r)) + (float->int (rect-width r)) + (float->int (rect-height r)))))) + +(define (make-region area name rank) + (let* ((window (current-window)) + (w (window-width window)) + (h (window-height window))) + (when (or (< (rect-left area) 0.0) + (< (rect-bottom area) 0.0) + (> (rect-right area) w) + (> (rect-top area) h)) + (raise-exception + (make-exception-with-message "region area exceeds window area"))) + (make <region> #:area area #:name name #:rank rank))) + +(define-method (replace-scene (r <region>) (new-scene <scene>)) + (let ((old-scene (scene r))) + (when old-scene (on-exit old-scene)) + (set! (scene r) new-scene) + (set! (regions new-scene) (cons r (regions new-scene))) + (on-enter new-scene))) + +(define-method (push-scene (region <region>) (new-scene <scene>)) + (let ((old-scene (scene region))) + (when old-scene + (array-list-push! (scene-stack region) old-scene)) + (replace-scene region new-scene))) + +(define-method (pop-scene (region <region>)) + (let ((stack (scene-stack region))) + (unless (array-list-empty? stack) + (replace-scene (array-list-pop! stack))))) + +(define-method (update (region <region>) dt) + (let ((s (scene region))) + (when s (update/around s dt)))) + +(define-method (render (region <region>) alpha) + (let ((s (scene region)) + (c (camera region))) + (when (and s c) + (parameterize ((current-camera c)) + (with-projection (projection-matrix (camera region)) + (render/around s alpha)))))) diff --git a/catbird/repl.scm b/catbird/repl.scm new file mode 100644 index 0000000..d3c2197 --- /dev/null +++ b/catbird/repl.scm @@ -0,0 +1,349 @@ +;; TODO: Multiple values +;; TODO: Multiple expressions +;; TODO: Debugger +;; TODO: Switching languages +(define-module (catbird repl) + #:use-module (catbird line-editor) + #:use-module (catbird kernel) + #:use-module (catbird mode) + #:use-module (catbird node) + #:use-module (catbird node-2d) + #:use-module (catbird region) + #:use-module (catbird ring-buffer) + #:use-module (catbird scene) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics path) + #:use-module (chickadee graphics text) + #:use-module (chickadee math vector) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (system base compile) + #:use-module (system base language) + #:export (<repl> + <repl-mode> + resize-repl)) + +(define %background-color (make-color 0.0 0.0 0.0 0.9)) + +(define (make-user-module) + (let ((module (resolve-module '(guile-user) #f))) + (beautify-user-module! module) + module)) + +(define-class <repl> (<node-2d>) + (language #:accessor language #:init-value (lookup-language 'scheme)) + (module #:accessor module #:init-thunk make-user-module) + (max-line-length #:accessor max-line-length #:init-value 256) + (log-lines #:accessor log-lines #:init-form (make-ring-buffer 64))) + +(define-method (on-boot (repl <repl>)) + (attach-to repl + (make <canvas> + #:name 'background) + (make <label> + #:name 'log + #:rank 1) + (make <line-editor> + #:name 'editor + #:rank 1)) + (log-append repl "Enter ',help' for help.") + (refresh-prompt repl)) + +(define-method (log-append (repl <repl>) line) + (ring-buffer-put! (log-lines repl) + ;; Truncate long lines + (if (> (string-length line) (max-line-length repl)) + (substring line 0 (max-line-length repl)) + line)) + (refresh-log repl)) + +(define-method (concatenate-log (repl <repl>)) + (let ((n (- (inexact->exact + (floor + (/ (height repl) + (font-line-height (font (& repl log)))))) + 1)) + (lines (log-lines repl))) + (string-join (let loop ((i (max (- (ring-buffer-length lines) n) 0))) + (if (< i (ring-buffer-length lines)) + (cons (ring-buffer-ref lines i) + (loop (+ i 1))) + '())) + "\n"))) + +(define-method (refresh-log (repl <repl>)) + (let ((log (& repl log))) + (set! (text log) (concatenate-log repl)) + (set! (position-y log) (- (height repl) (height log))) + (place-below log (& repl editor)))) + +(define-method (refresh-prompt (repl <repl>)) + (set! (prompt (& repl editor)) + (format #f "~a@~a> " + (language-name (language repl)) + (module-name (module repl))))) + +(define-method (resize-repl (repl <repl>) w h) + (set! (width repl) w) + (set! (height repl) h) + (set! (painter (& repl background)) + (with-style ((fill-color %background-color)) + (fill + (rectangle (vec2 0.0 0.0) w h)))) + (refresh-log repl)) + +(define-method (repl-read-expression (repl <repl>) line) + (call-with-input-string line + (lambda (port) + ((language-reader (language repl)) port (module repl))))) + +(define-method (with-output-to-log (repl <repl>) thunk) + (let* ((val *unspecified*) + (str (with-output-to-string + (lambda () + (set! val (thunk)))))) + (unless (string-null? str) + (for-each (lambda (line) + (log-append repl line)) + (string-split str #\newline))) + val)) + +(define-method (with-error-handling (repl <repl>) thunk) + (let ((stack #f)) + (define (handle-error e) + (let ((frame (stack-ref stack 0))) + (log-append repl + (format #f "~a: In procedure: ~a:" + (match (frame-source frame) + ((_ file-name line . column) + (format #f "~a:~a:~a" + (if file-name + (basename file-name) + "unknown file") + line column)) + (_ "unknown")) + (or (frame-procedure-name frame) + "unknown"))) + (log-append repl + (format #f "In procedure: ~a: ~a" + (or (and (exception-with-origin? e) + (exception-origin e)) + "unknown") + (if (and (exception-with-message? e) + (exception-with-irritants? e)) + (apply format #f (exception-message e) + (exception-irritants e)) + ""))) + (with-output-to-log repl + (lambda () + (display-backtrace stack + (current-output-port)))))) + (define (pre-unwind-handler . args) + (set! stack (make-stack #t 4))) + (define (throw-handler) + (with-throw-handler #t thunk pre-unwind-handler)) + (define (exception-handler e) + (if (quit-exception? e) + (raise-exception e) + (handle-error e))) + (with-exception-handler exception-handler throw-handler #:unwind? #t))) + +(define-method (repl-compile (repl <repl>) line) + (define (compile-line) + (with-output-to-log repl + (lambda () + (compile (repl-read-expression repl line) + #:from (language repl) + #:env (module repl))))) + (with-error-handling repl compile-line)) + +(define-method (write-value-to-log (repl <repl>) x) + (unless (unspecified? x) + (with-output-to-log repl (lambda () (write x))))) + +(define (skip-whitespace str i) + (let loop ((i i)) + (cond + ((= i (string-length str)) + (- i 1)) + ((char-whitespace? (string-ref str i)) + (loop (+ i 1))) + (else + i)))) + +(define (find-whitespace str i) + (let loop ((i i)) + (cond + ((= i (string-length str)) + i) + ((char-whitespace? (string-ref str i)) + i) + (else + (loop (+ i 1)))))) + +(define (meta-command-string? str) + (and (not (string-null? str)) + (eqv? (string-ref str (skip-whitespace str 0)) #\,))) + +(define (parse-meta-command str) + (let* ((i (skip-whitespace str 0)) + (j (find-whitespace str i))) + (cons (substring str i j) + (call-with-input-string (substring str j) + (lambda (port) + (let loop () + (let ((exp (read port))) + (if (eof-object? exp) + '() + (cons exp (loop)))))))))) + +(define-method (meta-command (repl <repl>) line) + (match (parse-meta-command line) + ((name args ...) + (let ((meta (lookup-meta-command name))) + (if meta + (with-error-handling repl + (lambda () + (apply-meta-command meta repl args))) + (log-append repl (string-append "Unknown meta-command: " name))))))) + +(define-method (repl-eval (repl <repl>)) + (let* ((editor (& repl editor)) + (line (get-line editor))) + (save-to-history editor) + (log-append repl (string-append (prompt editor) line)) + (if (meta-command-string? line) + (meta-command repl line) + (write-value-to-log repl (repl-compile repl line))) + (clear-line editor) + (refresh-log repl) + (refresh-prompt repl))) + + +;;; +;;; Meta commands +;;; + +(define-record-type <meta-command> + (make-meta-command name aliases category docstring proc) + meta-command? + (name meta-command-name) + (aliases meta-command-aliases) + (category meta-command-category) + (docstring meta-command-docstring) + (proc meta-command-proc)) + +(define (apply-meta-command meta repl args) + (apply (meta-command-proc meta) repl args)) + +(define *meta-commands* '()) + +(define (lookup-meta-command name) + (find (lambda (m) + (or (string=? (meta-command-name m) name) + (any (lambda (alias) + (string=? alias name)) + (meta-command-aliases m)))) + *meta-commands*)) + +(define (add-meta-command! name aliases category docstring proc) + (set! *meta-commands* + (cons (make-meta-command name aliases category docstring proc) + *meta-commands*))) + +(define (symbol->meta-command sym) + (string-append "," (symbol->string sym))) + +(define-syntax define-meta-command + (syntax-rules () + ((_ ((name aliases ...) category repl args ...) docstring body ...) + (add-meta-command! (symbol->meta-command 'name) + (map symbol->meta-command '(aliases ...)) + 'category + docstring + (lambda* (repl args ...) + body ...))) + ((_ (name category repl args ...) docstring body ...) + (add-meta-command! (symbol->meta-command 'name) + '() + 'category + docstring + (lambda* (repl args ...) + body ...))))) + +(define-meta-command (help help repl) + "- Show this help information." + (for-each (lambda (m) + (match (meta-command-aliases m) + (() + (log-append repl + (format #f "~a ~a" + (meta-command-name m) + (meta-command-docstring m)))) + (aliases + (log-append repl + (format #f "~a ~a ~a" + (meta-command-name m) + aliases + (meta-command-docstring m)))))) + (sort *meta-commands* + (lambda (a b) + (string<? (meta-command-name a) + (meta-command-name b)))))) + +(define-meta-command ((quit q) system repl) + "- Quit program." + (exit-catbird)) + +(define-meta-command ((import use) module repl module-name) + "MODULE - Import a module." + (module-use! (module repl) (resolve-module module-name))) + +(define-meta-command ((module m) module repl #:optional module-name) + "[MODULE] - Change current module or show current module." + (if module-name + (log-append repl (format #f "~a" (module-name (module repl)))) + (set! (module repl) (resolve-module module-name)))) + + +;;; +;;; REPL major mode +;;; + +(define-class <repl-mode> (<major-mode>) + (prev-keyboard-focus #:accessor prev-keyboard-focus #:init-value #f)) + +(define (repl mode) + (& (parent mode) repl)) + +(define-method (on-enter (mode <repl-mode>)) + (let* ((scene (parent mode)) + (region (car (regions scene))) + (repl (or (& (parent mode) repl) + (make <repl> + #:name 'repl)))) + (unless (parent repl) + (attach-to (parent mode) repl)) + (show repl) + (resize-repl repl (area-width region) (area-height region)) + (set! (prev-keyboard-focus mode) (current-keyboard-focus)) + (take-keyboard-focus region) + (add-minor-mode scene (make <line-edit-mode> + #:editor (& repl editor))))) + +(define-method (close-repl (mode <repl-mode>)) + (let ((scene (parent mode))) + (hide (& scene repl)) + (take-keyboard-focus (prev-keyboard-focus mode)) + (remove-minor-mode (parent mode) <line-edit-mode>) + (pop-major-mode scene))) + +(define-method (eval-expression (mode <repl-mode>)) + (repl-eval (repl mode))) + +(bind-input <repl-mode> (key-press 'escape) close-repl) +(bind-input <repl-mode> (key-press 'g '(ctrl)) close-repl) +(bind-input <repl-mode> (key-press 'return) eval-expression) diff --git a/catbird/ring-buffer.scm b/catbird/ring-buffer.scm new file mode 100644 index 0000000..ce265c0 --- /dev/null +++ b/catbird/ring-buffer.scm @@ -0,0 +1,64 @@ +(define-module (catbird ring-buffer) + #:use-module (srfi srfi-9) + #:export (make-ring-buffer + ring-buffer + ring-buffer-length + ring-buffer-put! + ring-buffer-get! + ring-buffer-ref + ring-buffer-clear!)) + +(define-record-type <ring-buffer> + (%make-ring-buffer vector length head tail) + ring-buffer? + (vector ring-buffer-vector) + (length ring-buffer-length set-ring-buffer-length!) + (head ring-buffer-head set-ring-buffer-head!) + (tail ring-buffer-tail set-ring-buffer-tail!)) + +(define (make-ring-buffer size) + (%make-ring-buffer (make-vector size #f) 0 0 0)) + +(define (ring-buffer-empty? ring) + (zero? (ring-buffer-length ring))) + +(define (ring-buffer-put! ring x) + (let* ((head (ring-buffer-head ring)) + (tail (ring-buffer-tail ring)) + (l (ring-buffer-length ring)) + (v (ring-buffer-vector ring)) + (vl (vector-length v))) + (vector-set! v tail x) + (set-ring-buffer-length! ring (min (+ l 1) vl)) + (when (and (> l 0) (= head tail)) + (set-ring-buffer-head! ring (modulo (+ head 1) vl))) + (set-ring-buffer-tail! ring (modulo (+ tail 1) vl)))) + +(define (ring-buffer-get! ring) + (if (ring-buffer-empty? ring) + (error "ring buffer empty" ring) + (let* ((head (ring-buffer-head ring)) + (v (ring-buffer-vector ring)) + (result (vector-ref v head))) + (vector-set! v head #f) + (set-ring-buffer-head! ring (modulo (+ head 1) (vector-length v))) + (set-ring-buffer-length! ring (- (ring-buffer-length ring) 1)) + result))) + +(define (ring-buffer-ref ring i) + (let ((l (ring-buffer-length ring)) + (v (ring-buffer-vector ring))) + (if (>= i l) + (error "ring buffer index out of bounds" i) + (vector-ref v (modulo (+ (ring-buffer-head ring) i) + (vector-length v)))))) + +(define (ring-buffer-clear! ring) + (let ((v (ring-buffer-vector ring))) + (set-ring-buffer-head! ring 0) + (set-ring-buffer-tail! ring 0) + (set-ring-buffer-length! ring 0) + (let loop ((i 0)) + (when (< i (vector-length v)) + (vector-set! v i #f) + (loop (+ i 1)))))) diff --git a/catbird/scene.scm b/catbird/scene.scm new file mode 100644 index 0000000..b46a176 --- /dev/null +++ b/catbird/scene.scm @@ -0,0 +1,147 @@ +(define-module (catbird scene) + #:use-module (catbird config) + #:use-module (catbird mixins) + #:use-module (catbird mode) + #:use-module (catbird node) + #:use-module (chickadee data array-list) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 format) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:export (<scene> + regions + major-mode + minor-modes + replace-major-mode + push-major-mode + pop-major-mode + add-minor-mode + remove-minor-mode)) + +(define-root-class <scene> (<node>) + (regions #:accessor regions #:init-value '()) + (major-mode #:accessor major-mode #:init-keyword #:major-mode + #:init-form (make <nothing-mode>)) + (major-mode-stack #:getter major-mode-stack #:init-thunk make-array-list) + (minor-modes #:accessor minor-modes #:init-value '()) + (input-map #:getter input-map #:init-value '())) + +(define-method (initialize (scene <scene>) args) + (next-method) + (attach (major-mode scene) scene)) + +(define-method (replace-major-mode (scene <scene>) (mode <major-mode>)) + (let ((old-mode (major-mode scene))) + (when old-mode + (detach old-mode)) + (set! (major-mode scene) mode) + (attach mode scene))) + +(define-method (push-major-mode (scene <scene>) (mode <major-mode>)) + (let ((old-mode (major-mode scene))) + (array-list-push! (major-mode-stack scene) old-mode) + (when old-mode + (pause old-mode)) + (set! (major-mode scene) mode) + (attach mode scene))) + +(define-method (pop-major-mode (scene <scene>)) + (let ((stack (major-mode-stack scene))) + (unless (array-list-empty? stack) + (let ((mode (major-mode scene)) + (prev-mode (array-list-pop! stack))) + (when mode + (detach mode)) + (set! (major-mode scene) prev-mode) + (resume prev-mode))))) + +(define-method (add-minor-mode (scene <scene>) (mode <minor-mode>)) + (when (parent mode) + (raise-exception + (make-exception-with-message "mode already attached to a scene"))) + (set! (minor-modes scene) (cons mode (minor-modes scene))) + (attach mode scene)) + +(define-method (remove-minor-mode (scene <scene>) (mode <minor-mode>)) + (unless (eq? scene (parent mode)) + (raise-exception + (make-exception-with-message "mode not attached to scene"))) + (let ((modes (minor-modes scene))) + (set! (minor-modes scene) (delq mode modes)) + (detach mode))) + +(define-method (remove-minor-mode (scene <scene>) (mode-class <class>)) + (let ((mode (find (lambda (mode) + (eq? (class-of mode) mode-class)) + (minor-modes scene)))) + (when mode + (remove-minor-mode scene mode)))) + +(define-method (search-modes (scene <scene>) proc) + (or (proc (major-mode scene)) + (find (lambda (mode) + (proc mode)) + (minor-modes scene)))) + +(define-method (on-key-press (scene <scene>) key modifiers) + (search-modes scene + (lambda (mode) + (on-key-press mode key modifiers)))) + +(define-method (on-key-release (scene <scene>) key modifiers) + (search-modes scene + (lambda (mode) + (on-key-release mode key modifiers)))) + +(define-method (on-text-input (scene <scene>) text) + (search-modes scene + (lambda (mode) + (on-text-input mode text)))) + +(define-method (on-mouse-press (scene <scene>) button x y) + (search-modes scene + (lambda (mode) + (on-mouse-press mode button x y)))) + +(define-method (on-mouse-release (scene <scene>) button x y) + (search-modes scene + (lambda (mode) + (on-mouse-release mode button x y)))) + +(define-method (on-mouse-move (scene <scene>) x y x-rel y-rel buttons) + (search-modes scene + (lambda (mode) + (on-mouse-move mode x y x-rel y-rel buttons)))) + +(define-method (on-mouse-wheel (scene <scene>) x y) + (search-modes scene + (lambda (mode) + (on-mouse-wheel mode x y)))) + +(define-method (on-controller-press (scene <scene>) controller-id button) + (search-modes scene + (lambda (mode) + (on-controller-press mode controller-id button)))) + +(define-method (on-controller-release (scene <scene>) controller-id button) + (search-modes scene + (lambda (mode) + (on-controller-release mode controller-id button)))) + +(define-method (on-controller-move (scene <scene>) controller-id axis value) + (search-modes scene + (lambda (mode) + (on-controller-move mode controller-id axis value)))) + +(define-method (update (scene <scene>) dt) + (update (major-mode scene) dt) + (for-each (lambda (mode) (update mode dt)) + (minor-modes scene))) + +(define-method (pause (scene <scene>)) + (for-each-child pause scene) + (next-method)) + +(define-method (resume (scene <scene>)) + (for-each-child resume scene) + (next-method)) diff --git a/configure.ac b/configure.ac index c489791..bddce86 100644 --- a/configure.ac +++ b/configure.ac @@ -9,6 +9,7 @@ AM_SILENT_RULES([yes]) AC_PATH_PROG([GUILE], [guile]) AC_CONFIG_FILES([Makefile]) AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env]) +AC_CONFIG_FILES([test-env], [chmod +x test-env]) GUILE_PKG([3.0 2.2]) GUILE_PROGS @@ -117,7 +117,7 @@ SDL2 C shared library via the foreign function interface.") (license license:lgpl3+)))) (define chickadee - (let ((commit "5ed490cac58d9f548bc141cc334c25dea9bfcaf2")) + (let ((commit "5edce04c698cd92149004ead1cad77c481c682e8")) (package (name "chickadee") (version (string-append "0.8.0-1." (string-take commit 7))) @@ -128,7 +128,7 @@ SDL2 C shared library via the foreign function interface.") (commit commit))) (sha256 (base32 - "1wq1v19qp2q31ybjqzw0xccyw5v03hh9y79z8rjd6l83vbp1nvkx")))) + "1hckx827aw3af8cbw1mfjy57wdssv1q3bs2hziymxddipwa0d425")))) (build-system gnu-build-system) (arguments '(#:make-flags '("GUILE_AUTO_COMPILE=0") diff --git a/pre-inst-env.in b/pre-inst-env.in index 0d3b6a4..06cb204 100644 --- a/pre-inst-env.in +++ b/pre-inst-env.in @@ -30,6 +30,5 @@ then fi export PATH="$abs_top_builddir/scripts:$PATH" -export STARLING_DEV_MODE="1" exec "$@" diff --git a/test-env.in b/test-env.in new file mode 100644 index 0000000..1ab197a --- /dev/null +++ b/test-env.in @@ -0,0 +1,5 @@ +#!/bin/sh + +"@abs_top_builddir@/pre-inst-env" "$@" + +exit $? diff --git a/tests/node.scm b/tests/node.scm new file mode 100644 index 0000000..6cdd223 --- /dev/null +++ b/tests/node.scm @@ -0,0 +1,7 @@ +(define-module (tests node) + #:use-module (catbird node) + #:use-module (srfi srfi-64) + #:use-module (tests utils)) + +(with-tests "node" + #t) diff --git a/tests/scene.scm b/tests/scene.scm new file mode 100644 index 0000000..20a8301 --- /dev/null +++ b/tests/scene.scm @@ -0,0 +1,7 @@ +(define-module (tests scene) + #:use-module (catbird scene) + #:use-module (srfi srfi-64) + #:use-module (tests utils)) + +(with-tests "scene" + #t) diff --git a/tests/utils.scm b/tests/utils.scm new file mode 100644 index 0000000..b05f70c --- /dev/null +++ b/tests/utils.scm @@ -0,0 +1,9 @@ +(define-module (tests utils) + #:use-module (srfi srfi-64) + #:export (with-tests)) + +(define-syntax-rule (with-tests name body ...) + (begin + (test-begin name) + body ... + (exit (zero? (test-runner-fail-count (test-end)))))) |