basis/game/input/dinput/dinput.factor

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