-
-
Notifications
You must be signed in to change notification settings - Fork 7
/
Copy pathmapping.lisp
145 lines (130 loc) · 6.54 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
(in-package #:org.shirakumo.fraf.gamepad)
(defvar *here* #.(make-pathname :name NIL :type NIL :defaults (or *compile-file-pathname* *load-pathname*
(error "You must COMPILE-FILE or LOAD this file."))))
(defvar *default-mappings-file* (make-pathname :name "default-device-mappings" :type "lisp" :defaults *here*))
(defvar *device-mappings* (make-hash-table :test 'equalp))
(defvar *blacklist* (make-hash-table :test 'equalp))
(defun normalize-mapping-id (id)
(etypecase id
(device
(list (driver id) (vendor id) (product id)))
(cons
(check-type id (cons keyword (cons integer (cons integer null))))
id)))
(defun blacklisted-p (id)
(gethash (normalize-mapping-id id) *blacklist*))
(defun (setf blacklisted-p) (value id)
(setf (gethash (normalize-mapping-id id) *blacklist*) value))
(defun mapping-id< (a b)
(destructuring-bind (ad av ap) a
(destructuring-bind (bd bv bp) b
(or (string< ad bd)
(and (string= ad bd)
(or (< av bv)
(and (= av bv)
(< ap bp))))))))
(defun copyhash (from &optional (to (make-hash-table :test (hash-table-test from))))
(unless (eq from to)
(clrhash to)
(maphash (lambda (k v) (setf (gethash k to) v)) from))
to)
(defun update-mapping-in-device (device mapping)
(when (getf mapping :name)
(setf (slot-value device 'name) (getf mapping :name)))
(when (getf mapping :icon-type)
(setf (icon-type device) (getf mapping :icon-type)))
(setf (button-map device) (or (getf mapping :buttons)
(error "Malformed mapping, missing :BUTTONS")))
(setf (axis-map device) (or (getf mapping :axes)
(error "Malformed mapping, missing :AXES")))
(setf (orientation-map device) (or (getf mapping :orientations)
(make-hash-table :test 'eql))))
(defmethod initialize-instance :after ((device device) &key)
(let ((mapping (device-mapping device)))
(when mapping (update-mapping-in-device device mapping))))
(defun device-mapping (id)
(gethash (normalize-mapping-id id) *device-mappings*))
(defun (setf device-mapping) (mapping id)
(let* ((id (normalize-mapping-id id))
(mapping (etypecase mapping
(cons mapping)
(device (list :name (name mapping)
:buttons (button-map mapping)
:axes (axis-map mapping)
:orientations (orientation-map mapping)
:icon-type (icon-type mapping)))))
(known (device-mapping id)))
(cond (known
;; Update the values in place to immediately update all
;; devices using it, too. Don't update the name unless
;; necessary as the device default is probably less accurate
(unless (getf known :name)
(setf (getf known :name) (getf mapping :name)))
(when (getf mapping :icon-type)
(setf (getf known :icon-type) (getf mapping :icon-type)))
(copyhash (getf mapping :axes) (getf known :axes))
(copyhash (getf mapping :buttons) (getf known :buttons))
(copyhash (getf mapping :orientations) (getf known :orientations)))
(T
(setf (gethash id *device-mappings*) mapping)
;; Need to go through all devices to see if they match
;; the new mapping.
(dolist (device (list-devices))
(when (equalp id (normalize-mapping-id device))
(update-mapping-in-device device mapping)))))))
(defun remove-device-mapping (id)
(remhash (normalize-mapping-id id) *device-mappings*))
(defun map-plist (table)
(flet ((label-pos (thing)
(if (symbolp (second thing))
(position (second thing) +labels+)
(first thing))))
(loop for (k v) in (sort (loop for k being the hash-keys of table
for v being the hash-values of table
collect (list k v))
#'< :key #'label-pos)
collect k collect v)))
(defun plist-map (plist)
(let ((map (make-hash-table :test 'eql)))
(loop for (k v) on plist by #'cddr
do (setf (gethash k map) v))
map))
(defmacro define-device-mapping ((driver vendor product) &body plist)
`(setf (device-mapping '(,driver ,vendor ,product))
(list :name ,(getf plist :name)
:buttons (plist-map ',(getf plist :buttons))
:axes (plist-map ',(getf plist :axes))
:orientations (plist-map ',(getf plist :orientations))
:icon-type ,(getf plist :icon-type :generic-xbox))))
(defun save-device-mappings (&optional (file *default-mappings-file*))
(with-open-file (stream file :direction :output
:if-exists :supersede
:if-does-not-exist :create
:external-format :utf-8)
(format stream ";;;; Device mapping definitions
;;; This file is auto-generated. Do not edit it manually
;;; unless you know what you are doing. You can generate
;;; the file from current mappings in your Lisp image via
;;;
;;; (org.shirakumo.fraf.gamepad:save-device-mappings)
;;;
;;; You can also interactively define new mappings using
;;;
;;; (org.shirakumo.fraf.gamepad:configure-device device)
;;;
\(in-package ~s)~%" (package-name #.*package*))
(loop for (id . black) in (sort (loop for k being the hash-keys of *blacklist*
for v being the hash-values of *blacklist*
collect (cons k v))
#'mapping-id< :key #'car)
do (when black (format stream "~%(setf (blacklisted-p '~s) T)~%" id)))
(loop for (id . map) in (sort (loop for k being the hash-keys of *device-mappings*
for v being the hash-values of *device-mappings*
collect (cons k v))
#'mapping-id< :key #'car)
do (format stream "~%(define-device-mapping ~s" id)
(format stream "~% :name ~s" (getf map :name))
(format stream "~% :icon-type ~s" (getf map :icon-type :generic-xbox))
(format stream "~% :buttons ~s" (map-plist (getf map :buttons)))
(format stream "~% :axes ~s" (map-plist (getf map :axes)))
(format stream "~% :orientations ~s)~%" (map-plist (getf map :orientations))))))