1 USING: accessors alien alien.c-types alien.data alien.strings
2 arrays assocs byte-arrays classes.struct combinators
3 combinators.short-circuit game.input
4 game.input.dinput.keys-array kernel locals math math.bitwise
5 math.rectangles namespaces sequences specialized-arrays
6 ui.backend.windows vectors windows.com windows.directx.dinput
7 windows.directx.dinput.constants windows.errors windows.kernel32
8 windows.messages windows.ole32 windows.user32 ;
9 SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA
12 CONSTANT: MOUSE-BUFFER-SIZE 16
14 SINGLETON: dinput-game-input-backend
16 dinput-game-input-backend game-input-backend set-global
18 SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
19 +controller-devices+ +controller-guids+
20 +device-change-window+ +device-change-handle+
21 +mouse-device+ +mouse-state+ +mouse-buffer+ ;
23 : create-dinput ( -- )
24 f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
25 f void* <ref> [ f DirectInput8Create check-ole32-error ] keep void* deref
28 : delete-dinput ( -- )
29 +dinput+ [ com-release f ] change-global ;
31 : device-for-guid ( guid -- device )
32 +dinput+ get-global swap f void* <ref>
33 [ f IDirectInput8W::CreateDevice check-ole32-error ] keep void* deref ;
35 : set-coop-level ( device -- )
36 +device-change-window+ get-global DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
37 IDirectInputDevice8W::SetCooperativeLevel check-ole32-error ; inline
39 : set-data-format ( device format-symbol -- )
40 get-global IDirectInputDevice8W::SetDataFormat check-ole32-error ; inline
42 : <buffer-size-diprop> ( size -- DIPROPDWORD )
43 DIPROPDWORD <struct> [
45 DIPROPDWORD heap-size >>dwSize
46 DIPROPHEADER heap-size >>dwHeaderSize
50 ] keep swap >>dwData ;
52 : set-buffer-size ( device size -- )
53 DIPROP_BUFFERSIZE swap <buffer-size-diprop>
54 IDirectInputDevice8W::SetProperty check-ole32-error ;
56 : configure-keyboard ( keyboard -- )
57 [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
58 : configure-mouse ( mouse -- )
59 [ c_dfDIMouse2 set-data-format ]
60 [ MOUSE-BUFFER-SIZE set-buffer-size ]
61 [ set-coop-level ] tri ;
62 : configure-controller ( controller -- )
63 [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ;
65 : find-keyboard ( -- )
66 GUID_SysKeyboard device-for-guid
67 [ configure-keyboard ]
68 [ +keyboard-device+ set-global ] bi
69 256 <byte-array> 256 <keys-array> keyboard-state boa
70 +keyboard-state+ set-global ;
73 GUID_SysMouse device-for-guid
74 [ configure-mouse ] [ +mouse-device+ set-global ] bi
75 0 0 0 0 8 f <array> mouse-state boa +mouse-state+ set-global
76 MOUSE-BUFFER-SIZE DIDEVICEOBJECTDATA <c-array> +mouse-buffer+ set-global ;
78 : device-info ( device -- DIDEVICEIMAGEINFOW )
79 DIDEVICEINSTANCEW <struct>
80 DIDEVICEINSTANCEW heap-size >>dwSize
81 [ IDirectInputDevice8W::GetDeviceInfo check-ole32-error ] keep ; inline
82 : device-caps ( device -- DIDEVCAPS )
84 DIDEVCAPS heap-size >>dwSize
85 [ IDirectInputDevice8W::GetCapabilities check-ole32-error ] keep ; inline
87 : device-guid ( device -- guid )
88 device-info guidInstance>> ; inline
90 : device-attached? ( device -- ? )
91 +dinput+ get swap device-guid
92 IDirectInput8W::GetDeviceStatus S_OK = ;
94 : (find-device-axes-callback) ( lpddoi pvRef -- BOOL )
95 +controller-devices+ get-global at
97 { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
98 { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
99 { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
100 { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] }
101 { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] }
102 { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] }
103 { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] }
108 : find-device-axes-callback ( -- alien )
109 [ (find-device-axes-callback) ] LPDIENUMDEVICEOBJECTSCALLBACKW ;
111 : find-device-axes ( device controller-state -- controller-state )
112 swap [ +controller-devices+ get-global set-at ] 2keep
113 find-device-axes-callback over DIDFT_AXIS
114 IDirectInputDevice8W::EnumObjects check-ole32-error ;
116 : controller-state-template ( device -- controller-state )
119 [ dwButtons>> f <array> >>buttons ]
120 [ dwPOVs>> zero? f pov-neutral ? >>pov ] bi
123 : device-known? ( guid -- ? )
124 +controller-guids+ get-global key? ; inline
126 : (add-controller) ( guid -- )
128 [ configure-controller ]
129 [ controller-state-template ]
130 [ dup device-guid clone +controller-guids+ get-global set-at ]
131 [ +controller-devices+ get-global set-at ]
134 : add-controller ( guid -- )
135 dup device-known? [ drop ] [ (add-controller) ] if ;
137 : remove-controller ( device -- )
138 [ +controller-devices+ get-global delete-at ]
139 [ device-guid +controller-guids+ get-global delete-at ]
140 [ com-release ] tri ;
142 : (find-controller-callback) ( lpddi pvRef -- BOOL )
143 drop guidInstance>> add-controller
146 : find-controller-callback ( -- alien )
147 [ (find-controller-callback) ] LPDIENUMDEVICESCALLBACKW ;
149 : find-controllers ( -- )
150 +dinput+ get-global DI8DEVCLASS_GAMECTRL find-controller-callback
151 f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices check-ole32-error ;
153 : set-up-controllers ( -- )
154 4 <vector> +controller-devices+ set-global
155 4 <vector> +controller-guids+ set-global
158 : find-and-remove-detached-devices ( -- )
159 +controller-devices+ get-global keys
160 [ device-attached? ] reject
161 [ remove-controller ] each ;
163 : ?device-interface ( dbt-broadcast-hdr -- ? )
164 dup dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE =
165 [ >c-ptr DEV_BROADCAST_DEVICEW memory>struct ]
166 [ drop f ] if ; inline
168 : device-arrived ( dbt-broadcast-hdr -- )
169 ?device-interface [ find-controllers ] when ; inline
171 : device-removed ( dbt-broadcast-hdr -- )
172 ?device-interface [ find-and-remove-detached-devices ] when ; inline
174 : <DEV_BROADCAST_HDR> ( wParam -- struct )
175 <alien> DEV_BROADCAST_HDR memory>struct ;
177 : handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
179 { [ dup DBT_DEVICEARRIVAL = ] [ drop <DEV_BROADCAST_HDR> device-arrived ] }
180 { [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <DEV_BROADCAST_HDR> device-removed ] }
184 TUPLE: window-rect < rect window-loc ;
185 : <zero-window-rect> ( -- window-rect )
191 : (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
192 DEV_BROADCAST_DEVICEW <struct>
193 DEV_BROADCAST_DEVICEW heap-size >>dbcc_size
194 DBT_DEVTYP_DEVICEINTERFACE >>dbcc_devicetype ;
196 : create-device-change-window ( -- )
197 <zero-window-rect> WS_OVERLAPPEDWINDOW 0 create-window
199 (device-notification-filter)
200 DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor
201 RegisterDeviceNotification
202 +device-change-handle+ set-global
204 [ +device-change-window+ set-global ] bi ;
206 : close-device-change-window ( -- )
207 +device-change-handle+ [ UnregisterDeviceNotification drop f ] change-global
208 +device-change-window+ [ DestroyWindow win32-error=0/f f ] change-global ;
210 : add-wm-devicechange ( -- )
211 [ 4dup handle-wm-devicechange DefWindowProc ]
212 WM_DEVICECHANGE add-wm-handler ;
214 : remove-wm-devicechange ( -- )
215 WM_DEVICECHANGE wm-handlers get-global delete-at ;
217 : release-controllers ( -- )
218 +controller-devices+ [ [ drop com-release ] assoc-each f ] change-global
219 f +controller-guids+ set-global ;
221 : release-keyboard ( -- )
222 +keyboard-device+ [ com-release f ] change-global
223 f +keyboard-state+ set-global ;
225 : release-mouse ( -- )
226 +mouse-device+ [ com-release f ] change-global
227 f +mouse-state+ set-global ;
229 M: dinput-game-input-backend (open-game-input)
231 create-device-change-window
235 add-wm-devicechange ;
237 M: dinput-game-input-backend (close-game-input)
238 remove-wm-devicechange
242 close-device-change-window
245 M: dinput-game-input-backend (reset-game-input)
248 +dinput+ +keyboard-device+ +keyboard-state+
249 +controller-devices+ +controller-guids+
250 +device-change-window+ +device-change-handle+
254 M: dinput-game-input-backend get-controllers
255 +controller-devices+ get-global
256 [ drop controller boa ] { } assoc>map ;
258 M: dinput-game-input-backend product-string
259 handle>> device-info tszProductName>>
260 alien>native-string ;
262 M: dinput-game-input-backend product-id
263 handle>> device-info guidProduct>> ;
264 M: dinput-game-input-backend instance-id
265 handle>> device-guid ;
267 :: with-acquisition ( device acquired-quot succeeded-quot failed-quot -- result/f )
268 device { [ ] [ IDirectInputDevice8W::Acquire succeeded? ] } 1&& [
269 device acquired-quot call
271 ] failed-quot if ; inline
275 pov-up pov-up-right pov-right pov-down-right
276 pov-down pov-down-left pov-left pov-up-left
279 : >axis ( long -- float )
280 32767 - 32767.0 /f ; inline
281 : >slider ( long -- float )
283 : >pov ( long -- symbol )
284 dup 0xFFFF bitand 0xFFFF =
286 [ 2750 + 4500 /i pov-values nth ] if ; inline
288 : (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
289 [ drop ] compose [ 2drop ] if ; inline
291 : fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
293 [ over x>> [ lX>> >axis >>x ] (fill-if) ]
294 [ over y>> [ lY>> >axis >>y ] (fill-if) ]
295 [ over z>> [ lZ>> >axis >>z ] (fill-if) ]
296 [ over rx>> [ lRx>> >axis >>rx ] (fill-if) ]
297 [ over ry>> [ lRy>> >axis >>ry ] (fill-if) ]
298 [ over rz>> [ lRz>> >axis >>rz ] (fill-if) ]
299 [ over slider>> [ rglSlider>> first >slider >>slider ] (fill-if) ]
300 [ over pov>> [ rgdwPOV>> first >pov >>pov ] (fill-if) ]
301 [ rgbButtons>> over buttons>> length <keys-array> >>buttons ]
304 : read-device-buffer ( device buffer count -- buffer count' )
305 [ DIDEVICEOBJECTDATA heap-size ] 2dip uint <ref>
306 [ 0 IDirectInputDevice8W::GetDeviceData check-ole32-error ] 2keep uint deref ;
308 : (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
309 [ dwData>> 32 >signed ] [ dwOfs>> ] bi {
310 { DIMOFS_X [ [ + ] curry change-dx ] }
311 { DIMOFS_Y [ [ + ] curry change-dy ] }
312 { DIMOFS_Z [ [ + ] curry change-scroll-dy ] }
313 [ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot [ buttons>> set-nth ] keep ]
316 : fill-mouse-state ( buffer count -- state )
317 <iota> [ +mouse-state+ get-global ] 2dip swap [ nth (fill-mouse-state) ] curry each ;
319 : get-device-state ( device DIJOYSTATE2 -- )
320 [ dup IDirectInputDevice8W::Poll check-ole32-error ] dip
322 IDirectInputDevice8W::GetDeviceState check-ole32-error ;
324 : (read-controller) ( handle template -- state )
325 swap [ DIJOYSTATE2 <struct> [ get-device-state ] keep ]
326 [ fill-controller-state ] [ drop f ] with-acquisition ;
328 M: dinput-game-input-backend read-controller
329 handle>> dup +controller-devices+ get-global at
330 [ (read-controller) ] [ drop f ] if* ;
332 M: dinput-game-input-backend calibrate-controller
333 handle>> f 0 IDirectInputDevice8W::RunControlPanel check-ole32-error ;
335 M: dinput-game-input-backend read-keyboard
336 +keyboard-device+ get-global
337 [ +keyboard-state+ get-global [ keys>> underlying>> get-device-state ] keep ]
338 [ ] [ f ] with-acquisition ;
340 M: dinput-game-input-backend read-mouse
341 +mouse-device+ get-global [ +mouse-buffer+ get-global MOUSE-BUFFER-SIZE read-device-buffer ]
342 [ fill-mouse-state ] [ f ] with-acquisition ;
344 M: dinput-game-input-backend reset-mouse
345 +mouse-device+ get-global [ f MOUSE-BUFFER-SIZE read-device-buffer ]
346 [ 2drop ] [ ] with-acquisition
347 +mouse-state+ get-global