summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson@vistahigherlearning.com>2021-03-16 17:11:43 -0400
committerDavid Thompson <dthompson@vistahigherlearning.com>2021-03-16 17:11:43 -0400
commitd6d3bede2aed711d906d82c86ea5ddb410e41549 (patch)
tree8615e832e5c318192a78dd060f4f4b06aafef471
parentda469076e61e8d25e8af57a0d214cb3a664eee7d (diff)
Add watchable slots to <meta-node> metaclass.
-rw-r--r--starling/node-2d.scm30
-rw-r--r--starling/node.scm19
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>))