blob: b15f270aee4c88f0d1aba40464554bc43b87d130 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
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))
|
