blob: db49e0307c128b40c27d8a77e9bb4a67c9d00534 (
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
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
|
;;;; wheelwork.lisp
(in-package #:wheelwork)
(defvar *application* nil
"current application")
(defun start (app &key (x :centered) (y :centered))
(sdl2:with-init (:everything)
(sdl2:gl-set-attr :context-major-version 3)
(sdl2:gl-set-attr :context-minor-version 3)
(sdl2:gl-set-attr :context-profile-mask
sdl2-ffi:+sdl-gl-context-profile-core+)
(sdl2:gl-set-attr :doublebuffer 1)
(sdl2:with-window (window
:flags '(:shown :opengl)
:title (application-title app)
:w (application-width app)
:h (application-height app)
:x x :y y)
(setf (application-window app) window)
(sdl2:with-gl-context (ctx window)
(sdl2:gl-make-current window ctx)
(gl:viewport 0 0 (application-width app) (application-height app))
;(gl:enable :depth-test)
(gl:enable :scissor-test)
(let ((*application* app))
(unwind-protect
(progn
(boot app)
(eventloop app)
(shutdown app))
(cleanup app)))))))
(defun stop ()
(sdl2:push-event :quit))
(defun refocus-on (target &optional (app *application*))
"Sets focus of application to TARGET. This works whether or not
TARGET is FOCUSABLEP"
(setf (application-focus app) target))
(defun get-focus (&optional (app *application*))
(or (application-focus app) app))
(defun get-handlers-for (unit event-type)
"EVENT-TYPE must be one of the slot value names for WHEELWORK::LISTENER."
(when-let (listener (listener unit))
(slot-value listener event-type)))
(defun eventloop-keydown (app sdl-keysym)
(let ((target (get-focus app)))
(when-let (handlers (get-handlers-for target 'keydown))
(dolist (handler handlers)
(apply handler
target
(sdl2:scancode sdl-keysym)
(sdl2:mod-keywords (sdl2:mod-value sdl-keysym)))))))
(defun eventloop-keyup (app sdl-keysym)
(let ((target (get-focus app)))
(when-let (handlers (get-handlers-for target 'keyup))
(dolist (handler handlers)
(apply handler
target
(sdl2:scancode sdl-keysym)
(sdl2:mod-keywords (sdl2:mod-value sdl-keysym)))))))
(defun unit-contains-point-p (unit pt)
(path-encloses-point-p (get-rect unit) pt))
(defun mouse-event-targets (app x y &optional bubblep)
"Returns a list of one or more objects found under the x y
position. The list always contains the app itself as the last element."
(nconc (if bubblep
(all-units-under app x y)
(unit-under app x y))
(list app)))
(defun unit-under (app x y)
"Finds the visible unit that contains the point x y, returns it as a
single elemtn list, or nil if none found"
(let ((xy (vec:vec x y 0.0 1.0)))
(labels
((finder (thing)
(when (unit-visiblep thing)
(etypecase thing
(container
(when (unit-contains-point-p thing xy)
(find-if #'finder (container-units thing) :from-end t)))
(unit
(when (unit-contains-point-p thing xy)
(return-from unit-under (list thing))))))))
(finder app))))
(defun all-units-under (app x y)
"Finds all units under the point x y"
(let ((xy
(vec:vec x y 0.0 1.0))
(units
nil))
(labels
((finder (thing)
(when (unit-visiblep thing)
(etypecase thing
(container
(when (unit-contains-point-p thing xy)
(mapc #'finder (container-units thing))))
(unit
(when (unit-contains-point-p thing xy)
(push thing units)))))))
(finder app))
units))
(defvar *event-still-bubbling-p* nil
"Controls whether an event is bubbling")
(defun stop-bubbling ()
(setf *event-still-bubbling-p* nil))
(defun screen-to-world (x y &optional (app *application*))
"Scales the screen point - the literal pixel position relative to
the top corner of the application window - to reflect the
application's scaling factor."
(with-slots (height scale) app
(list (/ x scale) (/ (- height y) scale))))
(defun eventloop-mousebuttondown (app wx wy clicks button)
"Searches for a handler to handle applies it if found.
Additionally, if the APPLICATION's REFOCUS-ON-MOUSEDOWN-P is T, try to
give focus to whatever was clicked."
(destructuring-bind (x y) (screen-to-world wx wy)
(let ((candidate-targets
(mouse-event-targets app x y (mouse-button-events-bubble-p app))))
;; refocus always occurs on the "top" focasable thing
(when (and (refocus-on-mousedown-p app)
(focusablep (first candidate-targets)))
(refocus-on (first candidate-targets)))
(let ((*event-still-bubbling-p*
(mouse-button-events-bubble-p app)))
(loop for target in candidate-targets
do
(dolist (handler (get-handlers-for target 'mousedown))
(funcall handler target x y clicks button wx wy))
while *event-still-bubbling-p*)))))
(defun eventloop-mousebuttonup (app wx wy clicks button)
(when (should-listen-for-p 'mouseup app)
(destructuring-bind (x y) (screen-to-world wx wy)
(let ((*event-still-bubbling-p*
(mouse-button-events-bubble-p app)))
(loop for target in (mouse-event-targets app x y (mouse-button-events-bubble-p app))
do
(dolist (handler (get-handlers-for target 'mouseup))
(funcall handler target x y clicks button wx wy))
while *event-still-bubbling-p*)))))
(defun eventloop-mousemotion (app wx wy wxrel wyrel state)
(when (should-listen-for-p 'mousemotion app)
(destructuring-bind (x y) (screen-to-world wx wy)
(destructuring-bind (xrel yrel) (screen-to-world wxrel wyrel)
(let ((*event-still-bubbling-p*
(mouse-motion-events-bubble-p app)))
(loop for target in (mouse-event-targets app x y (mouse-motion-events-bubble-p app))
do
(dolist (handler (get-handlers-for target 'mousemotion))
(funcall handler target x y xrel yrel state wx wy wxrel wyrel))
while *event-still-bubbling-p*))))))
(defun eventloop-mousewheel (app wx wy dir)
(when (should-listen-for-p 'mousewheel app)
(when-let* ((focus (get-focus app))
(handlers (get-handlers-for focus 'mousewheel)))
(dolist (handler handlers)
(funcall handler focus wx wy dir)))))
(defun eventloop (app)
(sdl2:with-event-loop (:method :poll)
(:mousebuttondown
(:x x :y y :clicks clicks :button button)
(eventloop-mousebuttondown app x y clicks button))
(:mousemotion
(:x x :y y :xrel xrel :yrel yrel :state state)
(eventloop-mousemotion app x y xrel yrel state))
(:mousebuttonup
(:x x :y y :clicks clicks :button button)
(eventloop-mousebuttonup app x y clicks button))
(:keydown
(:keysym keysym)
(eventloop-keydown app keysym))
(:keyup
(:keysym keysym)
(eventloop-keyup app keysym))
(:mousewheel
(:x x :y y :direction dir)
(eventloop-mousewheel app x y dir))
(:idle () (render app))
(:quit () t)))
(defun asset-class-for (asset-id &optional (app *application*))
"Given an asset-id (see GET-ASSET), retrieve the symbol name of a
the class that will be used to instantiate the asset object. That
class should be a subclass of ASSET. Additional clases can be added
to the application's ASSET-CLASSIFIERS association list."
(second (assoc (pathname-type asset-id) (asset-classifiers app) :test #'string-equal)))
(defun get-asset (asset-id &key (app *application*) asset-args)
"ASSET-ID is a pathname namestring relative to the application's
ASSET-ROOT. GET-ASSET retrieves an already-available asset from the
application's ASSETS table, or, if not available, loads the asset from
disk.
ASSET-ARGS is a plist to pass to make-instance for the given resource.
"
(or (gethash asset-id (application-assets app))
(setf (gethash asset-id (application-assets app))
(ensure-loaded
(apply 'make-instance
(asset-class-for asset-id)
:path (uiop:merge-pathnames* asset-id (asset-root app))
asset-args)))))
|
