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. --- catbird/asset.scm | 241 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 241 insertions(+) create mode 100644 catbird/asset.scm (limited to 'catbird/asset.scm') 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)))) -- cgit v1.2.3