diff options
| -rw-r--r-- | starling/asset.scm | 31 | ||||
| -rw-r--r-- | starling/node-2d.scm | 22 | ||||
| -rw-r--r-- | starling/node.scm | 56 |
3 files changed, 90 insertions, 19 deletions
diff --git a/starling/asset.scm b/starling/asset.scm index c1a05a1..8ddf945 100644 --- a/starling/asset.scm +++ b/starling/asset.scm @@ -32,7 +32,10 @@ artifact file-name loader - args + loader-args + on-asset-reload + add-subscriber + remove-subscriber watch-assets watching-assets? watch-asset-directory @@ -57,7 +60,8 @@ (file-name #:getter file-name #:init-keyword #:file-name) (loader #:getter loader #:init-keyword #:loader) (loader-args #:getter loader-args #:init-form '() - #:init-keyword #:loader-args)) + #:init-keyword #:loader-args) + (subscribers #:getter subscribers #:init-form (make-weak-key-hash-table))) (define (absolute-file-name file-name) (if (absolute-file-name? file-name) @@ -80,6 +84,23 @@ wt)))) (hash-set! sub-table asset asset))) +(define-method (on-asset-reload obj slot-name) + #t) + +(define-method (add-subscriber (asset <asset>) obj slot-name) + (let ((subs (subscribers asset))) + (hashq-set! subs obj (cons slot-name (hashq-ref subs obj '()))))) + +(define-method (remove-subscriber (asset <asset>) obj slot-name) + (let* ((subs (subscribers asset)) + (slot-names (delq slot-name (hashq-ref subs obj '())))) + (if (null? slot-names) + (hashq-remove! subs obj) + (hashq-set! subs obj slot-names)))) + +(define-method (notify-subscribers (asset <asset>)) + (hash-for-each on-asset-reload (subscribers asset))) + (define-method (asset-purge (asset <asset>)) (hash-remove! (hash-ref (asset-file-map) (file-name asset)) asset)) @@ -151,7 +172,8 @@ (expire-cached-artifact (cache-key asset))) assets) (hash-for-each (lambda (key asset) - (load! asset)) + (load! asset) + (notify-subscribers asset)) assets)))))))) (define (cache-key asset) @@ -192,9 +214,6 @@ (or (hashq-ref (asset-artifact-map) asset) (load! asset #t))) -;; Make assets that are outside of the cache "just work". -(define-method (asset-ref x) x) - ;; Handy syntax for defining new assets. (define-syntax-rule (define-asset name (loader file-name loader-args ...)) diff --git a/starling/node-2d.scm b/starling/node-2d.scm index d54edf9..576cc3f 100644 --- a/starling/node-2d.scm +++ b/starling/node-2d.scm @@ -434,13 +434,13 @@ (define-generic texture) (define-method (texcoords (sprite <base-sprite>)) - (texture-gl-tex-rect (asset-ref (texture sprite)))) + (texture-gl-tex-rect (texture sprite))) (define-method (source-rect (sprite <base-sprite>)) - (texture-gl-rect (asset-ref (texture sprite)))) + (texture-gl-rect (texture sprite))) (define-method (render (sprite <base-sprite>) alpha) - (let* ((tex (asset-ref (texture sprite))) + (let* ((tex (texture sprite)) (rect (source-rect sprite)) (batch (batch sprite)) (tint (tint sprite)) @@ -459,7 +459,7 @@ ;;; (define-class <sprite> (<base-sprite>) - (texture #:getter texture #:init-keyword #:texture) + (texture #:getter texture #:init-keyword #:texture #:asset? #t) (texcoords #:init-keyword #:texcoords #:init-form #f) (source-rect #:init-keyword #:source-rect #:init-form #f)) @@ -477,11 +477,11 @@ ;;; (define-class <atlas-sprite> (<base-sprite>) - (atlas #:accessor atlas #:init-keyword #:atlas) + (atlas #:accessor atlas #:init-keyword #:atlas #:asset? #t) (index #:accessor index #:init-keyword #:index)) (define-method (texture (sprite <atlas-sprite>)) - (texture-atlas-ref (asset-ref (atlas sprite)) (index sprite))) + (texture-atlas-ref (atlas sprite) (index sprite))) ;;; @@ -566,7 +566,7 @@ ;;; (define-class <label> (<node-2d>) - (font #:accessor font #:init-keyword #:font #:init-thunk default-font) + (font #:accessor font #:init-keyword #:font #:init-thunk default-font #:asset? #t) (text #:accessor text #:init-form "" #:init-keyword #:text) (align #:accessor align #:init-value 'left #:init-keyword #:align) (vertical-align #:accessor vertical-align #:init-value 'bottom @@ -581,7 +581,7 @@ (realign label)) (define-method (realign (label <label>)) - (let ((font (asset-ref (font label)))) + (let ((font (font label))) (set-vec2! (origin label) (match (align label) ('left 0.0) @@ -594,7 +594,7 @@ (dirty! label)) (define-method (render (label <label>) alpha) - (draw-text* (asset-ref (font label)) (text label) (world-matrix label))) + (draw-text* (font label) (text label) (world-matrix label))) ;;; @@ -602,14 +602,14 @@ ;;; (define-class <tile-map> (<node-2d>) - (tile-map #:accessor tile-map #:init-keyword #:map) + (tile-map #:accessor tile-map #:init-keyword #:map #:asset? #t) (layers #:accessor layers #:init-keyword #:layers #:init-form #f)) (define-method (initialize (node <tile-map>) initargs) (next-method)) (define-method (render (node <tile-map>) alpha) - (let ((m (asset-ref (tile-map node)))) + (let ((m (tile-map node))) (draw-tile-map* m (world-matrix node) (tile-map-rect m) #:layers (layers node)))) diff --git a/starling/node.scm b/starling/node.scm index 6ddcd2c..58896b8 100644 --- a/starling/node.scm +++ b/starling/node.scm @@ -23,6 +23,7 @@ (define-module (starling node) #:use-module (chickadee scripting) #:use-module (oop goops) + #:use-module (starling asset) #:use-module (starling config) #:export (<node> name @@ -60,6 +61,54 @@ blink) #:replace (pause)) +(define-class <meta-node> (<class>)) + +(define-method (asset-slot? (slot <slot>)) + (get-keyword #:asset? (slot-definition-options slot))) + +(define-method (compute-getter-method (class <meta-node>) slot) + (if (asset-slot? slot) + (make <method> + #:specializers (list class) + #:procedure (let ((slot-name (slot-definition-name slot))) + (lambda (obj) + (let ((value (slot-ref obj slot-name))) + (if (is-a? value <asset>) + (asset-ref value) + value))))) + (next-method))) + + +(define-class <developer-meta-node> (<meta-node> <redefinable-class>)) + +(define-method (compute-setter-method (class <developer-meta-node>) slot) + (if (asset-slot? slot) + (make <method> + #:specializers (list class <top>) + #:procedure (let ((slot-name (slot-definition-name slot))) + (lambda (obj new) + (let ((old (and (slot-bound? obj slot-name) + (slot-ref obj slot-name)))) + (when (is-a? old <asset>) + (remove-subscriber old obj slot-name)) + (when (is-a? new <asset>) + (add-subscriber new obj slot-name)) + (slot-set! obj slot-name new))))) + (next-method))) + +(define-method (make (class <developer-meta-node>) . initargs) + (let ((instance (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 (and (slot-bound? instance slot-name) + (slot-ref instance slot-name)))) + (when (is-a? value <asset>) + (add-subscriber value instance slot-name))))) + (class-slots class)) + instance)) + (define-class <node> () ;; Auto-generated process-unique identifier. As of now I don't see ;; a need for globally unique identifiers and this is much faster. @@ -92,8 +141,8 @@ (paused? #:accessor paused? #:init-form #f #:init-keyword #:paused?) ;; Use redefinable classes when in dev mode. #:metaclass (if developer-mode? - <redefinable-class> - <class>)) + <developer-meta-node> + <meta-node>)) (define-method (initialize (node <node>) initargs) (next-method) @@ -148,6 +197,9 @@ represented as a ratio in the range [0, 1]." "Perform task now that NODE has left the current scene." #t) +(define-method (on-asset-reload (node <node>) slot-name asset) + #t) + ;;; ;;; Life cycle state management |