diff options
Diffstat (limited to 'test-subject/device.scm')
-rw-r--r-- | test-subject/device.scm | 42 |
1 files changed, 42 insertions, 0 deletions
diff --git a/test-subject/device.scm b/test-subject/device.scm new file mode 100644 index 0000000..b15f270 --- /dev/null +++ b/test-subject/device.scm @@ -0,0 +1,42 @@ +(define-module (test-subject device) + #:use-module (chickadee graphics color) + #:use-module (chickadee graphics texture) + #:use-module (oop goops) + #:use-module (starling gui) + #:use-module (starling node) + #:use-module (starling node-2d) + #:export (<device>)) + +(define %device-hover-tint (rgb #xff7777)) + +;; An object you can interact with by clicking. +(define-class <device> (<margin-container>) + (texture #:accessor texture #:init-keyword #:texture + #:init-value null-texture #:watch? #t)) + +(define-method (refresh-hover-state (device <device>)) + ;; A crude way of showing the user something is clickable. + (set! (tint (& device sprite)) + (if (hover? device) + %device-hover-tint + white))) + +(define-method (on-change (device <device>) slot-name old new) + (case slot-name + ((hover?) + (refresh-hover-state device)) + ((texture) + (let ((sprite (& device sprite))) + (when sprite + (set! (texture sprite) new)))) + (else + (next-method)))) + +(define-method (apply-theme (device <device>)) + (next-method) + (replace device + (make <sprite> + #:name 'sprite + #:rank 1 + #:texture (texture device))) + (refresh-hover-state device)) |