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