summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--starling/asset.scm31
-rw-r--r--starling/node-2d.scm22
-rw-r--r--starling/node.scm56
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