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 symbols namespaces assocs vectors arrays combinators
5 core-foundation.run-loop accessors sequences.private
6 alien.c-types math parser ;
7 << "game-input" (use+) >>
8 IN: game-input.backend.iokit
10 SINGLETON: iokit-game-input-backend
12 : hid-manager-matching ( matching-seq -- alien )
13 f 0 IOHIDManagerCreate
14 [ swap >plist IOHIDManagerSetDeviceMatchingMultiple ]
17 : devices-from-hid-manager ( manager -- vector )
19 IOHIDManagerCopyDevices
20 [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
23 : game-devices-matching-seq
25 H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
26 H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
27 H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
30 : buttons-matching-hash
31 H{ { "UsagePage" 9 } { "Type" 2 } } ; inline
33 H{ { "UsagePage" 7 } { "Type" 2 } } ; inline
34 : x-axis-matching-hash
35 H{ { "UsagePage" 1 } { "Usage" HEX: 30 } { "Type" 1 } } ; inline
36 : y-axis-matching-hash
37 H{ { "UsagePage" 1 } { "Usage" HEX: 31 } { "Type" 1 } } ; inline
38 : z-axis-matching-hash
39 H{ { "UsagePage" 1 } { "Usage" HEX: 32 } { "Type" 1 } } ; inline
40 : rx-axis-matching-hash
41 H{ { "UsagePage" 1 } { "Usage" HEX: 33 } { "Type" 1 } } ; inline
42 : ry-axis-matching-hash
43 H{ { "UsagePage" 1 } { "Usage" HEX: 34 } { "Type" 1 } } ; inline
44 : rz-axis-matching-hash
45 H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } } ; inline
46 : slider-matching-hash
47 H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } } ; inline
48 : hat-switch-matching-hash
49 H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } } ; inline
51 : device-elements-matching ( device matching-hash -- vector )
53 >plist 0 IOHIDDeviceCopyMatchingElements
54 [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
57 : button-count ( device -- button-count )
58 buttons-matching-hash device-elements-matching length ;
60 : ?axis ( device hash -- axis/f )
61 device-elements-matching [ f ] [ first ] if-empty ;
63 : ?x-axis ( device -- ? )
64 x-axis-matching-hash ?axis ;
65 : ?y-axis ( device -- ? )
66 y-axis-matching-hash ?axis ;
67 : ?z-axis ( device -- ? )
68 z-axis-matching-hash ?axis ;
69 : ?rx-axis ( device -- ? )
70 rx-axis-matching-hash ?axis ;
71 : ?ry-axis ( device -- ? )
72 ry-axis-matching-hash ?axis ;
73 : ?rz-axis ( device -- ? )
74 rz-axis-matching-hash ?axis ;
75 : ?slider ( device -- ? )
76 slider-matching-hash ?axis ;
77 : ?hat-switch ( device -- ? )
78 hat-switch-matching-hash ?axis ;
80 : hid-manager-matching-game-devices ( -- alien )
81 game-devices-matching-seq hid-manager-matching ;
83 : device-property ( device key -- value )
84 <NSString> IOHIDDeviceGetProperty plist> ;
85 : element-property ( element key -- value )
86 <NSString> IOHIDElementGetProperty plist> ;
87 : set-element-property ( element key value -- )
88 [ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
89 : transfer-element-property ( element from-key to-key -- )
90 [ dupd element-property ] dip swap set-element-property ;
92 : controller-device? ( device -- ? )
94 [ 1 4 IOHIDDeviceConformsTo ]
95 [ 1 5 IOHIDDeviceConformsTo ]
98 : element-usage ( element -- {usage-page,usage} )
99 [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
102 : button? ( {usage-page,usage} -- ? )
104 : keyboard-key? ( {usage-page,usage} -- ? )
106 : x-axis? ( {usage-page,usage} -- ? )
107 { 1 HEX: 30 } = ; inline
108 : y-axis? ( {usage-page,usage} -- ? )
109 { 1 HEX: 31 } = ; inline
110 : z-axis? ( {usage-page,usage} -- ? )
111 { 1 HEX: 32 } = ; inline
112 : rx-axis? ( {usage-page,usage} -- ? )
113 { 1 HEX: 33 } = ; inline
114 : ry-axis? ( {usage-page,usage} -- ? )
115 { 1 HEX: 34 } = ; inline
116 : rz-axis? ( {usage-page,usage} -- ? )
117 { 1 HEX: 35 } = ; inline
118 : slider? ( {usage-page,usage} -- ? )
119 { 1 HEX: 36 } = ; inline
120 : hat-switch? ( {usage-page,usage} -- ? )
121 { 1 HEX: 39 } = ; inline
125 pov-up pov-up-right pov-right pov-down-right
126 pov-down pov-down-left pov-left pov-up-left
130 : button-value ( value -- f/(0,1] )
131 IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
132 : axis-value ( value -- [-1,1] )
133 kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
134 : pov-value ( value -- pov-direction )
135 IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
137 : record-controller ( controller-state value -- )
138 dup IOHIDValueGetElement element-usage {
139 { [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] }
140 { [ dup x-axis? ] [ drop axis-value >>x drop ] }
141 { [ dup y-axis? ] [ drop axis-value >>y drop ] }
142 { [ dup z-axis? ] [ drop axis-value >>z drop ] }
143 { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
144 { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
145 { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
146 { [ dup slider? ] [ drop axis-value >>slider drop ] }
147 { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
151 SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
153 : ?set-nth ( value nth seq -- )
154 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
156 : record-keyboard ( value -- )
157 dup IOHIDValueGetElement element-usage keyboard-key? [
158 [ IOHIDValueGetIntegerValue c-bool> ]
159 [ IOHIDValueGetElement IOHIDElementGetUsage ] bi
160 +keyboard-state+ get ?set-nth
163 : default-calibrate-saturation ( element -- )
164 [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
165 [ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ]
168 : default-calibrate-axis ( element -- )
169 [ kIOHIDElementCalibrationMinKey -1.0 set-element-property ]
170 [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
171 [ default-calibrate-saturation ]
174 : default-calibrate-slider ( element -- )
175 [ kIOHIDElementCalibrationMinKey 0.0 set-element-property ]
176 [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
177 [ default-calibrate-saturation ]
180 : (default) ( ? quot -- )
183 : <device-controller-state> ( device -- controller-state )
185 [ ?x-axis [ default-calibrate-axis 0.0 ] (default) ]
186 [ ?y-axis [ default-calibrate-axis 0.0 ] (default) ]
187 [ ?z-axis [ default-calibrate-axis 0.0 ] (default) ]
188 [ ?rx-axis [ default-calibrate-axis 0.0 ] (default) ]
189 [ ?ry-axis [ default-calibrate-axis 0.0 ] (default) ]
190 [ ?rz-axis [ default-calibrate-axis 0.0 ] (default) ]
191 [ ?slider [ default-calibrate-slider 0.0 ] (default) ]
192 [ ?hat-switch pov-neutral and ]
193 [ button-count f <array> ]
194 } cleave controller-state boa ;
196 : device-matched-callback ( -- alien )
197 [| context result sender device |
198 device controller-device? [
199 device <device-controller-state>
200 device +controller-states+ get set-at
202 ] IOHIDDeviceCallback ;
204 : device-removed-callback ( -- alien )
205 [| context result sender device |
206 device +controller-states+ get delete-at
207 ] IOHIDDeviceCallback ;
209 : device-input-callback ( -- alien )
210 [| context result sender value |
211 sender controller-device?
212 [ sender +controller-states+ get at value record-controller ]
213 [ value record-keyboard ]
215 ] IOHIDValueCallback ;
217 : initialize-variables ( manager -- )
218 +hid-manager+ set-global
219 4 <vector> +controller-states+ set-global
220 256 f <array> +keyboard-state+ set-global ;
222 M: iokit-game-input-backend (open-game-input)
223 hid-manager-matching-game-devices {
224 [ initialize-variables ]
225 [ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
226 [ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
227 [ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
228 [ 0 IOHIDManagerOpen mach-error ]
230 CFRunLoopGetMain CFRunLoopDefaultMode
231 IOHIDManagerScheduleWithRunLoop
235 M: iokit-game-input-backend (reset-game-input)
236 { +hid-manager+ +keyboard-state+ +controller-states+ }
237 [ f swap set-global ] each ;
239 M: iokit-game-input-backend (close-game-input)
240 +hid-manager+ get-global [
241 +hid-manager+ global [
243 CFRunLoopGetMain CFRunLoopDefaultMode
244 IOHIDManagerUnscheduleFromRunLoop
246 [ 0 IOHIDManagerClose drop ]
250 f +keyboard-state+ set-global
251 f +controller-states+ set-global
254 M: iokit-game-input-backend get-controllers ( -- sequence )
255 +controller-states+ get keys [ controller boa ] map ;
257 : ?join ( pre post sep -- string )
258 2over start [ swap 2nip ] [ [ 2array ] dip join ] if ;
260 M: iokit-game-input-backend product-string ( controller -- string )
262 [ kIOHIDManufacturerKey device-property ]
263 [ kIOHIDProductKey device-property ] bi " " ?join ;
264 M: iokit-game-input-backend product-id ( controller -- integer )
266 [ kIOHIDVendorIDKey device-property ]
267 [ kIOHIDProductIDKey device-property ] bi 2array ;
268 M: iokit-game-input-backend instance-id ( controller -- integer )
269 handle>> kIOHIDLocationIDKey device-property ;
271 M: iokit-game-input-backend read-controller ( controller -- controller-state )
272 handle>> +controller-states+ get at clone ;
274 M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
275 +keyboard-state+ get clone keyboard-state boa ;
277 M: iokit-game-input-backend calibrate-controller ( controller -- )