1 USING: cocoa cocoa.plists core-foundation iokit iokit.hid
2 kernel cocoa.enumeration destructors math.parser cocoa.application
3 sequences locals combinators.short-circuit threads
4 namespaces assocs arrays combinators hints alien
5 core-foundation.run-loop accessors sequences.private
6 alien.c-types math parser game-input vectors ;
9 SINGLETON: iokit-game-input-backend
11 SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
13 iokit-game-input-backend game-input-backend set-global
15 : hid-manager-matching ( matching-seq -- alien )
16 f 0 IOHIDManagerCreate
17 [ swap >plist IOHIDManagerSetDeviceMatchingMultiple ]
20 : devices-from-hid-manager ( manager -- vector )
22 IOHIDManagerCopyDevices
23 [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
26 CONSTANT: game-devices-matching-seq
28 H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses
29 H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
30 H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
31 H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
32 H{ { "DeviceUsage" 7 } { "DeviceUsagePage" 1 } } ! keypads
33 H{ { "DeviceUsage" 8 } { "DeviceUsagePage" 1 } } ! multiaxis controllers
36 CONSTANT: buttons-matching-hash
37 H{ { "UsagePage" 9 } { "Type" 2 } }
38 CONSTANT: keys-matching-hash
39 H{ { "UsagePage" 7 } { "Type" 2 } }
40 CONSTANT: x-axis-matching-hash
41 H{ { "UsagePage" 1 } { "Usage" HEX: 30 } { "Type" 1 } }
42 CONSTANT: y-axis-matching-hash
43 H{ { "UsagePage" 1 } { "Usage" HEX: 31 } { "Type" 1 } }
44 CONSTANT: z-axis-matching-hash
45 H{ { "UsagePage" 1 } { "Usage" HEX: 32 } { "Type" 1 } }
46 CONSTANT: rx-axis-matching-hash
47 H{ { "UsagePage" 1 } { "Usage" HEX: 33 } { "Type" 1 } }
48 CONSTANT: ry-axis-matching-hash
49 H{ { "UsagePage" 1 } { "Usage" HEX: 34 } { "Type" 1 } }
50 CONSTANT: rz-axis-matching-hash
51 H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } }
52 CONSTANT: slider-matching-hash
53 H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } }
54 CONSTANT: wheel-matching-hash
55 H{ { "UsagePage" 1 } { "Usage" HEX: 38 } { "Type" 1 } }
56 CONSTANT: hat-switch-matching-hash
57 H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } }
59 : device-elements-matching ( device matching-hash -- vector )
61 >plist 0 IOHIDDeviceCopyMatchingElements
62 [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
65 : button-count ( device -- button-count )
66 buttons-matching-hash device-elements-matching length ;
68 : ?axis ( device hash -- axis/f )
69 device-elements-matching [ f ] [ first ] if-empty ;
71 : ?x-axis ( device -- ? )
72 x-axis-matching-hash ?axis ;
73 : ?y-axis ( device -- ? )
74 y-axis-matching-hash ?axis ;
75 : ?z-axis ( device -- ? )
76 z-axis-matching-hash ?axis ;
77 : ?rx-axis ( device -- ? )
78 rx-axis-matching-hash ?axis ;
79 : ?ry-axis ( device -- ? )
80 ry-axis-matching-hash ?axis ;
81 : ?rz-axis ( device -- ? )
82 rz-axis-matching-hash ?axis ;
83 : ?slider ( device -- ? )
84 slider-matching-hash ?axis ;
85 : ?hat-switch ( device -- ? )
86 hat-switch-matching-hash ?axis ;
88 : hid-manager-matching-game-devices ( -- alien )
89 game-devices-matching-seq hid-manager-matching ;
91 : device-property ( device key -- value )
92 <NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
93 : element-property ( element key -- value )
94 <NSString> IOHIDElementGetProperty [ plist> ] [ f ] if* ;
95 : set-element-property ( element key value -- )
96 [ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
97 : transfer-element-property ( element from-key to-key -- )
98 [ dupd element-property ] dip swap
99 [ set-element-property ] [ 2drop ] if* ;
101 : mouse-device? ( device -- ? )
102 1 2 IOHIDDeviceConformsTo ;
104 : controller-device? ( device -- ? )
106 [ 1 4 IOHIDDeviceConformsTo ]
107 [ 1 5 IOHIDDeviceConformsTo ]
108 [ 1 8 IOHIDDeviceConformsTo ]
111 : element-usage ( element -- {usage-page,usage} )
112 [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
115 : button? ( element -- ? )
116 IOHIDElementGetUsagePage 9 = ; inline
117 : keyboard-key? ( element -- ? )
118 IOHIDElementGetUsagePage 7 = ; inline
119 : axis? ( element -- ? )
120 IOHIDElementGetUsagePage 1 = ; inline
122 : x-axis? ( {usage-page,usage} -- ? )
123 IOHIDElementGetUsage HEX: 30 = ; inline
124 : y-axis? ( {usage-page,usage} -- ? )
125 IOHIDElementGetUsage HEX: 31 = ; inline
126 : z-axis? ( {usage-page,usage} -- ? )
127 IOHIDElementGetUsage HEX: 32 = ; inline
128 : rx-axis? ( {usage-page,usage} -- ? )
129 IOHIDElementGetUsage HEX: 33 = ; inline
130 : ry-axis? ( {usage-page,usage} -- ? )
131 IOHIDElementGetUsage HEX: 34 = ; inline
132 : rz-axis? ( {usage-page,usage} -- ? )
133 IOHIDElementGetUsage HEX: 35 = ; inline
134 : slider? ( {usage-page,usage} -- ? )
135 IOHIDElementGetUsage HEX: 36 = ; inline
136 : wheel? ( {usage-page,usage} -- ? )
137 IOHIDElementGetUsage HEX: 38 = ; inline
138 : hat-switch? ( {usage-page,usage} -- ? )
139 IOHIDElementGetUsage HEX: 39 = ; inline
143 pov-up pov-up-right pov-right pov-down-right
144 pov-down pov-down-left pov-left pov-up-left
148 : button-value ( value -- f/(0,1] )
149 IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
150 : axis-value ( value -- [-1,1] )
151 kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
152 : mouse-axis-value ( value -- n )
153 IOHIDValueGetIntegerValue ;
154 : pov-value ( value -- pov-direction )
155 IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
157 : record-button ( state hid-value element -- )
158 [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ;
160 : record-controller ( controller-state value -- )
161 dup IOHIDValueGetElement {
162 { [ dup button? ] [ record-button ] }
164 { [ dup x-axis? ] [ drop axis-value >>x drop ] }
165 { [ dup y-axis? ] [ drop axis-value >>y drop ] }
166 { [ dup z-axis? ] [ drop axis-value >>z drop ] }
167 { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
168 { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
169 { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
170 { [ dup slider? ] [ drop axis-value >>slider drop ] }
171 { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
177 HINTS: record-controller { controller-state alien } ;
179 : ?set-nth ( value nth seq -- )
180 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
182 : record-keyboard ( keyboard-state value -- )
183 dup IOHIDValueGetElement dup keyboard-key? [
184 [ IOHIDValueGetIntegerValue c-bool> ]
185 [ IOHIDElementGetUsage ] bi*
189 HINTS: record-keyboard { array alien } ;
191 : record-mouse ( mouse-state value -- )
192 dup IOHIDValueGetElement {
193 { [ dup button? ] [ record-button ] }
195 { [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] }
196 { [ dup y-axis? ] [ drop mouse-axis-value [ + ] curry change-dy drop ] }
197 { [ dup wheel? ] [ drop mouse-axis-value [ + ] curry change-scroll-dx drop ] }
198 { [ dup z-axis? ] [ drop mouse-axis-value [ + ] curry change-scroll-dy drop ] }
204 HINTS: record-mouse { mouse-state alien } ;
206 M: iokit-game-input-backend read-mouse
209 M: iokit-game-input-backend reset-mouse
217 : default-calibrate-saturation ( element -- )
218 [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
219 [ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ]
222 : default-calibrate-axis ( element -- )
223 [ kIOHIDElementCalibrationMinKey -1.0 set-element-property ]
224 [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
225 [ default-calibrate-saturation ]
228 : default-calibrate-slider ( element -- )
229 [ kIOHIDElementCalibrationMinKey 0.0 set-element-property ]
230 [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
231 [ default-calibrate-saturation ]
234 : (default) ( ? quot -- )
237 : <device-controller-state> ( device -- controller-state )
239 [ ?x-axis [ default-calibrate-axis 0.0 ] (default) ]
240 [ ?y-axis [ default-calibrate-axis 0.0 ] (default) ]
241 [ ?z-axis [ default-calibrate-axis 0.0 ] (default) ]
242 [ ?rx-axis [ default-calibrate-axis 0.0 ] (default) ]
243 [ ?ry-axis [ default-calibrate-axis 0.0 ] (default) ]
244 [ ?rz-axis [ default-calibrate-axis 0.0 ] (default) ]
245 [ ?slider [ default-calibrate-slider 0.0 ] (default) ]
246 [ ?hat-switch pov-neutral and ]
247 [ button-count f <array> ]
248 } cleave controller-state boa ;
250 : ?add-mouse-buttons ( device -- )
251 button-count +mouse-state+ get buttons>>
253 [ set-length ] [ 2drop ] if ;
255 : device-matched-callback ( -- alien )
256 [| context result sender device |
258 { [ device controller-device? ] [
259 device <device-controller-state>
260 device +controller-states+ get set-at
262 { [ device mouse-device? ] [ device ?add-mouse-buttons ] }
265 ] IOHIDDeviceCallback ;
267 : device-removed-callback ( -- alien )
268 [| context result sender device |
269 device +controller-states+ get delete-at
270 ] IOHIDDeviceCallback ;
272 : device-input-callback ( -- alien )
273 [| context result sender value |
275 { [ sender controller-device? ] [
276 sender +controller-states+ get at value record-controller
278 { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] }
279 [ +keyboard-state+ get value record-keyboard ]
281 ] IOHIDValueCallback ;
283 : initialize-variables ( manager -- )
284 +hid-manager+ set-global
285 4 <vector> +controller-states+ set-global
286 0 0 0 0 2 <vector> mouse-state boa
287 +mouse-state+ set-global
288 256 f <array> +keyboard-state+ set-global ;
290 M: iokit-game-input-backend (open-game-input)
291 hid-manager-matching-game-devices {
292 [ initialize-variables ]
293 [ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
294 [ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
295 [ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
296 [ 0 IOHIDManagerOpen mach-error ]
298 CFRunLoopGetMain CFRunLoopDefaultMode
299 IOHIDManagerScheduleWithRunLoop
303 M: iokit-game-input-backend (reset-game-input)
304 { +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ }
305 [ f swap set-global ] each ;
307 M: iokit-game-input-backend (close-game-input)
308 +hid-manager+ get-global [
311 CFRunLoopGetMain CFRunLoopDefaultMode
312 IOHIDManagerUnscheduleFromRunLoop
314 [ 0 IOHIDManagerClose drop ]
318 f +keyboard-state+ set-global
319 f +mouse-state+ set-global
320 f +controller-states+ set-global
323 M: iokit-game-input-backend get-controllers ( -- sequence )
324 +controller-states+ get keys [ controller boa ] map ;
326 : ?join ( pre post sep -- string )
327 2over start [ swap 2nip ] [ [ 2array ] dip join ] if ;
329 M: iokit-game-input-backend product-string ( controller -- string )
331 [ kIOHIDManufacturerKey device-property ]
332 [ kIOHIDProductKey device-property ] bi " " ?join ;
333 M: iokit-game-input-backend product-id ( controller -- integer )
335 [ kIOHIDVendorIDKey device-property ]
336 [ kIOHIDProductIDKey device-property ] bi 2array ;
337 M: iokit-game-input-backend instance-id ( controller -- integer )
338 handle>> kIOHIDLocationIDKey device-property ;
340 M: iokit-game-input-backend read-controller ( controller -- controller-state )
341 handle>> +controller-states+ get at clone ;
343 M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
344 +keyboard-state+ get clone keyboard-state boa ;
346 M: iokit-game-input-backend calibrate-controller ( controller -- )