blob: 7c946639edcab2f2880042e41fdb05aeaf846f12 (
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
|
;;;; 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 :with :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 (setf closer-mop:slot-value-using-class) :before
(newval class (button button) slot)
(let ((slot-name
(closer-mop:slot-definition-name slot)))
(case slot-name
((up down bg)
(when (slot-boundp button slot-name)
(error "Swapping Button Faces Not Presently Supported"))))))
(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))))
(macrolet
((def-accessors (&rest accessor-names)
(let ((defs
(loop for accessor-name in accessor-names
collect
`(defmethod ,accessor-name ((button button))
(,accessor-name (button-up button)))
collect
`(defmethod (setf ,accessor-name) (newval (button button))
(setf (,accessor-name (button-up button)) newval
(,accessor-name (button-down button)) newval)
(when (button-bg button)
(setf (,accessor-name (button-bg button)) newval))))))
`(progn ,@defs))))
(def-accessors x y scale-x scale-y width height rotation))
(defmethod get-rect ((button button))
(get-rect (button-up button)))
(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 'image :texture (get-asset up))
:down (make-instance 'image :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))))
|
