blob: 1c546ba2e13b822d50989b4a31ae6675809e5e59 (
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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
;;;; button.lisp
(in-package #:wheelwork)
(defclass/std button (unit interactive)
((up down :with
:std (error "UP and DOWN lots are required")
:doc "Any affine renderable unit")
(bg :with)
(on-press on-release :doc "Function accepting the button."))
(:documentation "A basic button class. The UP and DOWN slots should
be filled with renderable objects having the same size."))
(defhandler button-released
(on-mouseup ()
(with-slots (up down on-release) target
(setf (unit-visiblep up) t
(unit-visiblep down) nil)
(when on-release
(funcall on-release target)))))
(defhandler button-pressed
(on-mousedown ()
(with-slots (up down on-press) target
(setf (unit-visiblep up) nil
(unit-visiblep down) t)
(when on-press
(funcall on-press target)))))
(defmethod initialize-instance :after ((button button) &key)
(add-handler button #'button-pressed)
(add-handler button #'button-released)
(with-slots (up down bg) button
(when bg
(setf (unit-container bg) button
(unit-visiblep bg) t))
(setf (unit-visiblep down) nil
(unit-visiblep up) t
(unit-container up) button
(unit-container down) button)))
(defmethod cleanup ((button button))
(with-slots (up down bg) button
(when bg (cleanup bg))
(cleanup up)
(cleanup down)))
(defmethod render ((button button))
(with-slots (up down bg) button
(when bg (render bg))
(if (unit-visiblep up)
(render up)
(render down))))
(defmethod x ((button button))
(x (button-up button)))
(defmethod (setf x) (newval (button button))
(with-slots (up down bg) button
(when bg
(setf (x bg) newval))
(setf (x up) newval
(x down) newval)))
(defmethod y ((button button))
(y (button-up button)))
(defmethod (setf y) (newval (button button))
(with-slots (up down bg) button
(when bg
(setf (y bg) newval))
(setf (y up) newval
(y down) newval)))
(defmethod scale-x ((thing button))
(scale-x (button-up thing)))
(defmethod (setf scale-x) (newval (button button))
(with-slots (up down bg) button
(when bg
(setf (scale-x bg) newval))
(setf (scale-x up) newval
(scale-x down) newval)))
(defmethod scale-y ((thing button))
(scale-y (button-up thing)))
(defmethod (setf scale-y) (newval (button button))
(with-slots (up down bg) button
(when bg
(setf (scale-y bg) newval))
(setf (scale-y up) newval
(scale-y down) newval)))
(defmethod rotation ((thing button))
(rotation (button-up thing)))
(defmethod (setf rotation) (newval (button button))
(with-slots (up down bg) button
(when bg
(setf (rotation bg) newval))
(setf (rotation up) newval
(rotation down) newval)))
(defmethod width ((thing button))
(width (button-up thing)))
(defmethod (setf width) (newval (button button))
(with-slots (up down bg) button
(when bg
(setf (width bg) newval))
(setf (width up) newval
(width down) newval)))
(defmethod height ((thing button))
(height (button-up thing)))
(defmethod (setf height) (newval (button button))
(with-slots (up down bg) button
(when bg
(setf (height bg) newval))
(setf (height up) newval
(height down) newval)))
(defun make-texture-button (up down &key pressed released)
"UP and DOWN should be strings naming assets to use as the up and
down images for the button."
(make-instance
'button
:on-press pressed :on-release released
:up (make-instance 'bitmap :texture (get-asset up))
:down (make-instance 'bitmap :texture (get-asset down))))
(defun make-text-button
(font up down
&key
pressed released
down-font
(up-color #(1.0 1.0 1.0 1.0))
(down-color #(1.0 1.0 1.0 1.0)))
(make-instance
'button
:on-release released :on-press pressed
:up (make-instance
'text
:content up
:color up-color
:font font)
:down (make-instance
'text
:content down
:color down-color
:font (or down-font font))))
|
