blob: 8b1e534c7e2202587dd9c61034803c6faa5d94e2 (
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
|
;;;; 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 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 unit-under (app x y)
"Finds the visible unit that contains the point x y."
(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 thing)))))))
(finder app))))
(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 ((target
(or (unit-under app x y) ; if no unit is under the mouse,
app))) ; then target the app itself
(when (and (refocus-on-mousedown-p app) (focusablep target))
(refocus-on target))
(when-let (handlers (get-handlers-for target 'mousedown))
(dolist (handler handlers)
(funcall handler target x y clicks button wx wy))))))
(defun eventloop-mousebuttonup (app wx wy clicks button)
(when (should-listen-for-p 'mouseup app)
(destructuring-bind (x y) (screen-to-world wx wy)
(when-let* ((target (or (unit-under app x y)
app))
(handlers (get-handlers-for target 'mouseup)))
(dolist (handler handlers)
(funcall handler target x y clicks button wx wy))))))
(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)
(when-let* ((target (or (unit-under app x y)
app))
(handlers (get-handlers-for target 'mousemotion)))
(dolist (handler handlers)
(funcall handler target x y xrel yrel state wx wy wxrel wyrel)))))))
(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)))))
|
