forked from Shirakumo/trial
-
Notifications
You must be signed in to change notification settings - Fork 0
/
mapping.lisp
302 lines (265 loc) · 12.2 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
#|
This file is a part of trial
(c) 2016 Shirakumo http://tymoon.eu ([email protected])
Author: Nicolas Hafner <[email protected]>
|#
(in-package #:org.shirakumo.fraf.trial)
(define-global +retention-table* (make-hash-table :test 'eql))
(defvar *mappings* (make-hash-table :test 'equal))
(declaim (inline retained (setf retained) clear-retained))
(defun retained (id)
(gethash id +retention-table*))
(defun (setf retained) (bool id)
(setf (gethash id +retention-table*) bool))
(defun clear-retained ()
(clrhash +retention-table*))
(defun mapping (name)
(gethash name *mappings*))
(defun (setf mapping) (mapping name)
(setf (gethash name *mappings*) mapping))
(defun remove-mapping (name)
(remhash name *mappings*))
(defmacro define-mapping (name (loop ev) &body body)
`(setf (mapping ',name)
(list (lambda (,loop ,ev)
,@body)
())))
(defmacro define-simple-mapping (name (from to &rest to-args) &body tests)
(let ((loop (gensym "LOOP")))
`(define-mapping ,name (,loop ,from)
(when (typep ,from ',from)
(with-all-slots-bound (,from ,from)
(when (and ,@tests)
(issue ,loop (make-instance ',to ,@to-args))))))))
(defun map-event (event loop)
(loop for (function) being the hash-values of *mappings*
do (funcall function loop event)))
(defun action-definition (mapping action)
(find action (second (mapping mapping)) :key #'second))
(defun action-input (mapping action &key (device :gamepad))
(let ((binds (cddr (action-definition mapping action))))
(ecase device
(:keyboard
(getf (rest (or (assoc 'key binds) (assoc 'mouse binds))) :one-of))
(:gamepad
(getf (rest (or (assoc 'button binds) (assoc 'axis binds))) :one-of)))))
(defclass action-set () ()) ;; marker-class
(defclass exclusive-action-set () ())
(defmethod (setf active-p) :after (value (set exclusive-action-set))
(when value
(dolist (other (c2mop:class-direct-subclasses (find-class 'exclusive-action-set)))
(unless (eql (class-of set) other)
(setf (active-p other) NIL)))))
(defun find-action-set (action)
(flet ((direct-action-set (base)
(loop for class in (c2mop:class-direct-superclasses base)
do (when (eql class (find-class 'action-set))
(return base)))))
(or (direct-action-set action)
(loop for class in (or (ignore-errors (c2mop:class-precedence-list action))
(c2mop:compute-class-precedence-list action))
thereis (direct-action-set class))
(find-class 'action))))
(defun action-set (action)
(find-action-set (ensure-class action)))
(define-compiler-macro action-set (action &environment env)
(if (constantp action env)
`(load-time-value (find-action-set (ensure-class ,action)))
`(find-action-set (ensure-class ,action))))
(defmacro define-action-set (name &optional superclasses)
`(progn (defclass ,name (,@superclasses action-set)
((active-p :initform T :accessor active-p :allocation :class)))
(defmethod active-p ((class (eql (find-class ',name))))
(active-p (c2mop:class-prototype class)))
(defmethod (setf active-p) (value (class (eql (find-class ',name))))
(setf (active-p (c2mop:class-prototype class)) value))
(c2mop:finalize-inheritance (find-class ',name))))
(defclass action (event)
((source-event :initarg :source-event :initform NIL :accessor source-event)))
(defmethod active-p ((action (eql (find-class 'action)))) T)
(defclass analog-action (action)
((value :initarg :value :initform 0f0 :accessor value)))
(defclass directional-action (action)
((x :initarg :value :initform 0f0 :accessor x)
(y :initarg :value :initform 0f0 :accessor y)))
(defclass spatial-action (action)
((x :initarg :value :initform 0f0 :accessor x)
(y :initarg :value :initform 0f0 :accessor y)
(z :initarg :value :initform 0f0 :accessor z)))
(defun remove-action-mappings (action)
(loop for k being the hash-keys of *mappings*
do (when (and (consp k) (eql (car k) action))
(remhash k *mappings*))))
(defmacro define-action (name superclasses &body mappings)
(flet ((compile-mapping (mapping)
(destructuring-bind (type &rest tests) mapping
`(define-simple-mapping (,name ,type) (,type ,name :source-event ,type)
,@tests))))
(setf superclasses (append superclasses '(action)))
`(progn
(defclass ,name ,superclasses
())
(remove-action-mappings ',name)
,@(mapcar #'compile-mapping mappings))))
(defgeneric process-trigger-form (ev event &key &allow-other-keys)
(:method (ev (_ (eql 'label)) &key &allow-other-keys))
(:method (ev (_ (eql 'key)) &key one-of (edge :rise))
`(,(ecase edge (:rise 'key-press) (:fall 'key-release))
(one-of (key ,ev) ,@one-of)))
(:method (ev (_ (eql 'button)) &key one-of (edge :rise))
`(,(ecase edge (:rise 'gamepad-press) (:fall 'gamepad-release))
(one-of (button ,ev) ,@one-of)))
(:method (ev (_ (eql 'mouse)) &key one-of (edge :rise))
`(,(ecase edge (:rise 'mouse-press) (:fall 'mouse-release))
(one-of (button ,ev) ,@one-of)))
(:method (ev (_ (eql 'axis)) &key one-of (edge :rise) (threshold 0.5))
`(gamepad-move
(and (one-of (axis ,ev) ,@one-of)
,(if (xor (eql edge :rise) (plusp threshold))
`(< (pos ,ev) ,threshold (old-pos ,ev))
`(< (old-pos ,ev) ,threshold (pos ,ev)))))))
(defgeneric process-retain-form (ev event &key &allow-other-keys)
(:method (ev (_ (eql 'label)) &key &allow-other-keys))
(:method (ev (_ (eql 'key)) &key one-of (edge :rise))
`(,(ecase edge (:rise 'key-press) (:fall 'key-release))
,(ecase edge (:rise 'key-release) (:fall 'key-press))
(one-of (key ,ev) ,@one-of)))
(:method (ev (_ (eql 'button)) &key one-of (edge :rise))
`(,(ecase edge (:rise 'gamepad-press) (:fall 'gamepad-release))
,(ecase edge (:rise 'gamepad-release) (:fall 'gamepad-press))
(one-of (button ,ev) ,@one-of)))
(:method (ev (_ (eql 'mouse)) &key one-of (edge :rise))
`(,(ecase edge (:rise 'mouse-press) (:fall 'mouse-release))
,(ecase edge (:rise 'mouse-release) (:fall 'mouse-press))
(one-of (button ,ev) ,@one-of)))
(:method (ev (_ (eql 'axis)) &key one-of (edge :rise) (threshold 0.5))
`(gamepad-move
gamepad-move
(and (one-of (axis ,ev) ,@one-of)
,(if (xor (eql edge :rise) (plusp threshold))
`(< (pos ,ev) ,threshold (old-pos ,ev))
`(< (old-pos ,ev) ,threshold (pos ,ev))))
(and (one-of (axis ,ev) ,@one-of)
,(if (xor (eql edge :rise) (plusp threshold))
`(< (old-pos ,ev) ,threshold (pos ,ev))
`(< (pos ,ev) ,threshold (old-pos ,ev)))))))
(defgeneric process-analog-form (ev event &key &allow-other-keys)
(:method (ev (_ (eql 'label)) &key &allow-other-keys))
(:method (ev (_ (eql 'key)) &key one-of (edge :rise) (value 1.0))
`(key-event
(one-of (key ,ev) ,@one-of)
(etypecase ,ev
(key-press ,(ecase edge (:rise value) (:fall 0.0)))
(key-release (ecase edge (:rise 0.0) (:fall ,value))))))
(:method (ev (_ (eql 'button)) &key one-of (edge :rise) (value 1.0))
`(button-event
(one-of (button ,ev) ,@one-of)
(etypecase ,ev
(button-press ,(ecase edge (:rise value) (:fall 0.0)))
(button-release (ecase edge (:rise 0.0) (:fall ,value))))))
(:method (ev (_ (eql 'mouse)) &key one-of (edge :rise) (value 1.0))
`(mouse-button-event
(one-of (button ,ev) ,@one-of)
(etypecase ,ev
(mouse-press ,(ecase edge (:rise value) (:fall 0.0)))
(mouse-release (ecase edge (:rise 0.0) (:fall ,value))))))
(:method (ev (_ (eql 'cursor)) &key (axis :x) (multiplier 1.0))
`(mouse-move
T
(* ,multiplier (,(ecase axis (:x 'vx2) (:y 'vy2)) (pos ,ev)))))
(:method (ev (_ (eql 'axis)) &key one-of (threshold 0.1) (multiplier 1.0))
`(gamepad-move
(and (one-of (axis ,ev) ,@one-of)
(< ,threshold (pos ,ev)))
(* ,multiplier (pos ,ev)))))
(defun process-mapping-form (loop ev form)
(destructuring-bind (type action &body triggers) form
(ecase type
(trigger
(loop for trigger in triggers
for (evtype condition) = (apply #'process-trigger-form ev trigger)
when evtype
collect (list evtype
`(when (and ,condition
(active-p (action-set ',action)))
(issue ,loop (make-instance ',action :source-event ,ev))))))
(retain
(loop for trigger in triggers
for (evdn evup cddn cdup) = (apply #'process-retain-form ev trigger)
when evdn
collect (list evdn
`(when (and ,cddn
(active-p (action-set ',action)))
(issue ,loop (make-instance ',action :source-event ,ev))
(setf (retained ',action) T)))
when evup
collect (list evup
`(when (and ,(or cdup cddn)
(active-p (action-set ',action)))
(setf (retained ',action) NIL)))))
(analog
(loop for trigger in triggers
for (evtype condition value) = (apply #'process-analog-form ev trigger)
when evtype
collect (list evtype
`(when (and ,condition
(active-p (action-set ',action)))
(issue ,loop (make-instance ',action :source-event ,ev :value ,value)))))))))
;; TODO: could optimise this further by combining ONE-OF tests.
(defun load-mapping (input &key (name 'keymap) (package *package*))
(etypecase input
((or pathname string)
(with-open-file (stream input :direction :input)
(load-mapping stream :name name :package package)))
(stream
(load-mapping (loop with *package* = package
for form = (read input NIL '#1=#:END)
until (eq form '#1#)
collect form)
:name name))
(list
(let ((bits (make-hash-table :test 'eql)))
(dolist (form input)
(loop for (type body) in (process-mapping-form 'loop 'event form)
do (push body (gethash type bits))))
(setf (mapping name)
(list
(compile NIL `(lambda (loop event)
(typecase event
,@(loop for event being the hash-keys of bits
for bodies being the hash-values of bits
collect `(,event ,@bodies)))))
input))))))
(defun event-trigger (event &optional (base-event 'input-event))
(loop for (_function mapping) being the hash-values of *mappings*
do (loop for (_type target . sources) in mapping
do (when (eql event target)
(loop for (source . args) in sources
for source-event = (case source
(key 'key-event)
(mouse 'mouse-button-event)
(button 'gamepad-event))
do (when (subtypep source-event base-event)
(return-from event-trigger
(values (getf args :one-of) source args))))))))
#| 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))
|#