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 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 ;
  10 IN: game-input.dinput
  11 CONSTANT: MOUSE-BUFFER-SIZE 16
  12
  13 SINGLETON: dinput-game-input-backend
  14
  15 dinput-game-input-backend game-input-backend set-global
  16
  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+ ;
  21
  22 : create-dinput ( -- )
  23     f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
  24     f <void*> [ f DirectInput8Create ole32-error ] keep *void*
  25     +dinput+ set-global ;
  26
  27 : delete-dinput ( -- )
  28     +dinput+ [ com-release f ] change-global ;
  29
  30 : device-for-guid ( guid -- device )
  31     +dinput+ get swap f <void*>
  32     [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
  33
  34 : set-coop-level ( device -- )
  35     +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
  36     IDirectInputDevice8W::SetCooperativeLevel ole32-error ;
  37
  38 : set-data-format ( device format-symbol -- )
  39     get IDirectInputDevice8W::SetDataFormat ole32-error ;
  40
  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 ;
  48
  49 : set-buffer-size ( device size -- )
  50     DIPROP_BUFFERSIZE swap <buffer-size-diprop>
  51     IDirectInputDevice8W::SetProperty ole32-error ;
  52
  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 ;
  61
  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 ;
  68
  69 : find-mouse ( -- )
  70     GUID_SysMouse device-for-guid
  71     [ configure-mouse ]
  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 ;
  77
  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 ;
  86
  87 : <guid> ( memory -- byte-array )
  88     "GUID" heap-size memory>byte-array ;
  89
  90 : device-guid ( device -- guid )
  91     device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
  92
  93 : device-attached? ( device -- ? )
  94     +dinput+ get swap device-guid
  95     IDirectInput8W::GetDeviceStatus S_OK = ;
  96
  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 ] }
 108             [ drop ]
 109         } cond drop
 110         DIENUM_CONTINUE
 111     ] LPDIENUMDEVICEOBJECTSCALLBACKW ;
 112
 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 ;
 117
 118 : controller-state-template ( device -- controller-state )
 119     controller-state new
 120     over device-caps
 121     [ DIDEVCAPS-dwButtons f <array> >>buttons ]
 122     [ DIDEVCAPS-dwPOVs zero? f pov-neutral ? >>pov ] bi
 123     find-device-axes ;
 124
 125 : device-known? ( guid -- ? )
 126     +controller-guids+ get key? ; inline
 127
 128 : (add-controller) ( guid -- )
 129     device-for-guid {
 130         [ configure-controller ]
 131         [ controller-state-template ]
 132         [ dup device-guid +controller-guids+ get set-at ]
 133         [ +controller-devices+ get set-at ]
 134     } cleave ;
 135
 136 : add-controller ( guid -- )
 137     dup <guid> device-known? [ drop ] [ (add-controller) ] if ;
 138
 139 : remove-controller ( device -- )
 140     [ +controller-devices+ get delete-at ]
 141     [ device-guid +controller-guids+ get delete-at ]
 142     [ com-release ] tri ;
 143
 144 : find-controller-callback ( -- alien )
 145     [ ! ( lpddi pvRef -- BOOL )
 146         drop DIDEVICEINSTANCEW-guidInstance add-controller
 147         DIENUM_CONTINUE
 148     ] LPDIENUMDEVICESCALLBACKW ;
 149
 150 : find-controllers ( -- )
 151     +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
 152     f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ;
 153
 154 : set-up-controllers ( -- )
 155     4 <vector> +controller-devices+ set-global
 156     4 <vector> +controller-guids+ set-global
 157     find-controllers ;
 158
 159 : find-and-remove-detached-devices ( -- )
 160     +controller-devices+ get keys
 161     [ device-attached? not ] filter
 162     [ remove-controller ] each ;
 163
 164 : device-interface? ( dbt-broadcast-hdr -- ? )
 165     dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE = ;
 166
 167 : device-arrived ( dbt-broadcast-hdr -- )
 168     device-interface? [ find-controllers ] when ;
 169
 170 : device-removed ( dbt-broadcast-hdr -- )
 171     device-interface? [ find-and-remove-detached-devices ] when ;
 172
 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 ] }
 177         [ 2drop ]
 178     } cond ;
 179
 180 TUPLE: window-rect < rect window-loc ;
 181 : <zero-window-rect> ( -- window-rect )
 182     window-rect new
 183     { 0 0 } >>window-loc
 184     { 0 0 } >>loc
 185     { 0 0 } >>dim ;
 186
 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 ;
 191
 192 : create-device-change-window ( -- )
 193     <zero-window-rect> WS_OVERLAPPEDWINDOW 0 create-window
 194     [
 195         (device-notification-filter)
 196         DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor
 197         RegisterDeviceNotification
 198         +device-change-handle+ set-global
 199     ]
 200     [ +device-change-window+ set-global ] bi ;
 201
 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 ;
 205
 206 : add-wm-devicechange ( -- )
 207     [ 4dup handle-wm-devicechange DefWindowProc ]
 208     WM_DEVICECHANGE add-wm-handler ;
 209
 210 : remove-wm-devicechange ( -- )
 211     WM_DEVICECHANGE wm-handlers get-global delete-at ;
 212
 213 : release-controllers ( -- )
 214     +controller-devices+ [ [ drop com-release ] assoc-each f ] change-global
 215     f +controller-guids+ set-global ;
 216
 217 : release-keyboard ( -- )
 218     +keyboard-device+ [ com-release f ] change-global
 219     f +keyboard-state+ set-global ;
 220
 221 : release-mouse ( -- )
 222     +mouse-device+ [ com-release f ] change-global
 223     f +mouse-state+ set-global ;
 224
 225 M: dinput-game-input-backend (open-game-input)
 226     create-dinput
 227     create-device-change-window
 228     find-keyboard
 229     find-mouse
 230     set-up-controllers
 231     add-wm-devicechange ;
 232
 233 M: dinput-game-input-backend (close-game-input)
 234     remove-wm-devicechange
 235     release-controllers
 236     release-mouse
 237     release-keyboard
 238     close-device-change-window
 239     delete-dinput ;
 240
 241 M: dinput-game-input-backend (reset-game-input)
 242     global [
 243         {
 244             +dinput+ +keyboard-device+ +keyboard-state+
 245             +controller-devices+ +controller-guids+
 246             +device-change-window+ +device-change-handle+
 247         } [ off ] each
 248     ] bind ;
 249
 250 M: dinput-game-input-backend get-controllers
 251     +controller-devices+ get
 252     [ drop controller boa ] { } assoc>map ;
 253
 254 M: dinput-game-input-backend product-string
 255     handle>> device-info DIDEVICEINSTANCEW-tszProductName
 256     utf16n alien>string ;
 257
 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 ;
 262
 263 :: with-acquisition ( device acquired-quot succeeded-quot failed-quot -- result/f )
 264     device IDirectInputDevice8W::Acquire succeeded? [
 265         device acquired-quot call
 266         succeeded-quot call
 267     ] failed-quot if ; inline
 268
 269 CONSTANT: pov-values
 270     {
 271         pov-up pov-up-right pov-right pov-down-right
 272         pov-down pov-down-left pov-left pov-up-left
 273     }
 274
 275 : >axis ( long -- float )
 276     32767 - 32767.0 /f ;
 277 : >slider ( long -- float )
 278     65535.0 /f ;
 279 : >pov ( long -- symbol )
 280     dup HEX: FFFF bitand HEX: FFFF =
 281     [ drop pov-neutral ]
 282     [ 2750 + 4500 /i pov-values nth ] if ;
 283 : >buttons ( alien length -- array )
 284     memory>byte-array <keys-array> ;
 285
 286 : (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
 287     [ drop ] compose [ 2drop ] if ; inline
 288
 289 : fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
 290     {
 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 ]
 300     } 2cleave ;
 301
 302 : read-device-buffer ( device buffer count -- buffer count' )
 303     [ "DIDEVICEOBJECTDATA" heap-size ] 2dip <uint>
 304     [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
 305
 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 ]
 312     } case ;
 313
 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 ;
 317
 318 : get-device-state ( device byte-array -- )
 319     [ dup IDirectInputDevice8W::Poll ole32-error ] dip
 320     [ length ] keep
 321     IDirectInputDevice8W::GetDeviceState ole32-error ;
 322
 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 ;
 326
 327 M: dinput-game-input-backend read-controller
 328     handle>> dup +controller-devices+ get at
 329     [ (read-controller) ] [ drop f ] if* ;
 330
 331 M: dinput-game-input-backend calibrate-controller
 332     handle>> f 0 IDirectInputDevice8W::RunControlPanel ole32-error ;
 333
 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 ;
 338
 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 ;
 342
 343 M: dinput-game-input-backend reset-mouse
 344     +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ]
 345     [ 2drop ] [ ] with-acquisition
 346     +mouse-state+ get
 347         0 >>dx
 348         0 >>dy
 349         0 >>scroll-dx
 350         0 >>scroll-dy
 351         drop ;