1 USING: accessors alien alien.c-types arrays assocs bit-arrays
2 cocoa.application cocoa.enumeration cocoa.plists combinators
3 combinators.short-circuit core-foundation core-foundation.data
4 core-foundation.run-loop core-foundation.strings destructors
5 game.input hints iokit iokit.hid kernel math namespaces
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 : make-hid-manager ( -- alien )
16 f 0 IOHIDManagerCreate ;
18 : set-hid-manager-matching ( alien matching-seq -- )
19 >plist IOHIDManagerSetDeviceMatchingMultiple ;
21 : devices-from-hid-manager ( manager -- vector )
23 IOHIDManagerCopyDevices
24 [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
27 CONSTANT: game-devices-matching-seq
29 H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses
30 H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
31 H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
32 H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
33 H{ { "DeviceUsage" 7 } { "DeviceUsagePage" 1 } } ! keypads
34 H{ { "DeviceUsage" 8 } { "DeviceUsagePage" 1 } } ! multiaxis controllers
37 CONSTANT: buttons-matching-hash
38 H{ { "UsagePage" 9 } { "Type" 2 } }
39 CONSTANT: keys-matching-hash
40 H{ { "UsagePage" 7 } { "Type" 2 } }
41 CONSTANT: x-axis-matching-hash
42 H{ { "UsagePage" 1 } { "Usage" 0x30 } { "Type" 1 } }
43 CONSTANT: y-axis-matching-hash
44 H{ { "UsagePage" 1 } { "Usage" 0x31 } { "Type" 1 } }
45 CONSTANT: z-axis-matching-hash
46 H{ { "UsagePage" 1 } { "Usage" 0x32 } { "Type" 1 } }
47 CONSTANT: rx-axis-matching-hash
48 H{ { "UsagePage" 1 } { "Usage" 0x33 } { "Type" 1 } }
49 CONSTANT: ry-axis-matching-hash
50 H{ { "UsagePage" 1 } { "Usage" 0x34 } { "Type" 1 } }
51 CONSTANT: rz-axis-matching-hash
52 H{ { "UsagePage" 1 } { "Usage" 0x35 } { "Type" 1 } }
53 CONSTANT: slider-matching-hash
54 H{ { "UsagePage" 1 } { "Usage" 0x36 } { "Type" 1 } }
55 CONSTANT: wheel-matching-hash
56 H{ { "UsagePage" 1 } { "Usage" 0x38 } { "Type" 1 } }
57 CONSTANT: hat-switch-matching-hash
58 H{ { "UsagePage" 1 } { "Usage" 0x39 } { "Type" 1 } }
60 : device-elements-matching ( device matching-hash -- vector )
62 >plist 0 IOHIDDeviceCopyMatchingElements
63 [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
66 : button-count ( device -- button-count )
67 buttons-matching-hash device-elements-matching length ;
69 : ?axis ( device hash -- axis/f )
70 device-elements-matching ?first ;
72 : ?x-axis ( device -- ? )
73 x-axis-matching-hash ?axis ;
74 : ?y-axis ( device -- ? )
75 y-axis-matching-hash ?axis ;
76 : ?z-axis ( device -- ? )
77 z-axis-matching-hash ?axis ;
78 : ?rx-axis ( device -- ? )
79 rx-axis-matching-hash ?axis ;
80 : ?ry-axis ( device -- ? )
81 ry-axis-matching-hash ?axis ;
82 : ?rz-axis ( device -- ? )
83 rz-axis-matching-hash ?axis ;
84 : ?slider ( device -- ? )
85 slider-matching-hash ?axis ;
86 : ?hat-switch ( device -- ? )
87 hat-switch-matching-hash ?axis ;
89 : device-property ( device key -- value )
90 <NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
91 : element-property ( element key -- value )
92 <NSString> IOHIDElementGetProperty [ plist> ] [ f ] if* ;
93 : set-element-property ( element key value -- )
94 [ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
95 : transfer-element-property ( element from-key to-key -- )
96 [ dupd element-property ] dip swap
97 [ set-element-property ] [ 2drop ] if* ;
99 : mouse-device? ( device -- ? )
100 1 2 IOHIDDeviceConformsTo ;
102 : controller-device? ( device -- ? )
104 [ 1 4 IOHIDDeviceConformsTo ]
105 [ 1 5 IOHIDDeviceConformsTo ]
106 [ 1 8 IOHIDDeviceConformsTo ]
109 : element-usage ( element -- {usage-page,usage} )
110 [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
113 : button? ( element -- ? )
114 IOHIDElementGetUsagePage 9 = ; inline
115 : keyboard-key? ( element -- ? )
116 IOHIDElementGetUsagePage 7 = ; inline
117 : axis? ( element -- ? )
118 IOHIDElementGetUsagePage 1 = ; inline
120 : x-axis? ( {usage-page,usage} -- ? )
121 IOHIDElementGetUsage 0x30 = ; inline
122 : y-axis? ( {usage-page,usage} -- ? )
123 IOHIDElementGetUsage 0x31 = ; inline
124 : z-axis? ( {usage-page,usage} -- ? )
125 IOHIDElementGetUsage 0x32 = ; inline
126 : rx-axis? ( {usage-page,usage} -- ? )
127 IOHIDElementGetUsage 0x33 = ; inline
128 : ry-axis? ( {usage-page,usage} -- ? )
129 IOHIDElementGetUsage 0x34 = ; inline
130 : rz-axis? ( {usage-page,usage} -- ? )
131 IOHIDElementGetUsage 0x35 = ; inline
132 : slider? ( {usage-page,usage} -- ? )
133 IOHIDElementGetUsage 0x36 = ; inline
134 : wheel? ( {usage-page,usage} -- ? )
135 IOHIDElementGetUsage 0x38 = ; inline
136 : hat-switch? ( {usage-page,usage} -- ? )
137 IOHIDElementGetUsage 0x39 = ; inline
141 pov-up pov-up-right pov-right pov-down-right
142 pov-down pov-down-left pov-left pov-up-left
146 : button-value ( value -- f/(0,1] )
147 IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
148 : axis-value ( value -- [-1,1] )
149 kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
150 : mouse-axis-value ( value -- n )
151 IOHIDValueGetIntegerValue ;
152 : pov-value ( value -- pov-direction )
153 IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
155 : record-button ( state hid-value element -- )
156 [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1 - ] tri* rot set-nth ;
158 : record-controller ( controller-state value -- )
159 dup IOHIDValueGetElement {
160 { [ dup button? ] [ record-button ] }
162 { [ dup x-axis? ] [ drop axis-value >>x drop ] }
163 { [ dup y-axis? ] [ drop axis-value >>y drop ] }
164 { [ dup z-axis? ] [ drop axis-value >>z drop ] }
165 { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
166 { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
167 { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
168 { [ dup slider? ] [ drop axis-value >>slider drop ] }
169 { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
175 HINTS: record-controller { controller-state alien } ;
177 : record-keyboard ( keyboard-state value -- )
178 dup IOHIDValueGetElement dup keyboard-key? [
179 [ IOHIDValueGetIntegerValue c-bool> ]
180 [ IOHIDElementGetUsage ] bi*
184 HINTS: record-keyboard { bit-array alien } ;
186 : record-mouse ( mouse-state value -- )
187 dup IOHIDValueGetElement {
188 { [ dup button? ] [ record-button ] }
190 { [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] }
191 { [ dup y-axis? ] [ drop mouse-axis-value [ + ] curry change-dy drop ] }
192 { [ dup wheel? ] [ drop mouse-axis-value [ + ] curry change-scroll-dx drop ] }
193 { [ dup z-axis? ] [ drop mouse-axis-value [ + ] curry change-scroll-dy drop ] }
199 HINTS: record-mouse { mouse-state alien } ;
201 M: iokit-game-input-backend read-mouse
202 +mouse-state+ get-global ;
204 M: iokit-game-input-backend reset-mouse
205 +mouse-state+ get-global
212 : default-calibrate-saturation ( element -- )
213 [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
214 [ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ]
217 : default-calibrate-axis ( element -- )
218 [ kIOHIDElementCalibrationMinKey -1.0 set-element-property ]
219 [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
220 [ default-calibrate-saturation ]
223 : default-calibrate-slider ( element -- )
224 [ kIOHIDElementCalibrationMinKey 0.0 set-element-property ]
225 [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
226 [ default-calibrate-saturation ]
229 : (default) ( ? quot -- )
232 : <device-controller-state> ( device -- controller-state )
234 [ ?x-axis [ default-calibrate-axis 0.0 ] (default) ]
235 [ ?y-axis [ default-calibrate-axis 0.0 ] (default) ]
236 [ ?z-axis [ default-calibrate-axis 0.0 ] (default) ]
237 [ ?rx-axis [ default-calibrate-axis 0.0 ] (default) ]
238 [ ?ry-axis [ default-calibrate-axis 0.0 ] (default) ]
239 [ ?rz-axis [ default-calibrate-axis 0.0 ] (default) ]
240 [ ?slider [ default-calibrate-slider 0.0 ] (default) ]
241 [ ?hat-switch pov-neutral and ]
242 [ button-count f <array> ]
243 } cleave controller-state boa ;
245 : ?add-mouse-buttons ( device -- )
246 button-count +mouse-state+ get-global buttons>>
248 [ set-length ] [ 2drop ] if ;
250 :: (device-matched-callback) ( context result sender device -- )
252 { [ device mouse-device? ] [ device ?add-mouse-buttons ] }
253 { [ device controller-device? ] [
254 device <device-controller-state>
255 device +controller-states+ get-global set-at
260 : device-matched-callback ( -- alien )
261 [ (device-matched-callback) ] IOHIDDeviceCallback ;
263 :: (device-removed-callback) ( context result sender device -- )
264 device +controller-states+ get-global delete-at ;
266 : device-removed-callback ( -- alien )
267 [ (device-removed-callback) ] IOHIDDeviceCallback ;
269 ! Lion sends the input callback an IOHIDQueue as the "sender".
270 ! Leopard and Snow Leopard send an IOHIDDevice.
271 ! This function gets the IOHIDDevice regardless of which is received
272 : get-input-device ( sender -- device )
274 { [ dup IOHIDDeviceGetTypeID = ] [ drop ] }
275 { [ dup IOHIDQueueGetTypeID = ] [ drop IOHIDQueueGetDevice ] }
278 "input callback doesn't know how to deal with "
279 swap CF>description append throw
283 :: (device-input-callback) ( context result sender value -- )
284 sender get-input-device :> device
286 { [ device mouse-device? ] [ +mouse-state+ get-global value record-mouse ] }
287 { [ device controller-device? ] [
288 device +controller-states+ get-global at value record-controller
290 [ +keyboard-state+ get-global value record-keyboard ]
293 : device-input-callback ( -- alien )
294 [ (device-input-callback) ] IOHIDValueCallback ;
296 : initialize-variables ( manager -- )
297 +hid-manager+ set-global
298 4 <vector> +controller-states+ set-global
299 0 0 0 0 2 <vector> mouse-state boa
300 +mouse-state+ set-global
301 256 <bit-array> +keyboard-state+ set-global ;
303 M: iokit-game-input-backend (open-game-input)
305 [ initialize-variables ]
306 [ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
307 [ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
308 [ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
309 [ 0 IOHIDManagerOpen mach-error ]
310 [ game-devices-matching-seq set-hid-manager-matching ]
312 CFRunLoopGetMain CFRunLoopDefaultMode
313 IOHIDManagerScheduleWithRunLoop
317 M: iokit-game-input-backend (reset-game-input)
318 { +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ }
319 [ f swap set-global ] each ;
321 M: iokit-game-input-backend (close-game-input)
322 +hid-manager+ get-global [
325 CFRunLoopGetMain CFRunLoopDefaultMode
326 IOHIDManagerUnscheduleFromRunLoop
328 [ 0 IOHIDManagerClose drop ]
332 f +keyboard-state+ set-global
333 f +mouse-state+ set-global
334 f +controller-states+ set-global
337 M: iokit-game-input-backend get-controllers
338 +controller-states+ get-global keys [ controller boa ] map ;
340 : ?glue ( seq subseq sep -- string )
341 2over subseq-index [ drop nip ] [ glue ] if ;
343 M: iokit-game-input-backend product-string
345 [ kIOHIDProductKey device-property ]
346 [ kIOHIDManufacturerKey device-property ] bi " " ?glue ;
348 M: iokit-game-input-backend product-id
350 [ kIOHIDVendorIDKey device-property ]
351 [ kIOHIDProductIDKey device-property ] bi 2array ;
353 M: iokit-game-input-backend instance-id
354 handle>> kIOHIDLocationIDKey device-property ;
356 M: iokit-game-input-backend read-controller
357 handle>> +controller-states+ get-global at clone ;
359 M: iokit-game-input-backend read-keyboard
360 +keyboard-state+ get-global clone keyboard-state boa ;
362 M: iokit-game-input-backend calibrate-controller