Add watchable slots to <meta-node> metaclass.

2 files changed, 32 insertions, 17 deletions

diff --git a/starling/node-2d.scm b/starling/node-2d.scm
index 8ff7623..43e073e 100644
--- a/starling/node-2d.scm
+++ b/starling/node-2d.scm
@@ -453,8 +453,8 @@
 ;;;
 
 (define-class <atlas-sprite> (<sprite>)
-  (atlas #:accessor atlas #:init-keyword #:atlas #:asset? #t)
-  (index #:accessor index #:init-keyword #:index))
+  (atlas #:accessor atlas #:init-keyword #:atlas #:asset? #t #:watch? #t)
+  (index #:accessor index #:init-keyword #:index #:init-value 0 #:watch? #t))
 
 (define-method (sync-texture (sprite <atlas-sprite>))
   (set! (texture sprite) (texture-atlas-ref (atlas sprite) (index sprite))))
@@ -463,12 +463,7 @@
   (next-method)
   (sync-texture sprite))
 
-(define-method ((setter atlas) (sprite <atlas-sprite>) atlas)
-  (slot-set! sprite 'atlas atlas)
-  (sync-texture sprite))
-
-(define-method ((setter index) (sprite <atlas-sprite>) i)
-  (slot-set! sprite 'index i)
+(define-method (on-change (sprite <atlas-sprite>) slot-name old new)
   (sync-texture sprite))
 
 
@@ -481,7 +476,7 @@
   (frame-duration #:getter frame-duration #:init-keyword #:frame-duration
                   #:init-form 250))
 
-(define-class <animated-sprite> (<sprite>)
+(define-class <animated-sprite> (<atlas-sprite>)
   (atlas #:accessor atlas #:init-keyword #:atlas #:asset? #t)
   (animations #:accessor animations #:init-keyword #:animations)
   (current-animation #:accessor current-animation
@@ -500,7 +495,8 @@
          (time (mod (- (elapsed-time) (start-time sprite)) anim-duration))
          (frame (vector-ref frames (inexact->exact
                                     (floor (/ time frame-duration))))))
-    (set! (texture sprite) (texture-atlas-ref (atlas sprite) frame))))
+    (when (not (= frame (index sprite)))
+      (set! (index sprite) frame))))
 
 (define-method (change-animation (sprite <animated-sprite>) name)
   (set! (current-animation sprite) name)
@@ -534,16 +530,17 @@
 ;;;
 
 (define-class <path> (<node-2d>)
-  (painter #:accessor painter #:init-keyword #:painter)
+  (painter #:accessor painter #:init-keyword #:painter #:watch? #t)
   (canvas #:accessor canvas #:init-thunk make-empty-canvas))
 
 (define-method (initialize (path <path>) args)
   (next-method)
   (set-canvas-painter! (canvas path) (painter path)))
 
-(define-method ((setter painter) (path <path>) p)
-  (slot-set! path 'painter p)
-  (set-canvas-painter! (canvas path) p))
+(define-method (on-change (path <path>) slot-name old new)
+  (pk 'change slot-name old new)
+  (when (eq? slot-name 'painter)
+    (set-canvas-painter! (canvas path) new)))
 
 (define-method (render (path <path>) alpha)
   (draw-canvas* (canvas path) (world-matrix path)))
@@ -555,7 +552,7 @@
 
 (define-class <label> (<node-2d>)
   (font #:accessor font #:init-keyword #:font #:init-thunk default-font #:asset? #t)
-  (text #:accessor text #:init-form "" #:init-keyword #:text)
+  (text #:accessor text #:init-form "" #:init-keyword #:text #:watch? #t)
   (align #:accessor align #:init-value 'left #:init-keyword #:align)
   (vertical-align #:accessor vertical-align #:init-value 'bottom
                   #:init-keyword #:vertical-align))
@@ -564,8 +561,7 @@
   (next-method)
   (realign label))
 
-(define-method ((setter text) (label <label>) s)
-  (slot-set! label 'text s)
+(define-method (on-change (label <label>) slot-name old new)
   (realign label))
 
 (define-method (realign (label <label>))
diff --git a/starling/node.scm b/starling/node.scm
index 8e16c4f..578ce2c 100644
--- a/starling/node.scm
+++ b/starling/node.scm
@@ -36,6 +36,7 @@
             visible?
             paused?
             for-each-child
+            on-change
             on-boot
             on-enter
             on-exit
@@ -66,6 +67,9 @@
 (define-method (asset-slot? (slot <slot>))
   (get-keyword #:asset? (slot-definition-options slot)))
 
+(define-method (watch-slot? (slot <slot>))
+  (get-keyword #:watch? (slot-definition-options slot)))
+
 (define-method (compute-getter-method (class <meta-node>) slot)
   (if (asset-slot? slot)
       (make <method>
@@ -78,6 +82,21 @@
                               value)))))
       (next-method)))
 
+(define-generic on-change)
+
+(define-method (compute-setter-method (class <meta-node>) slot)
+  (let ((method (next-method)))
+    (if (watch-slot? slot)
+        (let ((slot-name (slot-definition-name slot))
+              (proc (method-procedure method)))
+          (make <method>
+            #:specializers (list class <top>)
+            #:procedure (lambda (obj new)
+                          (let ((old (and (slot-bound? obj slot-name)
+                                          (slot-ref obj slot-name))))
+                            (proc obj new)
+                            (on-change obj slot-name old new)))))
+        method)))
 
 (define-class <developer-meta-node> (<meta-node> <redefinable-class>))