summaryrefslogtreecommitdiff
path: root/catbird/asset.scm
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2022-10-03 19:22:23 -0400
committerDavid Thompson <dthompson2@worcester.edu>2022-10-22 11:48:39 -0400
commit14464dee966fe415d4c8e1fb8b5205653b22003f (patch)
tree986a7b03a089a4545465901cadce4d671f3032c1 /catbird/asset.scm
parentdcf869ccd7ec9d33c937507fe96e9e09f517bded (diff)
Add prototype catbird modules.
Diffstat (limited to 'catbird/asset.scm')
-rw-r--r--catbird/asset.scm241
1 files changed, 241 insertions, 0 deletions
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))))