1 USING: accessors alien alien.c-types alien.strings arrays
2 assocs byte-arrays combinators continuations game-input
3 game-input.dinput.keys-array io.encodings.utf16
4 io.encodings.utf16n kernel locals math math.bitwise
5 math.rectangles namespaces parser sequences shuffle
6 struct-arrays ui.backend.windows vectors windows.com
7 windows.dinput windows.dinput.constants windows.errors
8 windows.kernel32 windows.messages windows.ole32
9 windows.user32 classes.struct ;
11 CONSTANT: MOUSE-BUFFER-SIZE 16
13 SINGLETON: dinput-game-input-backend
15 dinput-game-input-backend game-input-backend set-global
17 SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
18 +controller-devices+ +controller-guids+
19 +device-change-window+ +device-change-handle+
20 +mouse-device+ +mouse-state+ +mouse-buffer+ ;
22 : create-dinput ( -- )
23 f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
24 f <void*> [ f DirectInput8Create ole32-error ] keep *void*
27 : delete-dinput ( -- )
28 +dinput+ [ com-release f ] change-global ;
30 : device-for-guid ( guid -- device )
31 +dinput+ get swap f <void*>
32 [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
34 : set-coop-level ( device -- )
35 +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
36 IDirectInputDevice8W::SetCooperativeLevel ole32-error ;
38 : set-data-format ( device format-symbol -- )
39 get IDirectInputDevice8W::SetDataFormat ole32-error ;
41 : <buffer-size-diprop> ( size -- DIPROPDWORD )
42 "DIPROPDWORD" <c-object>
43 "DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize
44 "DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize
45 0 over set-DIPROPHEADER-dwObj
46 DIPH_DEVICE over set-DIPROPHEADER-dwHow
47 swap over set-DIPROPDWORD-dwData ;
49 : set-buffer-size ( device size -- )
50 DIPROP_BUFFERSIZE swap <buffer-size-diprop>
51 IDirectInputDevice8W::SetProperty ole32-error ;
53 : configure-keyboard ( keyboard -- )
54 [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
55 : configure-mouse ( mouse -- )
56 [ c_dfDIMouse2 set-data-format ]
57 [ MOUSE-BUFFER-SIZE set-buffer-size ]
58 [ set-coop-level ] tri ;
59 : configure-controller ( controller -- )
60 [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ;
62 : find-keyboard ( -- )
63 GUID_SysKeyboard device-for-guid
64 [ configure-keyboard ]
65 [ +keyboard-device+ set-global ] bi
66 256 <byte-array> <keys-array> keyboard-state boa
67 +keyboard-state+ set-global ;
70 GUID_SysMouse device-for-guid
72 [ +mouse-device+ set-global ] bi
73 0 0 0 0 8 f <array> mouse-state boa
74 +mouse-state+ set-global
75 MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" <c-array>
76 +mouse-buffer+ set-global ;
78 : device-info ( device -- DIDEVICEIMAGEINFOW )
79 "DIDEVICEINSTANCEW" <c-object>
80 "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
81 [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ;
82 : device-caps ( device -- DIDEVCAPS )
83 "DIDEVCAPS" <c-object>
84 "DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize
85 [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ;
87 : <guid> ( memory -- byte-array )
88 "GUID" heap-size memory>byte-array ;
90 : device-guid ( device -- guid )
91 device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
93 : device-attached? ( device -- ? )
94 +dinput+ get swap device-guid
95 IDirectInput8W::GetDeviceStatus S_OK = ;
97 : find-device-axes-callback ( -- alien )
98 [ ! ( lpddoi pvRef -- BOOL )
99 +controller-devices+ get at
100 swap DIDEVICEOBJECTINSTANCEW-guidType <guid> {
101 { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
102 { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
103 { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
104 { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] }
105 { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] }
106 { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] }
107 { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] }
111 ] LPDIENUMDEVICEOBJECTSCALLBACKW ;
113 : find-device-axes ( device controller-state -- controller-state )
114 swap [ +controller-devices+ get set-at ] 2keep
115 find-device-axes-callback over DIDFT_AXIS
116 IDirectInputDevice8W::EnumObjects ole32-error ;
118 : controller-state-template ( device -- controller-state )
121 [ DIDEVCAPS-dwButtons f <array> >>buttons ]
122 [ DIDEVCAPS-dwPOVs zero? f pov-neutral ? >>pov ] bi
125 : device-known? ( guid -- ? )
126 +controller-guids+ get key? ; inline
128 : (add-controller) ( guid -- )
130 [ configure-controller ]
131 [ controller-state-template ]
132 [ dup device-guid +controller-guids+ get set-at ]
133 [ +controller-devices+ get set-at ]
136 : add-controller ( guid -- )
137 dup <guid> device-known? [ drop ] [ (add-controller) ] if ;
139 : remove-controller ( device -- )
140 [ +controller-devices+ get delete-at ]
141 [ device-guid +controller-guids+ get delete-at ]
142 [ com-release ] tri ;
144 : find-controller-callback ( -- alien )
145 [ ! ( lpddi pvRef -- BOOL )
146 drop DIDEVICEINSTANCEW-guidInstance add-controller
148 ] LPDIENUMDEVICESCALLBACKW ;
150 : find-controllers ( -- )
151 +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
152 f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ;
154 : set-up-controllers ( -- )
155 4 <vector> +controller-devices+ set-global
156 4 <vector> +controller-guids+ set-global
159 : find-and-remove-detached-devices ( -- )
160 +controller-devices+ get keys
161 [ device-attached? not ] filter
162 [ remove-controller ] each ;
164 : device-interface? ( dbt-broadcast-hdr -- ? )
165 dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE = ;
167 : device-arrived ( dbt-broadcast-hdr -- )
168 device-interface? [ find-controllers ] when ;
170 : device-removed ( dbt-broadcast-hdr -- )
171 device-interface? [ find-and-remove-detached-devices ] when ;
173 : handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
174 [ 2drop ] 2dip swap {
175 { [ dup DBT_DEVICEARRIVAL = ] [ drop <alien> device-arrived ] }
176 { [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <alien> device-removed ] }
180 TUPLE: window-rect < rect window-loc ;
181 : <zero-window-rect> ( -- window-rect )
187 : (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
188 DEV_BROADCAST_DEVICEW <struct>
189 DEV_BROADCAST_DEVICEW heap-size >>dbcc_size
190 DBT_DEVTYP_DEVICEINTERFACE >>dbcc_devicetype ;
192 : create-device-change-window ( -- )
193 <zero-window-rect> WS_OVERLAPPEDWINDOW 0 create-window
195 (device-notification-filter)
196 DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor
197 RegisterDeviceNotification
198 +device-change-handle+ set-global
200 [ +device-change-window+ set-global ] bi ;
202 : close-device-change-window ( -- )
203 +device-change-handle+ [ UnregisterDeviceNotification drop f ] change-global
204 +device-change-window+ [ DestroyWindow win32-error=0/f f ] change-global ;
206 : add-wm-devicechange ( -- )
207 [ 4dup handle-wm-devicechange DefWindowProc ]
208 WM_DEVICECHANGE add-wm-handler ;
210 : remove-wm-devicechange ( -- )
211 WM_DEVICECHANGE wm-handlers get-global delete-at ;
213 : release-controllers ( -- )
214 +controller-devices+ [ [ drop com-release ] assoc-each f ] change-global
215 f +controller-guids+ set-global ;
217 : release-keyboard ( -- )
218 +keyboard-device+ [ com-release f ] change-global
219 f +keyboard-state+ set-global ;
221 : release-mouse ( -- )
222 +mouse-device+ [ com-release f ] change-global
223 f +mouse-state+ set-global ;
225 M: dinput-game-input-backend (open-game-input)
227 create-device-change-window
231 add-wm-devicechange ;
233 M: dinput-game-input-backend (close-game-input)
234 remove-wm-devicechange
238 close-device-change-window
241 M: dinput-game-input-backend (reset-game-input)
244 +dinput+ +keyboard-device+ +keyboard-state+
245 +controller-devices+ +controller-guids+
246 +device-change-window+ +device-change-handle+
250 M: dinput-game-input-backend get-controllers
251 +controller-devices+ get
252 [ drop controller boa ] { } assoc>map ;
254 M: dinput-game-input-backend product-string
255 handle>> device-info DIDEVICEINSTANCEW-tszProductName
256 utf16n alien>string ;
258 M: dinput-game-input-backend product-id
259 handle>> device-info DIDEVICEINSTANCEW-guidProduct <guid> ;
260 M: dinput-game-input-backend instance-id
261 handle>> device-guid ;
263 :: with-acquisition ( device acquired-quot succeeded-quot failed-quot -- result/f )
264 device IDirectInputDevice8W::Acquire succeeded? [
265 device acquired-quot call
267 ] failed-quot if ; inline
271 pov-up pov-up-right pov-right pov-down-right
272 pov-down pov-down-left pov-left pov-up-left
275 : >axis ( long -- float )
277 : >slider ( long -- float )
279 : >pov ( long -- symbol )
280 dup HEX: FFFF bitand HEX: FFFF =
282 [ 2750 + 4500 /i pov-values nth ] if ;
283 : >buttons ( alien length -- array )
284 memory>byte-array <keys-array> ;
286 : (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
287 [ drop ] compose [ 2drop ] if ; inline
289 : fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
291 [ over x>> [ DIJOYSTATE2-lX >axis >>x ] (fill-if) ]
292 [ over y>> [ DIJOYSTATE2-lY >axis >>y ] (fill-if) ]
293 [ over z>> [ DIJOYSTATE2-lZ >axis >>z ] (fill-if) ]
294 [ over rx>> [ DIJOYSTATE2-lRx >axis >>rx ] (fill-if) ]
295 [ over ry>> [ DIJOYSTATE2-lRy >axis >>ry ] (fill-if) ]
296 [ over rz>> [ DIJOYSTATE2-lRz >axis >>rz ] (fill-if) ]
297 [ over slider>> [ DIJOYSTATE2-rglSlider *long >slider >>slider ] (fill-if) ]
298 [ over pov>> [ DIJOYSTATE2-rgdwPOV *uint >pov >>pov ] (fill-if) ]
299 [ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
302 : read-device-buffer ( device buffer count -- buffer count' )
303 [ "DIDEVICEOBJECTDATA" heap-size ] 2dip <uint>
304 [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
306 : (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
307 [ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-dwOfs ] bi {
308 { DIMOFS_X [ [ + ] curry change-dx ] }
309 { DIMOFS_Y [ [ + ] curry change-dy ] }
310 { DIMOFS_Z [ [ + ] curry change-scroll-dy ] }
311 [ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot [ buttons>> set-nth ] keep ]
314 : fill-mouse-state ( buffer count -- state )
315 [ +mouse-state+ get ] 2dip swap
316 [ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ;
318 : get-device-state ( device byte-array -- )
319 [ dup IDirectInputDevice8W::Poll ole32-error ] dip
321 IDirectInputDevice8W::GetDeviceState ole32-error ;
323 : (read-controller) ( handle template -- state )
324 swap [ "DIJOYSTATE2" heap-size <byte-array> [ get-device-state ] keep ]
325 [ fill-controller-state ] [ drop f ] with-acquisition ;
327 M: dinput-game-input-backend read-controller
328 handle>> dup +controller-devices+ get at
329 [ (read-controller) ] [ drop f ] if* ;
331 M: dinput-game-input-backend calibrate-controller
332 handle>> f 0 IDirectInputDevice8W::RunControlPanel ole32-error ;
334 M: dinput-game-input-backend read-keyboard
335 +keyboard-device+ get
336 [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
337 [ ] [ f ] with-acquisition ;
339 M: dinput-game-input-backend read-mouse
340 +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ]
341 [ fill-mouse-state ] [ f ] with-acquisition ;
343 M: dinput-game-input-backend reset-mouse
344 +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ]
345 [ 2drop ] [ ] with-acquisition