From 14464dee966fe415d4c8e1fb8b5205653b22003f Mon Sep 17 00:00:00 2001 From: David Thompson Date: Mon, 3 Oct 2022 19:22:23 -0400 Subject: Add prototype catbird modules. --- .gitignore | 1 + Makefile.am | 40 +- catbird/asset.scm | 241 ++++++++++++ catbird/cached-slots.scm | 88 +++++ catbird/camera.scm | 113 ++++++ catbird/config.scm | 16 + catbird/inotify.scm | 197 ++++++++++ catbird/input-map.scm | 175 +++++++++ catbird/kernel.scm | 394 ++++++++++++++++++++ catbird/line-editor.scm | 312 ++++++++++++++++ catbird/minibuffer.scm | 157 ++++++++ catbird/mixins.scm | 195 ++++++++++ catbird/mode.scm | 105 ++++++ catbird/node-2d.scm | 939 +++++++++++++++++++++++++++++++++++++++++++++++ catbird/node.scm | 160 ++++++++ catbird/observer.scm | 37 ++ catbird/overlay.scm | 116 ++++++ catbird/region.scm | 102 +++++ catbird/repl.scm | 349 ++++++++++++++++++ catbird/ring-buffer.scm | 64 ++++ catbird/scene.scm | 147 ++++++++ configure.ac | 1 + guix.scm | 4 +- pre-inst-env.in | 1 - test-env.in | 5 + tests/node.scm | 7 + tests/scene.scm | 7 + tests/utils.scm | 9 + 28 files changed, 3965 insertions(+), 17 deletions(-) create mode 100644 catbird/asset.scm create mode 100644 catbird/cached-slots.scm create mode 100644 catbird/camera.scm create mode 100644 catbird/config.scm create mode 100644 catbird/inotify.scm create mode 100644 catbird/input-map.scm create mode 100644 catbird/kernel.scm create mode 100644 catbird/line-editor.scm create mode 100644 catbird/minibuffer.scm create mode 100644 catbird/mixins.scm create mode 100644 catbird/mode.scm create mode 100644 catbird/node-2d.scm create mode 100644 catbird/node.scm create mode 100644 catbird/observer.scm create mode 100644 catbird/overlay.scm create mode 100644 catbird/region.scm create mode 100644 catbird/repl.scm create mode 100644 catbird/ring-buffer.scm create mode 100644 catbird/scene.scm create mode 100644 test-env.in create mode 100644 tests/node.scm create mode 100644 tests/scene.scm create mode 100644 tests/utils.scm diff --git a/.gitignore b/.gitignore index 6494a33..2891512 100644 --- a/.gitignore +++ b/.gitignore @@ -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 ( + file-names + loader + artifact + subscribers + load! + ->asset + subscribe + unsubscribe + on-asset-refresh + define-asset + reload-modified-assets + + )) + +(define (absolute-file-name file-name) + (if (absolute-file-name? file-name) + file-name + (string-append (getcwd) "/" file-name))) + + +;;; +;;; Base Asset +;;; + +(define-root-class () + (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 ) 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 + #:file-names '() + #:loader (lambda () x))) + +(define-method (->asset (asset )) + asset) + +(define-method (subscribe (asset ) obj context) + (let ((subs (subscribers asset))) + (hashq-set! subs obj (cons context (hashq-ref subs obj '()))))) + +(define-method (unsubscribe (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 )) + (hash-for-each (lambda (subscriber contexts) + (for-each (lambda (context) + (on-asset-refresh subscriber context)) + contexts)) + (subscribers asset))) + +(define-method (load! (asset )) + (let ((value (apply (loader asset) (file-names asset)))) + (set! (%artifact asset) value) + (notify-refresh asset) + value)) + +(define-method (reload! (asset )) + (load! asset)) + +(define-method (unload! (asset )) + (set! (%artifact asset) #f)) + +(define-method (artifact (asset )) + (or (%artifact asset) + (load! asset))) + + +;;; +;;; Auto-reloading Asset +;;; + +(define-class () + ;; 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 'inotify))) + +(define (auto-reload-assets) + (class-slot-ref 'assets)) + +(define (register-auto-reload-asset! asset) + (hashq-set! (auto-reload-assets) asset #t)) + +(define-method (load! (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 )) + (begin + (initialize name + #:file-names file-names + #:loader proc) + name) + (make (if developer-mode? ) + #:file-names file-names + #:loader proc))))) + + +;;; +;;; Asset Metaclass +;;; + +(define-class ()) + +(define-method (asset-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 ) slot) + (if (asset-slot? slot) + ;; Wrap the original getter procedure with a new procedure that + ;; extracts the current value from the asset object. + (make + #: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 ) slot) + (if (asset-slot? slot) + ;; Wrap the original setter procedure with a new procedure that + ;; manages asset update notifications. + (make + #:specializers (list class ) + #: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 ) + value + (let ((asset (->asset value))) + (slot-set! obj slot-name asset) + asset)))) + +(define-class () + #:metaclass ) + +(define-method (initialize (instance ) 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 ( + slot-expired? + expire-slot!)) + +(define-record-type + (%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 ()) + +(define (slot-ref* obj slot-name) + (and (slot-bound? obj slot-name) + (slot-ref obj slot-name))) + +(define-method (cached-slot? (slot )) + (get-keyword #:cached? (slot-definition-options slot))) + +(define-method (slot-refresh-proc (slot )) + (get-keyword #:refresh (slot-definition-options slot))) + +(define-method (compute-getter-method (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 + #: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 ) slot) + (if (cached-slot? slot) + (make + #:specializers (list class ) + #:procedure (lambda (obj new) + (raise-exception + (make-exception-with-message "cached slots cannot be set")))) + (next-method))) + +(define-class () + #:metaclass ) + +(define-method (initialize (instance ) 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 ( + projection-matrix + view-matrix + width + height + current-camera + + + view-bounding-box + move-to + move-by + + + field-of-vision + near-clip + far-clip + direction + up)) + +(define-root-class () + (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 ) args) + (next-method) + (refresh-projection camera) + (refresh-view camera)) + +(define current-camera (make-parameter #f)) + + +;;; +;;; 2D Camera +;;; + +(define-class ( ) + (view-bounding-box #:accessor view-bounding-box #:init-thunk make-null-rect)) + +(define-method (initialize (camera ) 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 )) + (orthographic-projection! (projection-matrix camera) + 0.0 (width camera) + (height camera) 0.0 + 0.0 1.0)) + +(define-method (refresh-view (camera )) + (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 ) p) + (vec2-copy! p (position camera)) + (refresh-view camera)) + +(define-method (move-by (camera ) d) + (vec2-add! (position camera) d) + (refresh-view camera)) + + +;;; +;;; 3D Camera +;;; + +(define-class ( ) + (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 )) + (perspective-projection! (projection-matrix camera) + (field-of-vision camera) + (/ (width camera) (height camera)) + (near-clip camera) + (far-clip camera))) + +(define-method (refresh-view (camera )) + (look-at! (view-matrix camera) + (position camera) + (direction camera) + (up camera))) + +(define-method (move-to (camera ) p) + (vec3-copy! p (position camera)) + (refresh-view camera)) + +(define-method (move-by (camera ) 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? + + define-root-class)) + +(define developer-mode? + (equal? (getenv "CATBIRD_DEV_MODE") "1")) + +(define + (if developer-mode? )) + +(define-syntax-rule (define-root-class name (supers ...) args ...) + (define-class name (supers ...) + args ... + #: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 + (%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 + (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 + (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 inotify))) + +(define (display-inotify-watch watch port) + (format port "#" + (inotify-watch-id watch) + (inotify-watch-file-name watch))) + +(define (display-inotify-event event port) + (format port "#" + (inotify-event-type event) + (inotify-event-cookie event) + (inotify-event-file-name event) + (inotify-event-watch event))) + +(set-record-type-printer! display-inotify) +(set-record-type-printer! display-inotify-watch) +(set-record-type-printer! 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 () + (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 )) + (when developer-mode? + (set! (repl kernel) (spawn-coop-repl-server)))) + +;; Add the system notification and debugging overlay. +(define-method (add-overlay (kernel )) + (let ((region (create-full-region #:name 'overlay #:rank 9999))) + (set! (camera region) + (make + #: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 )) + (scene (lookup-region kernel 'overlay))) + +(define-method (notify (kernel ) message) + (let ((notify (module-ref (resolve-module '(catbird overlay)) 'notify))) + (notify (overlay-scene kernel) message))) + +(define-method (update (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 ) 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 ) region-name) + (find (lambda (region) + (eq? (name region) region-name)) + (regions kernel))) + +(define-method (add-region (kernel ) (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 ) spec handler) + (set! (input-map kernel) (add-input (input-map kernel) spec handler))) + +(define-method (unbind-input (kernel ) spec) + (set! (input-map kernel) (remove-input (input-map kernel) spec))) + + +;;; +;;; Keyboard +;;; + +(define-method (on-key-press (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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 )) + (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 ) 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 ) 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 ) 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 ) 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 ) 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 ) 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 ))) + (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 ( + + 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 () + (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 ) slot old new) + (update-visual editor)) + +(define-method (on-boot (editor )) + (attach-to editor + (make