basis/game/input/dinput/dinput.factor

   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 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
  10 IN: game.input.dinput
  11
  12 CONSTANT: MOUSE-BUFFER-SIZE 16
  13
  14 SINGLETON: dinput-game-input-backend
  15
  16 dinput-game-input-backend game-input-backend set-global
  17
  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+ ;
  22
  23 : create-dinput ( -- )
  24     f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
  25     f void* <ref> [ f DirectInput8Create check-ole32-error ] keep void* deref
  26     +dinput+ set-global ;
  27
  28 : delete-dinput ( -- )
  29     +dinput+ [ com-release f ] change-global ;
  30
  31 : device-for-guid ( guid -- device )
  32     +dinput+ get-global swap f void* <ref>
  33     [ f IDirectInput8W::CreateDevice check-ole32-error ] keep void* deref ;
  34
  35 : set-coop-level ( device -- )
  36     +device-change-window+ get-global DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
  37     IDirectInputDevice8W::SetCooperativeLevel check-ole32-error ; inline
  38
  39 : set-data-format ( device format-symbol -- )
  40     get-global IDirectInputDevice8W::SetDataFormat check-ole32-error ; inline
  41
  42 : <buffer-size-diprop> ( size -- DIPROPDWORD )
  43     DIPROPDWORD new [
  44         diph>>
  45         DIPROPDWORD heap-size  >>dwSize
  46         DIPROPHEADER heap-size >>dwHeaderSize
  47         0           >>dwObj
  48         DIPH_DEVICE >>dwHow
  49         drop
  50     ] keep swap >>dwData ;
  51
  52 : set-buffer-size ( device size -- )
  53     DIPROP_BUFFERSIZE swap <buffer-size-diprop>
  54     IDirectInputDevice8W::SetProperty check-ole32-error ;
  55
  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 ;
  64
  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 ;
  71
  72 : find-mouse ( -- )
  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 ;
  77
  78 : device-info ( device -- DIDEVICEIMAGEINFOW )
  79     DIDEVICEINSTANCEW new
  80         DIDEVICEINSTANCEW heap-size >>dwSize
  81     [ IDirectInputDevice8W::GetDeviceInfo check-ole32-error ] keep ; inline
  82 : device-caps ( device -- DIDEVCAPS )
  83     DIDEVCAPS new
  84         DIDEVCAPS heap-size >>dwSize
  85     [ IDirectInputDevice8W::GetCapabilities check-ole32-error ] keep ; inline
  86
  87 : device-guid ( device -- guid )
  88     device-info guidInstance>> ; inline
  89
  90 : device-attached? ( device -- ? )
  91     +dinput+ get swap device-guid
  92     IDirectInput8W::GetDeviceStatus S_OK = ;
  93
  94 : (find-device-axes-callback) ( lpddoi pvRef -- BOOL )
  95     +controller-devices+ get-global at
  96     swap guidType>> {
  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 ] }
 104         [ drop ]
 105     } cond drop
 106     DIENUM_CONTINUE ;
 107
 108 : find-device-axes-callback ( -- alien )
 109     [ (find-device-axes-callback) ] LPDIENUMDEVICEOBJECTSCALLBACKW ;
 110
 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 ;
 115
 116 : controller-state-template ( device -- controller-state )
 117     controller-state new
 118     over device-caps
 119     [ dwButtons>> f <array> >>buttons ]
 120     [ dwPOVs>> zero? f pov-neutral ? >>pov ] bi
 121     find-device-axes ;
 122
 123 : device-known? ( guid -- ? )
 124     +controller-guids+ get-global key? ; inline
 125
 126 : (add-controller) ( guid -- )
 127     device-for-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 ]
 132     } cleave ;
 133
 134 : add-controller ( guid -- )
 135     dup device-known? [ drop ] [ (add-controller) ] if ;
 136
 137 : remove-controller ( device -- )
 138     [ +controller-devices+ get-global delete-at ]
 139     [ device-guid +controller-guids+ get-global delete-at ]
 140     [ com-release ] tri ;
 141
 142 : (find-controller-callback) ( lpddi pvRef -- BOOL )
 143     drop guidInstance>> add-controller
 144     DIENUM_CONTINUE ;
 145
 146 : find-controller-callback ( -- alien )
 147     [ (find-controller-callback) ] LPDIENUMDEVICESCALLBACKW ;
 148
 149 : find-controllers ( -- )
 150     +dinput+ get-global DI8DEVCLASS_GAMECTRL find-controller-callback
 151     f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices check-ole32-error ;
 152
 153 : set-up-controllers ( -- )
 154     4 <vector> +controller-devices+ set-global
 155     4 <vector> +controller-guids+ set-global
 156     find-controllers ;
 157
 158 : find-and-remove-detached-devices ( -- )
 159     +controller-devices+ get-global keys
 160     [ device-attached? ] reject
 161     [ remove-controller ] each ;
 162
 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
 167
 168 : device-arrived ( dbt-broadcast-hdr -- )
 169     ?device-interface [ find-controllers ] when ; inline
 170
 171 : device-removed ( dbt-broadcast-hdr -- )
 172     ?device-interface [ find-and-remove-detached-devices ] when ; inline
 173
 174 : <DEV_BROADCAST_HDR> ( wParam -- struct )
 175     <alien> DEV_BROADCAST_HDR memory>struct ;
 176
 177 : handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
 178     2nipd swap {
 179         { [ dup DBT_DEVICEARRIVAL = ]         [ drop <DEV_BROADCAST_HDR> device-arrived ] }
 180         { [ dup DBT_DEVICEREMOVECOMPLETE = ]  [ drop <DEV_BROADCAST_HDR> device-removed ] }
 181         [ 2drop ]
 182     } cond ;
 183
 184 TUPLE: window-rect < rect window-loc ;
 185 : <zero-window-rect> ( -- window-rect )
 186     window-rect new
 187     { 0 0 } >>window-loc
 188     { 0 0 } >>loc
 189     { 0 0 } >>dim ;
 190
 191 : (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
 192     DEV_BROADCAST_DEVICEW new
 193         DEV_BROADCAST_DEVICEW heap-size >>dbcc_size
 194         DBT_DEVTYP_DEVICEINTERFACE >>dbcc_devicetype ;
 195
 196 : create-device-change-window ( -- )
 197     <zero-window-rect> WS_OVERLAPPEDWINDOW 0 create-window
 198     [
 199         (device-notification-filter)
 200         DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor
 201         RegisterDeviceNotification
 202         +device-change-handle+ set-global
 203     ]
 204     [ +device-change-window+ set-global ] bi ;
 205
 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 ;
 209
 210 : add-wm-devicechange ( -- )
 211     [ 4dup handle-wm-devicechange DefWindowProc ]
 212     WM_DEVICECHANGE add-wm-handler ;
 213
 214 : remove-wm-devicechange ( -- )
 215     WM_DEVICECHANGE wm-handlers get-global delete-at ;
 216
 217 : release-controllers ( -- )
 218     +controller-devices+ [ [ drop com-release ] assoc-each f ] change-global
 219     f +controller-guids+ set-global ;
 220
 221 : release-keyboard ( -- )
 222     +keyboard-device+ [ com-release f ] change-global
 223     f +keyboard-state+ set-global ;
 224
 225 : release-mouse ( -- )
 226     +mouse-device+ [ com-release f ] change-global
 227     f +mouse-state+ set-global ;
 228
 229 M: dinput-game-input-backend (open-game-input)
 230     create-dinput
 231     create-device-change-window
 232     find-keyboard
 233     find-mouse
 234     set-up-controllers
 235     add-wm-devicechange ;
 236
 237 M: dinput-game-input-backend (close-game-input)
 238     remove-wm-devicechange
 239     release-controllers
 240     release-mouse
 241     release-keyboard
 242     close-device-change-window
 243     delete-dinput ;
 244
 245 M: dinput-game-input-backend (reset-game-input)
 246     [
 247         {
 248             +dinput+ +keyboard-device+ +keyboard-state+
 249             +controller-devices+ +controller-guids+
 250             +device-change-window+ +device-change-handle+
 251         } [ off ] each
 252     ] with-global ;
 253
 254 M: dinput-game-input-backend get-controllers
 255     +controller-devices+ get-global
 256     [ drop controller boa ] { } assoc>map ;
 257
 258 M: dinput-game-input-backend product-string
 259     handle>> device-info tszProductName>>
 260     alien>native-string ;
 261
 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 ;
 266
 267 :: with-acquisition ( device acquired-quot succeeded-quot failed-quot -- result/f )
 268     device { [ ] [ IDirectInputDevice8W::Acquire succeeded? ] } 1&& [
 269         device acquired-quot call
 270         succeeded-quot call
 271     ] failed-quot if ; inline
 272
 273 CONSTANT: pov-values
 274     {
 275         pov-up pov-up-right pov-right pov-down-right
 276         pov-down pov-down-left pov-left pov-up-left
 277     }
 278
 279 : >axis ( long -- float )
 280     32767 - 32767.0 /f ; inline
 281 : >slider ( long -- float )
 282     65535.0 /f ; inline
 283 : >pov ( long -- symbol )
 284     dup 0xFFFF bitand 0xFFFF =
 285     [ drop pov-neutral ]
 286     [ 2750 + 4500 /i pov-values nth ] if ; inline
 287
 288 : (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
 289     [ drop ] compose [ 2drop ] if ; inline
 290
 291 : fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
 292     {
 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 ]
 302     } 2cleave ;
 303
 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 ;
 307
 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 ]
 314     } case ;
 315
 316 : fill-mouse-state ( buffer count -- state )
 317     <iota> [ +mouse-state+ get-global ] 2dip swap [ nth (fill-mouse-state) ] curry each ;
 318
 319 : get-device-state ( device DIJOYSTATE2 -- )
 320     [ dup IDirectInputDevice8W::Poll check-ole32-error ] dip
 321     [ byte-length ] keep
 322     IDirectInputDevice8W::GetDeviceState check-ole32-error ;
 323
 324 : (read-controller) ( handle template -- state )
 325     swap [ DIJOYSTATE2 new [ get-device-state ] keep ]
 326     [ fill-controller-state ] [ drop f ] with-acquisition ;
 327
 328 M: dinput-game-input-backend read-controller
 329     handle>> dup +controller-devices+ get-global at
 330     [ (read-controller) ] [ drop f ] if* ;
 331
 332 M: dinput-game-input-backend calibrate-controller
 333     handle>> f 0 IDirectInputDevice8W::RunControlPanel check-ole32-error ;
 334
 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 ;
 339
 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 ;
 343
 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
 348         0 >>dx
 349         0 >>dy
 350         0 >>scroll-dx
 351         0 >>scroll-dy
 352         drop ;