diff options
| -rw-r--r-- | starling/node-2d.scm | 30 | ||||
| -rw-r--r-- | starling/node.scm | 19 |
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>)) |