]> gitweb.factorcode.org Git - factor.git/blob - extra/game-input/backend/dinput/dinput.factor
Merge branch 'master' into experimental (untested!)
[factor.git] / extra / game-input / backend / dinput / dinput.factor
1 USING: windows.dinput windows.dinput.constants parser symbols
2 alien.c-types windows.ole32 namespaces assocs kernel arrays
3 vectors windows.kernel32 windows.com windows.dinput shuffle
4 windows.user32 windows.messages sequences combinators
5 math.geometry.rect ui.windows accessors math windows alien
6 alien.strings io.encodings.utf16 io.encodings.utf16n
7 continuations byte-arrays locals
8 game-input.backend.dinput.keys-array ;
9 << "game-input" (use+) >>
10 IN: game-input.backend.dinput
11
12 SINGLETON: dinput-game-input-backend
13
14 SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
15     +controller-devices+ +controller-guids+
16     +device-change-window+ +device-change-handle+ ;
17
18 : create-dinput ( -- )
19     f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
20     f <void*> [ f DirectInput8Create ole32-error ] keep *void*
21     +dinput+ set-global ;
22
23 : delete-dinput ( -- )
24     +dinput+ global [ com-release f ] change-at ;
25
26 : device-for-guid ( guid -- device )
27     +dinput+ get swap f <void*>
28     [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
29
30 : set-coop-level ( device -- )
31     +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
32     IDirectInputDevice8W::SetCooperativeLevel ole32-error ;
33
34 : set-data-format ( device format-symbol -- )
35     get IDirectInputDevice8W::SetDataFormat ole32-error ;
36
37 : configure-keyboard ( keyboard -- )
38     [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
39 : configure-controller ( controller -- )
40     [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ;
41
42 : find-keyboard ( -- )
43     GUID_SysKeyboard device-for-guid
44     [ configure-keyboard ]
45     [ +keyboard-device+ set-global ] bi
46     256 <byte-array> <keys-array> keyboard-state boa
47     +keyboard-state+ set-global ;
48
49 : device-info ( device -- DIDEVICEIMAGEINFOW )
50     "DIDEVICEINSTANCEW" <c-object>
51     "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
52     [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ;
53 : device-caps ( device -- DIDEVCAPS )
54     "DIDEVCAPS" <c-object>
55     "DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize
56     [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ;
57
58 : <guid> ( memory -- byte-array )
59     "GUID" heap-size memory>byte-array ;
60
61 : device-guid ( device -- guid )
62     device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
63
64 : device-attached? ( device -- ? )
65     +dinput+ get swap device-guid
66     IDirectInput8W::GetDeviceStatus S_OK = ;
67
68 : find-device-axes-callback ( -- alien )
69     [ ! ( lpddoi pvRef -- BOOL )
70         +controller-devices+ get at
71         swap DIDEVICEOBJECTINSTANCEW-guidType <guid> {
72             { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
73             { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
74             { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
75             { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] }
76             { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] }
77             { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] }
78             { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] }
79             [ drop ]
80         } cond drop
81         DIENUM_CONTINUE
82     ] LPDIENUMDEVICEOBJECTSCALLBACKW ;
83
84 : find-device-axes ( device controller-state -- controller-state )
85     swap [ +controller-devices+ get set-at ] 2keep
86     find-device-axes-callback over DIDFT_AXIS
87     IDirectInputDevice8W::EnumObjects ole32-error ;
88
89 : controller-state-template ( device -- controller-state )
90     controller-state new
91     over device-caps
92     [ DIDEVCAPS-dwButtons f <array> >>buttons ]
93     [ DIDEVCAPS-dwPOVs zero? f pov-neutral ? >>pov ] bi
94     find-device-axes ;
95
96 : device-known? ( guid -- ? )
97     +controller-guids+ get key? ; inline
98
99 : (add-controller) ( guid -- )
100     device-for-guid {
101         [ configure-controller ]
102         [ controller-state-template ]
103         [ dup device-guid +controller-guids+ get set-at ]
104         [ +controller-devices+ get set-at ]
105     } cleave ;
106
107 : add-controller ( guid -- )
108     dup <guid> device-known? [ drop ] [ (add-controller) ] if ;
109
110 : remove-controller ( device -- )
111     [ +controller-devices+ get delete-at ]
112     [ device-guid +controller-guids+ get delete-at ]
113     [ com-release ] tri ;
114
115 : find-controller-callback ( -- alien )
116     [ ! ( lpddi pvRef -- BOOL )
117         drop DIDEVICEINSTANCEW-guidInstance add-controller
118         DIENUM_CONTINUE
119     ] LPDIENUMDEVICESCALLBACKW ;
120
121 : find-controllers ( -- )
122     +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
123     f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ;
124
125 : set-up-controllers ( -- )
126     4 <vector> +controller-devices+ set-global
127     4 <vector> +controller-guids+ set-global
128     find-controllers ;
129
130 : find-and-remove-detached-devices ( -- )
131     +controller-devices+ get keys
132     [ device-attached? not ] filter
133     [ remove-controller ] each ;
134
135 : device-interface? ( dbt-broadcast-hdr -- ? )
136     DEV_BROADCAST_HDR-dbch_devicetype DBT_DEVTYP_DEVICEINTERFACE = ;
137
138 : device-arrived ( dbt-broadcast-hdr -- )
139     device-interface? [ find-controllers ] when ;
140
141 : device-removed ( dbt-broadcast-hdr -- )
142     device-interface? [ find-and-remove-detached-devices ] when ;
143
144 : handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
145     [ 2drop ] 2dip swap {
146         { [ dup DBT_DEVICEARRIVAL = ]         [ drop <alien> device-arrived ] }
147         { [ dup DBT_DEVICEREMOVECOMPLETE = ]  [ drop <alien> device-removed ] }
148         [ 2drop ]
149     } cond ;
150
151 TUPLE: window-rect < rect window-loc ;
152 : <zero-window-rect> ( -- window-rect )
153     window-rect new
154     { 0 0 } >>window-loc
155     { 0 0 } >>loc
156     { 0 0 } >>dim ;
157
158 : (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
159     "DEV_BROADCAST_DEVICEW" <c-object>
160     "DEV_BROADCAST_DEVICEW" heap-size over set-DEV_BROADCAST_DEVICEW-dbcc_size
161     DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
162
163 : create-device-change-window ( -- )
164     <zero-window-rect> create-window
165     [
166         (device-notification-filter)
167         DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor
168         RegisterDeviceNotification
169         +device-change-handle+ set-global
170     ]
171     [ +device-change-window+ set-global ] bi ;
172
173 : close-device-change-window ( -- )
174     +device-change-handle+ global
175     [ UnregisterDeviceNotification drop f ] change-at
176     +device-change-window+ global
177     [ DestroyWindow win32-error=0/f f ] change-at ;
178
179 : add-wm-devicechange ( -- )
180     [ 4dup handle-wm-devicechange DefWindowProc ]
181     WM_DEVICECHANGE add-wm-handler ;
182
183 : remove-wm-devicechange ( -- )
184     WM_DEVICECHANGE wm-handlers get-global delete-at ;
185
186 : release-controllers ( -- )
187     +controller-devices+ global [
188         [ drop com-release ] assoc-each f
189     ] change-at
190     f +controller-guids+ set-global ;
191
192 : release-keyboard ( -- )
193     +keyboard-device+ global
194     [ com-release f ] change-at
195     f +keyboard-state+ set-global ;
196
197 M: dinput-game-input-backend (open-game-input)
198     create-dinput
199     create-device-change-window
200     find-keyboard
201     set-up-controllers
202     add-wm-devicechange ;
203
204 M: dinput-game-input-backend (close-game-input)
205     remove-wm-devicechange
206     release-controllers
207     release-keyboard
208     close-device-change-window
209     delete-dinput ;
210
211 M: dinput-game-input-backend (reset-game-input)
212     {
213         +dinput+ +keyboard-device+ +keyboard-state+
214         +controller-devices+ +controller-guids+
215         +device-change-window+ +device-change-handle+
216     } [ f swap set-global ] each ;
217
218 M: dinput-game-input-backend get-controllers
219     +controller-devices+ get
220     [ drop controller boa ] { } assoc>map ;
221
222 M: dinput-game-input-backend product-string
223     handle>> device-info DIDEVICEINSTANCEW-tszProductName
224     utf16n alien>string ;
225
226 M: dinput-game-input-backend product-id
227     handle>> device-info DIDEVICEINSTANCEW-guidProduct <guid> ;
228 M: dinput-game-input-backend instance-id
229     handle>> device-guid ;
230
231 :: with-acquisition ( device acquired-quot succeeded-quot failed-quot -- result/f )
232     device IDirectInputDevice8W::Acquire succeeded? [
233         device acquired-quot call
234         succeeded-quot call
235     ] failed-quot if ; inline
236
237 : pov-values
238     {
239         pov-up pov-up-right pov-right pov-down-right
240         pov-down pov-down-left pov-left pov-up-left
241     } ; inline
242
243 : >axis ( long -- float )
244     32767 - 32767.0 /f ;
245 : >slider ( long -- float )
246     65535.0 /f ;
247 : >pov ( long -- symbol )
248     dup HEX: FFFF bitand HEX: FFFF =
249     [ drop pov-neutral ]
250     [ 2750 + 4500 /i pov-values nth ] if ;
251 : >buttons ( alien length -- array )
252     memory>byte-array <keys-array> ;
253
254 : (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
255     [ drop ] compose [ 2drop ] if ; inline
256
257 : fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
258     {
259         [ over x>> [ DIJOYSTATE2-lX >axis >>x ] (fill-if) ]
260         [ over y>> [ DIJOYSTATE2-lY >axis >>y ] (fill-if) ]
261         [ over z>> [ DIJOYSTATE2-lZ >axis >>z ] (fill-if) ]
262         [ over rx>> [ DIJOYSTATE2-lRx >axis >>rx ] (fill-if) ]
263         [ over ry>> [ DIJOYSTATE2-lRy >axis >>ry ] (fill-if) ]
264         [ over rz>> [ DIJOYSTATE2-lRz >axis >>rz ] (fill-if) ]
265         [ over slider>> [ DIJOYSTATE2-rglSlider *long >slider >>slider ] (fill-if) ]
266         [ over pov>> [ DIJOYSTATE2-rgdwPOV *uint >pov >>pov ] (fill-if) ]
267         [ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
268     } 2cleave ;
269
270 : get-device-state ( device byte-array -- )
271     [ dup IDirectInputDevice8W::Poll ole32-error ] dip
272     [ length ] keep
273     IDirectInputDevice8W::GetDeviceState ole32-error ;
274
275 : (read-controller) ( handle template -- state )
276     swap [ "DIJOYSTATE2" heap-size <byte-array> [ get-device-state ] keep ]
277     [ fill-controller-state ] [ drop f ] with-acquisition ;
278
279 M: dinput-game-input-backend read-controller
280     handle>> dup +controller-devices+ get at
281     [ (read-controller) ] [ drop f ] if* ;
282
283 M: dinput-game-input-backend calibrate-controller
284     handle>> f 0 IDirectInputDevice8W::RunControlPanel ole32-error ;
285
286 M: dinput-game-input-backend read-keyboard
287     +keyboard-device+ get
288     [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
289     [ ] [ f ] with-acquisition ;