forked from Shirakumo/trial
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathmapping.lisp
338 lines (290 loc) · 13.5 KB
/
mapping.lisp
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
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
#|
This file is a part of trial
(c) 2016 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
Author: Nicolas Hafner <shinmera@tymoon.eu>
|#
(in-package #:org.shirakumo.fraf.trial)
(define-global +map-key-events+ T)
(define-global +retention-table+ (make-hash-table :test 'eql))
(defvar *mapping-functions* (make-hash-table :test 'eql))
(defvar *action-mappings* ())
(defun mapping-function (name)
(gethash name *mapping-functions*))
(defun (setf mapping-function) (mapping name)
(setf (gethash name *mapping-functions*) mapping))
(defun remove-mapping-function (name)
(remhash name *mapping-functions*))
(defmacro define-mapping-function (name (loop ev) &body body)
`(setf (mapping-function ',name)
(lambda (,loop ,ev)
(declare (ignorable ,loop))
,@body)))
(defun map-event (event loop)
(when (or +map-key-events+
(not (typep event 'key-event)))
(loop for function being the hash-values of *mapping-functions*
do (funcall function loop event))))
(declaim (inline %retained (setf %retained) retained (setf retained) clear-retained))
(defun %retained (id)
(gethash id +retention-table+ 0))
(defun (setf %retained) (int id)
(setf (gethash id +retention-table+) int))
(defun retained (id)
(< 0 (gethash id +retention-table+ 0)))
(defun (setf retained) (bool id)
(setf (gethash id +retention-table+) (if bool 1 0)))
(defun clear-retained ()
(clrhash +retention-table+))
(defun reset-retained (&optional (scene (scene +main+)))
(clear-retained)
(typecase +input-source+
((eql :keyboard)
;; FIXME: how the heck do we do this?
)
(gamepad:device
(loop for label across gamepad:+labels+
for button = (gamepad:button label +input-source+)
for axis = (gamepad:axis label +input-source+)
do (when button
(map-event (make-instance 'gamepad-press :button label :device +input-source+)
scene))
(when (<= 0.2 (abs axis))
(map-event (make-instance 'gamepad-move :axis label :pos axis :old-pos 0.0 :device +input-source+)
scene))))))
(define-mapping-function retain-generic (loop ev)
(typecase ev
(mouse-press
(setf (retained (button ev)) T))
(mouse-release
(setf (retained (button ev)) NIL))
(key-press
(setf (retained (key ev)) T)
(case (key ev)
((:left-control :right-control) (setf (retained :control) T))
((:left-shift :right-shift) (setf (retained :shift) T))
((:left-alt :right-alt) (setf (retained :alt) T))))
(key-release
(setf (retained (key ev)) NIL)
(case (key ev)
((:left-control :right-control) (setf (retained :control) NIL))
((:left-shift :right-shift) (setf (retained :shift) NIL))
((:left-alt :right-alt) (setf (retained :alt) NIL))))))
(defclass action-mapping ()
((action-type :initarg :action-type :accessor action-type)
(event-type :initarg :event-type :accessor event-type)
(qualifier :initarg :qualifier :accessor qualifier)
(%action-prototype)))
(defmethod shared-initialize :after ((mapping action-mapping) slots &key)
(setf (slot-value mapping '%action-prototype) (c2mop:class-prototype (c2mop:ensure-finalized (find-class (action-type mapping))))))
(defmethod print-object ((mapping action-mapping) stream)
(print-unreadable-object (mapping stream :type T)
(format stream "~s ~s -> ~s" (event-type mapping) (qualifier mapping) (action-type mapping))))
(defgeneric event-applicable-p (event mapping))
(defgeneric event-active-p (event mapping))
(defgeneric perform-event-mapping (event mapping loop))
(defgeneric from-mapping-description (type action bindings))
(defgeneric to-mapping-description (mapping))
(defgeneric event-from-action-mapping (mapping))
(defgeneric event-to-action-mapping (event action &key))
(defgeneric stratify-action-mapping (mapping))
(defmethod active-p ((mapping action-mapping))
(active-p (slot-value mapping '%action-prototype)))
(defmethod event-applicable-p ((event input-event) (mapping action-mapping))
NIL)
(defmethod event-applicable-p ((event key-event) (mapping action-mapping))
(and (not (repeat-p event))
(typep event (event-type mapping))
(find (key event) (qualifier mapping))))
(defmethod event-applicable-p ((event mouse-button-event) (mapping action-mapping))
(and (typep event (event-type mapping))
(find (button event) (qualifier mapping))))
(defmethod event-applicable-p ((event gamepad-button-event) (mapping action-mapping))
(and (typep event (event-type mapping))
(find (button event) (qualifier mapping))))
(defmethod event-applicable-p ((event gamepad-move) (mapping action-mapping))
(and (typep event (event-type mapping))
(find (axis event) (qualifier mapping))))
(defmethod stratify-action-mapping ((mapping action-mapping))
(loop for qualifier in (qualifier mapping)
collect (make-instance (type-of mapping) :action-type (action-type mapping)
:event-type (event-type mapping)
:qualifier (list qualifier))))
(defclass digital-mapping (action-mapping)
((threshold :initarg :threshold :initform +0.5 :accessor threshold)
(toggle-p :initarg :toggle-p :initform NIL :accessor toggle-p)))
(defmethod event-active-p ((event gamepad-move) (mapping digital-mapping))
(let* ((threshold (threshold mapping))
(old (old-pos event))
(cur (pos event)))
(if (< 0.0 threshold)
(cond ((< old threshold cur)
:on)
((< cur threshold old)
:off))
(cond ((< cur threshold old)
:on)
((< old threshold cur)
:off)))))
(defmethod event-active-p ((event digital-event) (mapping digital-mapping))
(if (typep event '(or key-press mouse-press gamepad-press))
:on :off))
(defmethod perform-event-mapping (event (mapping digital-mapping) loop)
(let ((active-p (event-active-p event mapping))
(action (action-type mapping)))
(when active-p
(let ((active-p (eql :on active-p)))
(cond ((toggle-p mapping)
(when active-p
(setf (%retained action) (if (retained action) -1 +1))))
(T
(when (and (not (retained action)) active-p)
(issue loop (make-instance action :source-event event)))
(typecase event
(digital-event
(setf (%retained action) (max 0 (+ (%retained action) (if active-p +1 -1)))))
(T
(setf (%retained action) (if active-p +1 0))))))))))
(defun normalize-mapping-event-type (type)
(case type
(key 'key-event)
(mouse 'mouse-button-event)
(button 'gamepad-button-event)
(axis 'gamepad-move)
(T type)))
(defmethod from-mapping-description ((type (eql 'trigger)) action bindings)
(loop for binding in bindings
collect (destructuring-bind (type &key one-of edge threshold (toggle NIL toggle-p)) binding
(make-instance 'digital-mapping
:action-type action
:event-type (normalize-mapping-event-type type)
:qualifier one-of
:threshold (or threshold 0.5)
:toggle-p (if toggle-p toggle (eql :rise-only edge))))))
(defmethod to-mapping-description ((mapping digital-mapping))
(list* 'trigger (action-type mapping)
(append (list (case (event-type mapping)
((key-event key-press) 'key)
((mouse-button-event mouse-press) 'mouse)
((gamepad-button-event gamepad-press) 'button)
(gamepad-move 'axis)
(T (event-type mapping)))
:one-of (qualifier mapping))
(unless (subtypep (event-type mapping) 'digital-event)
(list :threshold (threshold mapping)))
(when (toggle-p mapping) `(:toggle T)))))
(defmethod event-from-action-mapping ((mapping digital-mapping))
(let ((qualifier (first (qualifier mapping))))
(ecase (event-type mapping)
((key-event key-press key-release) (make-instance 'key-press :key qualifier))
((mouse-button-event mouse-press mouse-release) (make-instance 'mouse-press :button qualifier :pos #.(vec 0 0)))
((gamepad-button-event gamepad-press gamepad-release) (make-instance 'gamepad-press :device NIL :button qualifier))
(gamepad-move (make-instance 'gamepad-move :device NIL :axis qualifier :old-pos 0.0 :pos (threshold mapping))))))
(defmethod event-to-action-mapping (event (action symbol) &rest args &key &allow-other-keys)
(apply #'event-to-action-mapping event (make-instance action) args))
(defmethod event-to-action-mapping ((event gamepad-move) (action action) &key (threshold 0.5) toggle-p)
(make-instance 'digital-mapping
:action-type (type-of action)
:event-type (type-of event)
:qualifier (list (axis event))
:threshold threshold
:toggle-p toggle-p))
(defmethod event-to-action-mapping ((event digital-event) (action action) &key toggle-p)
(make-instance 'digital-mapping
:action-type (type-of action)
:event-type (typecase event
(key-event 'key-event)
(mouse-button-event 'mouse-button-event)
(gamepad-button-event 'gamepad-button-event)
(T (type-of event)))
:qualifier (list (button event))
:toggle-p toggle-p))
(defmethod stratify-action-mapping ((mapping digital-mapping))
(mapc (lambda (new)
(setf (threshold new) (threshold mapping))
(setf (toggle-p new) (toggle-p mapping)))
(call-next-method)))
(define-mapping-function input-maps (loop event)
(when (typep event 'input-event)
;; TODO: This is slow, as we keep iterating over and testing for events that will
;; very likely not change for a long time (comparatively). We should cache
;; the set of applicable mappings depending on active action-sets whenever
;; those change.
(dolist (mapping *action-mappings*)
(when (and (active-p mapping)
(event-applicable-p event mapping))
(perform-event-mapping event mapping loop)))))
(defun compile-mapping (input)
(let ((mappings ()))
(dolist (description input)
(destructuring-bind (type action &rest bindings) description
(dolist (mapping (from-mapping-description type action bindings))
(push mapping mappings))))
(setf *action-mappings* mappings)))
(defun load-mapping (input &key (package *package*))
(etypecase input
((or pathname string)
(with-open-file (stream input :direction :input)
(load-mapping stream :package package)))
(stream
(load-mapping (loop with *package* = package
for form = (read input NIL '#1=#:END)
until (eq form '#1#)
collect form)))
(list
(compile-mapping input))))
(defun save-mapping (output)
(etypecase output
(null
(with-output-to-string (stream)
(save-mapping stream)))
((or pathname string)
(with-open-file (stream output :direction :output :if-exists :supersede)
(save-mapping stream)))
(stream
(let ((descriptions (mapcar #'to-mapping-description *action-mappings*))
(cache (make-hash-table :test 'equal))
(*print-case* :downcase))
(dolist (description descriptions)
(push (cddr description) (gethash (list (first description) (second description)) cache)))
;; FIXME: collect based on matching :one-of.
(let ((descriptions (loop for preamble being the hash-keys of cache
for bindings being the hash-values of cache
collect (append preamble bindings))))
(loop for (type event . bindings) in descriptions
do (format output "(~s ~s~{~% ~s~})~%~%"
type event bindings)))))))
(defun find-action-mappings (action &optional (input-event-type 'input-event))
(let ((triggers ()))
(loop for mapping in *action-mappings*
do (when (and (eql action (action-type mapping))
(subtypep (event-type mapping) input-event-type))
(push mapping triggers)))
triggers))
(defun update-action-mappings (new-mappings &key (prune-event-type T))
(let ((mappings (append new-mappings
(remove-if (lambda (mapping)
(and (find (action-type mapping) new-mappings :key #'action-type)
(subtypep (event-type mapping) prune-event-type)))
*action-mappings*))))
(setf *action-mappings* mappings)))
#| Keymap should have the following syntax:
keymap ::= mapping*
mapping ::= (type action trigger*)
type ::= retain | trigger
trigger ::= (key one-of edge?)
| (mouse one-of edge?)
| (button one-of edge?)
| (axis one-of edge? threshold?)
one-of ::= :one-of label
edge ::= :edge :rise | :edge :fall
threshold ::= :threshold number
action --- a symbol naming an action event
label --- a keyword naming a key or button label
Examples:
(trigger quicksave
(label :english "Quick Save")
(key :one-of (:f5)))
(retain dash
(label :english "Dash")
(axis :one-of (:r2) :threshold 0.2))
|#