From 7ea3e69142f3a9f4d843f9afcad593d7c7a972f0 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Fri, 29 Jan 2021 21:01:16 -0500
Subject: Make asset access transparent and add reload handler method.

---
 starling/asset.scm   | 31 +++++++++++++++++++++++------
 starling/node-2d.scm | 22 ++++++++++-----------
 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
-- 
cgit v1.2.3