basis/game-input/dinput/dinput.factor

   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 specialized-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 ;
  10 SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA
  11 IN: game-input.dinput
  12
  13 CONSTANT: MOUSE-BUFFER-SIZE 16
  14
  15 SINGLETON: dinput-game-input-backend
  16
  17 dinput-game-input-backend game-input-backend set-global
  18
  19 SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
  20     +controller-devices+ +controller-guids+
  21     +device-change-window+ +device-change-handle+
  22     +mouse-device+ +mouse-state+ +mouse-buffer+ ;
  23
  24 : create-dinput ( -- )
  25     f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
  26     f <void*> [ f DirectInput8Create ole32-error ] keep *void*
  27     +dinput+ set-global ;
  28
  29 : delete-dinput ( -- )
  30     +dinput+ [ com-release f ] change-global ;
  31
  32 : device-for-guid ( guid -- device )
  33     +dinput+ get swap f <void*>
  34     [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
  35
  36 : set-coop-level ( device -- )
  37     +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
  38     IDirectInputDevice8W::SetCooperativeLevel ole32-error ;
  39
  40 : set-data-format ( device format-symbol -- )
  41     get IDirectInputDevice8W::SetDataFormat ole32-error ;
  42
  43 : <buffer-size-diprop> ( size -- DIPROPDWORD )
  44     DIPROPDWORD <struct> [
  45         diph>>
  46         DIPROPDWORD heap-size  >>dwSize
  47         DIPROPHEADER heap-size >>dwHeaderSize
  48         0           >>dwObj
  49         DIPH_DEVICE >>dwHow
  50         drop
  51     ] keep swap >>dwData ;
  52
  53 : set-buffer-size ( device size -- )
  54     DIPROP_BUFFERSIZE swap <buffer-size-diprop>
  55     IDirectInputDevice8W::SetProperty ole32-error ;
  56
  57 : configure-keyboard ( keyboard -- )
  58     [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
  59 : configure-mouse ( mouse -- )
  60     [ c_dfDIMouse2 set-data-format ]
  61     [ MOUSE-BUFFER-SIZE set-buffer-size ]
  62     [ set-coop-level ] tri ;
  63 : configure-controller ( controller -- )
  64     [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ;
  65
  66 : find-keyboard ( -- )
  67     GUID_SysKeyboard device-for-guid
  68     [ configure-keyboard ]
  69     [ +keyboard-device+ set-global ] bi
  70     256 <byte-array> 256 <keys-array> keyboard-state boa
  71     +keyboard-state+ set-global ;
  72
  73 : find-mouse ( -- )
  74     GUID_SysMouse device-for-guid
  75     [ configure-mouse ] [ +mouse-device+ set-global ] bi
  76     0 0 0 0 8 f <array> mouse-state boa +mouse-state+ set-global
  77     MOUSE-BUFFER-SIZE <DIDEVICEOBJECTDATA-array> +mouse-buffer+ set-global ;
  78
  79 : device-info ( device -- DIDEVICEIMAGEINFOW )
  80     DIDEVICEINSTANCEW <struct>
  81         DIDEVICEINSTANCEW heap-size >>dwSize
  82     [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ; inline
  83 : device-caps ( device -- DIDEVCAPS )
  84     DIDEVCAPS <struct>
  85         DIDEVCAPS heap-size >>dwSize
  86     [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ; inline
  87
  88 : device-guid ( device -- guid )
  89     device-info guidInstance>> ; inline
  90
  91 : device-attached? ( device -- ? )
  92     +dinput+ get swap device-guid
  93     IDirectInput8W::GetDeviceStatus S_OK = ;
  94
  95 : find-device-axes-callback ( -- alien )
  96     [ ! ( lpddoi pvRef -- BOOL )
  97         [ DIDEVICEOBJECTINSTANCEW memory>struct ] dip
  98         +controller-devices+ get at
  99         swap guidType>> {
 100             { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
 101             { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
 102             { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
 103             { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] }
 104             { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] }
 105             { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] }
 106             { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] }
 107             [ drop ]
 108         } cond drop
 109         DIENUM_CONTINUE
 110     ] LPDIENUMDEVICEOBJECTSCALLBACKW ;
 111
 112 : find-device-axes ( device controller-state -- controller-state )
 113     swap [ +controller-devices+ get set-at ] 2keep
 114     find-device-axes-callback over DIDFT_AXIS
 115     IDirectInputDevice8W::EnumObjects ole32-error ;
 116
 117 : controller-state-template ( device -- controller-state )
 118     controller-state new
 119     over device-caps
 120     [ dwButtons>> f <array> >>buttons ]
 121     [ dwPOVs>> zero? f pov-neutral ? >>pov ] bi
 122     find-device-axes ;
 123
 124 : device-known? ( guid -- ? )
 125     +controller-guids+ get key? ; inline
 126
 127 : (add-controller) ( guid -- )
 128     device-for-guid {
 129         [ configure-controller ]
 130         [ controller-state-template ]
 131         [ dup device-guid clone +controller-guids+ get set-at ]
 132         [ +controller-devices+ get set-at ]
 133     } cleave ;
 134
 135 : add-controller ( guid -- )
 136     dup device-known? [ drop ] [ (add-controller) ] if ;
 137
 138 : remove-controller ( device -- )
 139     [ +controller-devices+ get delete-at ]
 140     [ device-guid +controller-guids+ get delete-at ]
 141     [ com-release ] tri ;
 142
 143 : find-controller-callback ( -- alien )
 144     [ ! ( lpddi pvRef -- BOOL )
 145         drop DIDEVICEINSTANCEW memory>struct guidInstance>> add-controller
 146         DIENUM_CONTINUE
 147     ] LPDIENUMDEVICESCALLBACKW ; inline
 148
 149 : find-controllers ( -- )
 150     +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
 151     f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices 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 keys
 160     [ device-attached? not ] filter
 161     [ remove-controller ] each ;
 162
 163 : device-interface? ( dbt-broadcast-hdr -- ? )
 164     dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE = ;
 165
 166 : device-arrived ( dbt-broadcast-hdr -- )
 167     device-interface? [ find-controllers ] when ;
 168
 169 : device-removed ( dbt-broadcast-hdr -- )
 170     device-interface? [ find-and-remove-detached-devices ] when ;
 171
 172 : handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
 173     [ 2drop ] 2dip swap {
 174         { [ dup DBT_DEVICEARRIVAL = ]         [ drop <alien> device-arrived ] }
 175         { [ dup DBT_DEVICEREMOVECOMPLETE = ]  [ drop <alien> device-removed ] }
 176         [ 2drop ]
 177     } cond ;
 178
 179 TUPLE: window-rect < rect window-loc ;
 180 : <zero-window-rect> ( -- window-rect )
 181     window-rect new
 182     { 0 0 } >>window-loc
 183     { 0 0 } >>loc
 184     { 0 0 } >>dim ;
 185
 186 : (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
 187     DEV_BROADCAST_DEVICEW <struct>
 188         DEV_BROADCAST_DEVICEW heap-size >>dbcc_size
 189         DBT_DEVTYP_DEVICEINTERFACE >>dbcc_devicetype ;
 190
 191 : create-device-change-window ( -- )
 192     <zero-window-rect> WS_OVERLAPPEDWINDOW 0 create-window
 193     [
 194         (device-notification-filter)
 195         DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor
 196         RegisterDeviceNotification
 197         +device-change-handle+ set-global
 198     ]
 199     [ +device-change-window+ set-global ] bi ;
 200
 201 : close-device-change-window ( -- )
 202     +device-change-handle+ [ UnregisterDeviceNotification drop f ] change-global
 203     +device-change-window+ [ DestroyWindow win32-error=0/f f ] change-global ;
 204
 205 : add-wm-devicechange ( -- )
 206     [ 4dup handle-wm-devicechange DefWindowProc ]
 207     WM_DEVICECHANGE add-wm-handler ;
 208
 209 : remove-wm-devicechange ( -- )
 210     WM_DEVICECHANGE wm-handlers get-global delete-at ;
 211
 212 : release-controllers ( -- )
 213     +controller-devices+ [ [ drop com-release ] assoc-each f ] change-global
 214     f +controller-guids+ set-global ;
 215
 216 : release-keyboard ( -- )
 217     +keyboard-device+ [ com-release f ] change-global
 218     f +keyboard-state+ set-global ;
 219
 220 : release-mouse ( -- )
 221     +mouse-device+ [ com-release f ] change-global
 222     f +mouse-state+ set-global ;
 223
 224 M: dinput-game-input-backend (open-game-input)
 225     create-dinput
 226     create-device-change-window
 227     find-keyboard
 228     find-mouse
 229     set-up-controllers
 230     add-wm-devicechange ;
 231
 232 M: dinput-game-input-backend (close-game-input)
 233     remove-wm-devicechange
 234     release-controllers
 235     release-mouse
 236     release-keyboard
 237     close-device-change-window
 238     delete-dinput ;
 239
 240 M: dinput-game-input-backend (reset-game-input)
 241     global [
 242         {
 243             +dinput+ +keyboard-device+ +keyboard-state+
 244             +controller-devices+ +controller-guids+
 245             +device-change-window+ +device-change-handle+
 246         } [ off ] each
 247     ] bind ;
 248
 249 M: dinput-game-input-backend get-controllers
 250     +controller-devices+ get
 251     [ drop controller boa ] { } assoc>map ;
 252
 253 M: dinput-game-input-backend product-string
 254     handle>> device-info tszProductName>>
 255     utf16n alien>string ;
 256
 257 M: dinput-game-input-backend product-id
 258     handle>> device-info guidProduct>> ;
 259 M: dinput-game-input-backend instance-id
 260     handle>> device-guid ;
 261
 262 :: with-acquisition ( device acquired-quot succeeded-quot failed-quot -- result/f )
 263     device IDirectInputDevice8W::Acquire succeeded? [
 264         device acquired-quot call
 265         succeeded-quot call
 266     ] failed-quot if ; inline
 267
 268 CONSTANT: pov-values
 269     {
 270         pov-up pov-up-right pov-right pov-down-right
 271         pov-down pov-down-left pov-left pov-up-left
 272     }
 273
 274 : >axis ( long -- float )
 275     32767 - 32767.0 /f ; inline
 276 : >slider ( long -- float )
 277     65535.0 /f ; inline
 278 : >pov ( long -- symbol )
 279     dup HEX: FFFF bitand HEX: FFFF =
 280     [ drop pov-neutral ]
 281     [ 2750 + 4500 /i pov-values nth ] if ; inline
 282
 283 : (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
 284     [ drop ] compose [ 2drop ] if ; inline
 285
 286 : fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
 287     {
 288         [ over x>> [ lX>> >axis >>x ] (fill-if) ]
 289         [ over y>> [ lY>> >axis >>y ] (fill-if) ]
 290         [ over z>> [ lZ>> >axis >>z ] (fill-if) ]
 291         [ over rx>> [ lRx>> >axis >>rx ] (fill-if) ]
 292         [ over ry>> [ lRy>> >axis >>ry ] (fill-if) ]
 293         [ over rz>> [ lRz>> >axis >>rz ] (fill-if) ]
 294         [ over slider>> [ rglSlider>> first >slider >>slider ] (fill-if) ]
 295         [ over pov>> [ rgdwPOV>> first >pov >>pov ] (fill-if) ]
 296         [ rgbButtons>> over buttons>> length <keys-array> >>buttons ]
 297     } 2cleave ;
 298
 299 : read-device-buffer ( device buffer count -- buffer count' )
 300     [ DIDEVICEOBJECTDATA heap-size ] 2dip <uint>
 301     [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
 302
 303 : (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
 304     [ dwData>> 32 >signed ] [ dwOfs>> ] bi {
 305         { DIMOFS_X [ [ + ] curry change-dx ] }
 306         { DIMOFS_Y [ [ + ] curry change-dy ] }
 307         { DIMOFS_Z [ [ + ] curry change-scroll-dy ] }
 308         [ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot [ buttons>> set-nth ] keep ]
 309     } case ;
 310
 311 : fill-mouse-state ( buffer count -- state )
 312     [ +mouse-state+ get ] 2dip swap [ nth (fill-mouse-state) ] curry each ;
 313
 314 : get-device-state ( device DIJOYSTATE2 -- )
 315     [ dup IDirectInputDevice8W::Poll ole32-error ] dip
 316     [ byte-length ] keep
 317     IDirectInputDevice8W::GetDeviceState ole32-error ;
 318
 319 : (read-controller) ( handle template -- state )
 320     swap [ DIJOYSTATE2 <struct> [ get-device-state ] keep ]
 321     [ fill-controller-state ] [ drop f ] with-acquisition ;
 322
 323 M: dinput-game-input-backend read-controller
 324     handle>> dup +controller-devices+ get at
 325     [ (read-controller) ] [ drop f ] if* ;
 326
 327 M: dinput-game-input-backend calibrate-controller
 328     handle>> f 0 IDirectInputDevice8W::RunControlPanel ole32-error ;
 329
 330 M: dinput-game-input-backend read-keyboard
 331     +keyboard-device+ get
 332     [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
 333     [ ] [ f ] with-acquisition ;
 334
 335 M: dinput-game-input-backend read-mouse
 336     +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ]
 337     [ fill-mouse-state ] [ f ] with-acquisition ;
 338
 339 M: dinput-game-input-backend reset-mouse
 340     +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ]
 341     [ 2drop ] [ ] with-acquisition
 342     +mouse-state+ get
 343         0 >>dx
 344         0 >>dy
 345         0 >>scroll-dx
 346         0 >>scroll-dy
 347         drop ;