DirectInput adding, removing, basic reading devices works

extra/game-input/backend/dinput/dinput.factor

@@ -2,13 +2,14 @@ USING: windows.dinput windows.dinput.constants game-input
 symbols alien.c-types windows.ole32 namespaces assocs kernel
 arrays hashtables windows.kernel32 windows.com windows.dinput
 shuffle windows.user32 windows.messages sequences combinators
-math.geometry.rect ui.windows accessors math windows
+math.geometry.rect ui.windows accessors math windows alien
-alien.strings io.encodings.utf16 ;
+alien.strings io.encodings.utf16 continuations byte-arrays ;
 IN: game-input.backend.dinput
 
 SINGLETON: dinput-game-input-backend
 
-SYMBOLS: +dinput+ +keyboard-device+ +controller-devices+
+SYMBOLS: +dinput+ +keyboard-device+
+    +controller-devices+ +controller-guids+
     +device-change-window+ +device-change-handle+ ;
 
 : create-dinput ( -- )
@@ -23,69 +24,104 @@ SYMBOLS: +dinput+ +keyboard-device+ +controller-devices+
     +dinput+ get swap f <void*>
     [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
 
-: set-coop-level ( device -- device )
+: set-coop-level ( device -- )
-    dup +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
+    +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
     IDirectInputDevice8W::SetCooperativeLevel ole32-error ;
 
-: configure-keyboard ( keyboard -- keyboard )
+: set-data-format ( device format-symbol -- )
-    dup c_dfDIKeyboard_HID IDirectInputDevice8W::SetDataFormat
+    get IDirectInputDevice8W::SetDataFormat ole32-error ;
-    ole32-error set-coop-level ;
+
-: configure-controller ( controller -- controller )
+: configure-keyboard ( keyboard -- )
-    dup c_dfDIJoystick2 IDirectInputDevice8W::SetDataFormat
+    [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
-    ole32-error set-coop-level ;
+: configure-controller ( controller -- )
+    [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ;
 
 : find-keyboard ( -- )
-    GUID_SysKeyboard get device-for-guid
+    GUID_SysKeyboard device-for-guid
-    configure-keyboard
+    [ configure-keyboard ]
-    +keyboard-device+ set-global ;
+    [ +keyboard-device+ set-global ] bi ;
 
 : device-info ( device -- DIDEVICEIMAGEINFOW )
     "DIDEVICEINSTANCEW" <c-object>
     "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
     [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ;
-
+: device-caps ( device -- DIDEVCAPS )
-: controller-device? ( device -- ? )
+    "DIDEVCAPS" <c-object>
-    device-info
+    "DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize
-    DIDEVICEINSTANCEW-dwDevType GET_DIDEVICE_TYPE
+    [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ;
-    DI8DEVTYPE_KEYBOARD DI8DEVTYPE_MOUSE 2array member? not ;
-
-: device-attached? ( guid -- ? )
-    +dinput+ get swap IDirectInput8W::GetDeviceStatus
-    [ ole32-error ] [ S_OK = ] bi ;
 
 : <guid> ( memory -- byte-array )
     "GUID" heap-size memory>byte-array ;
 
-: add-controller ( guid -- )
+: device-guid ( device -- guid )
-    [ device-for-guid configure-controller ] [ <guid> ] bi
+    device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
-    over controller-device?
-    [ +controller-devices+ get set-at ]
-    [ drop com-release ] if ;
 
-: remove-controller ( guid -- )
+: device-attached? ( device -- ? )
-    <guid> +controller-devices+ get [ com-release f ] change-at ;
+    +dinput+ get swap device-guid
+    IDirectInput8W::GetDeviceStatus S_OK = ;
+
+: find-device-axes-callback ( -- alien )
+    [ ! ( lpddoi pvRef -- BOOL )
+        +controller-devices+ get at
+        swap DIDEVICEOBJECTINSTANCEW-guidType <guid> {
+            { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
+            { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
+            { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
+            { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] }
+            { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] }
+            { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] }
+            { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] }
+            [ drop ]
+        } cond drop
+        DIENUM_CONTINUE
+    ] LPDIENUMDEVICEOBJECTSCALLBACKW ;
+
+: find-device-axes ( device controller-state -- controller-state )
+    swap [ +controller-devices+ get set-at ] 2keep
+    find-device-axes-callback over DIDFT_AXIS
+    IDirectInputDevice8W::EnumObjects ole32-error ;
+
+: controller-state-template ( device -- controller-state )
+    controller-state new
+    over device-caps
+    [ DIDEVCAPS-dwButtons f <array> >>buttons ]
+    [ DIDEVCAPS-dwPOVs zero? f pov-neutral ? >>pov ] bi
+    find-device-axes ;
+
+: device-known? ( guid -- ? )
+    +controller-guids+ get key? ; inline
+
+: (add-controller) ( guid -- )
+    device-for-guid {
+        [ configure-controller ]
+        [ controller-state-template ]
+        [ dup device-guid +controller-guids+ get set-at ]
+        [ +controller-devices+ get set-at ]
+    } cleave ;
+
+: add-controller ( guid -- )
+    dup <guid> device-known? [ drop ] [ (add-controller) ] if ;
+
+: remove-controller ( device -- )
+    [ +controller-devices+ get delete-at ]
+    [ device-guid +controller-guids+ get delete-at ]
+    [ com-release ] tri ;
 
 : find-controller-callback ( -- alien )
-    [ ! ( lpddi pvRef -- ? )
+    [ ! ( lpddi pvRef -- BOOL )
         drop DIDEVICEINSTANCEW-guidInstance add-controller
         DIENUM_CONTINUE
     ] LPDIENUMDEVICESCALLBACKW ;
 
 : find-controllers ( -- )
-    4 <hashtable> +controller-devices+ set-global
     +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
     f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ;
 
-: find-device ( DEV_BROADCAST_DEVICEW -- guid/f )
+: set-up-controllers ( -- )
-    +dinput+ get swap
+    4 <hashtable> +controller-devices+ set-global
-    [ DEV_BROADCAST_DEVICEW-dbcc_classguid ]
+    4 <hashtable> +controller-guids+ set-global
-    [ DEV_BROADCAST_DEVICEW-dbcc_name ] bi
+    find-controllers ;
-    f <void*>
-    [ IDirectInput8W::FindDevice ] keep *void*
-    swap succeeded? [ drop f ] unless ;
 
-: find-and-add-device ( DEV_BROADCAST_DEVICEW -- )
-    find-device [ add-controller ] when* ;
 : find-and-remove-detached-devices ( -- )
     +controller-devices+ get [
         drop dup device-attached? [ drop ] [ remove-controller ] if
@@ -95,15 +131,15 @@ SYMBOLS: +dinput+ +keyboard-device+ +controller-devices+
     DEV_BROADCAST_HDR-dbch_devicetype DBT_DEVTYP_DEVICEINTERFACE = ;
 
 : device-arrived ( dbt-broadcast-hdr -- )
-    dup device-interface? [ find-and-add-device ] [ drop ] if ;
+    device-interface? [ find-controllers ] when ;
 
 : device-removed ( dbt-broadcast-hdr -- )
     device-interface? [ find-and-remove-detached-devices ] when ;
 
 : handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
     [ 2drop ] 2dip swap {
-        { [ dup DBT_DEVICEARRIVAL = ]         [ drop device-arrived ] }
+        { [ dup DBT_DEVICEARRIVAL = ]         [ drop <alien> device-arrived ] }
-        { [ dup DBT_DEVICEREMOVECOMPLETE = ]  [ drop device-removed ] }
+        { [ dup DBT_DEVICEREMOVECOMPLETE = ]  [ drop <alien> device-removed ] }
         [ 2drop ]
     } cond ;
 
@@ -144,8 +180,9 @@ TUPLE: window-rect < rect window-loc ;
 
 : release-controllers ( -- )
     +controller-devices+ global [
-        [ nip com-release ] assoc-each f
+        [ drop com-release ] assoc-each f
-    ] change-at ;
+    ] change-at
+    f +controller-guids+ set-global ;
 
 : release-keyboard ( -- )
     +keyboard-device+ global
@@ -155,7 +192,7 @@ M: dinput-game-input-backend open-game-input
     create-dinput
     create-device-change-window
     find-keyboard
-    find-controllers
+    set-up-controllers
     add-wm-devicechange ;
 
 M: dinput-game-input-backend close-game-input
@@ -167,30 +204,41 @@ M: dinput-game-input-backend close-game-input
 
 M: dinput-game-input-backend get-controllers
     +controller-devices+ get
-    [ nip controller boa ] { } assoc>map ;
+    [ drop controller boa ] { } assoc>map ;
 
 M: dinput-game-input-backend product-string
     handle>> device-info DIDEVICEINSTANCEW-tszProductName
-    utf16le alien>string ;
+    utf16n alien>string ;
 
 M: dinput-game-input-backend product-id
     handle>> device-info DIDEVICEINSTANCEW-guidProduct <guid> ;
 M: dinput-game-input-backend instance-id
-    handle>> device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
+    handle>> device-guid ;
 
 : with-acquisition ( device quot -- )
     over IDirectInputDevice8W::Acquire ole32-error
     over [ IDirectInputDevice8W::Unacquire ole32-error ] curry
     [ ] cleanup ; inline
 
+: pov-values
+    {
+        pov-up pov-up-right pov-right pov-down-right
+        pov-down pov-down-left pov-left pov-up-left
+    } ; inline
+
+: >keys ( byte-array -- array )
+    [ HEX: 80 bitand c-bool> ] { } map-as ;
+
 : >axis ( long -- float )
-    ;
+    32767 - 32767.0 /f ;
 : >slider ( long -- float )
-    ;
+    65535.0 /f ;
-: >pov ( long -- float )
+: >pov ( long -- symbol )
-    ;
+    dup HEX: FFFF and HEX: FFFF =
+    [ drop pov-neutral ]
+    [ 4500 + 9000 /i pov-values nth ] if ;
 : >buttons ( alien -- array )
-    128 memory>byte-array [ HEX: 80 bitand c-bool> ] { } map-as ;
+    128 memory>byte-array >keys ;
 
 : <controller-state> ( DIJOYSTATE2 -- controller-state )
     ! XXX only transfer elements that are present on device
@@ -207,9 +255,10 @@ M: dinput-game-input-backend instance-id
     } cleave controller-state boa ;
 
 : <keyboard-state> ( byte-array -- keyboard-state )
-    [ c-bool> ] { } map-as keyboard-state boa ;
+    >keys keyboard-state boa ;
 
 : get-device-state ( device state-size -- byte-array )
+    [ dup IDirectInputDevice8W::Poll ole32-error ] dip
     dup <byte-array>
     [ IDirectInputDevice8W::GetDeviceState ole32-error ] keep ;
 
@@ -225,3 +274,5 @@ M: dinput-game-input-backend read-keyboard
     +keyboard-device+ get [ 
         256 get-device-state
     ] with-acquisition <keyboard-state> ;
+
+dinput-game-input-backend game-input-backend set-global

extra/game-input/backend/iokit/iokit.factor

@@ -99,32 +99,32 @@ SINGLETON: iokit-game-input-backend
     2array ;
 
 : button? ( {usage-page,usage} -- ? )
-    first 9 = ;
+    first 9 = ; inline
 : keyboard-key? ( {usage-page,usage} -- ? )
-    first 7 = ;
+    first 7 = ; inline
 : x-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 30 } = ;
+    { 1 HEX: 30 } = ; inline
 : y-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 31 } = ;
+    { 1 HEX: 31 } = ; inline
 : z-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 32 } = ;
+    { 1 HEX: 32 } = ; inline
 : rx-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 33 } = ;
+    { 1 HEX: 33 } = ; inline
 : ry-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 34 } = ;
+    { 1 HEX: 34 } = ; inline
 : rz-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 35 } = ;
+    { 1 HEX: 35 } = ; inline
 : slider? ( {usage-page,usage} -- ? )
-    { 1 HEX: 36 } = ;
+    { 1 HEX: 36 } = ; inline
 : hat-switch? ( {usage-page,usage} -- ? )
-    { 1 HEX: 39 } = ;
+    { 1 HEX: 39 } = ; inline
 
 : pov-values
     {
         pov-up pov-up-right pov-right pov-down-right
         pov-down pov-down-left pov-left pov-up-left
         pov-neutral
-    } ;
+    } ; inline
 
 : button-value ( value -- f/(0,1] )
     IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;

extra/windows/dinput/dinput.factor

@@ -36,7 +36,7 @@ TYPEDEF: void* LPDIENUMEFFECTSINFILECALLBACK
     dip alien-callback ; inline
 TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW
 : LPDIENUMDEVICEOBJECTSCALLBACKW
-    [ "BOOL" { "LPCDIDEVICEOBJECTINSTANCE" "LPVOID" } "stdcall" ]
+    [ "BOOL" { "LPCDIDEVICEOBJECTINSTANCEW" "LPVOID" } "stdcall" ]
     dip alien-callback ; inline
 
 TYPEDEF: DWORD D3DCOLOR
@@ -107,29 +107,35 @@ TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
 TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
 
 C-STRUCT: DIDEVCAPS
-    { "DWORD" "wSize" }
+    { "DWORD" "dwSize" }
-    { "DWORD" "wFlags" }
+    { "DWORD" "dwFlags" }
-    { "DWORD" "wDevType" }
+    { "DWORD" "dwDevType" }
-    { "DWORD" "wAxes" }
+    { "DWORD" "dwAxes" }
-    { "DWORD" "wButtons" }
+    { "DWORD" "dwButtons" }
-    { "DWORD" "wPOVs" }
+    { "DWORD" "dwPOVs" }
-    { "DWORD" "wFFSamplePeriod" }
+    { "DWORD" "dwFFSamplePeriod" }
-    { "DWORD" "wFFMinTimeResolution" }
+    { "DWORD" "dwFFMinTimeResolution" }
-    { "DWORD" "wFirmwareRevision" }
+    { "DWORD" "dwFirmwareRevision" }
-    { "DWORD" "wHardwareRevision" }
+    { "DWORD" "dwHardwareRevision" }
-    { "DWORD" "wFFDriverVersion" } ;
+    { "DWORD" "dwFFDriverVersion" } ;
 TYPEDEF: DIDEVCAPS* LPDIDEVCAPS
 TYPEDEF: DIDEVCAPS* LPCDIDEVCAPS
 C-STRUCT: DIDEVICEOBJECTINSTANCEW
-    { "DWORD"      "dwSize" }
+    { "DWORD" "dwSize" }
-    { "GUID"       "guidInstance" }
+    { "GUID" "guidType" }
-    { "GUID"       "guidProduct" }
+    { "DWORD" "dwOfs" }
-    { "DWORD"      "dwDevType" }
+    { "DWORD" "dwType" }
-    { "WCHAR[260]" "tszInstanceName" }
+    { "DWORD" "dwFlags" }
-    { "WCHAR[260]" "tszProductName" }
+    { "WCHAR[260]" "tszName" }
-    { "GUID"       "guidFFDriver" }
+    { "DWORD" "dwFFMaxForce" }
-    { "WORD"       "wUsagePage" }
+    { "DWORD" "dwFFForceResolution" }
-    { "WORD"       "wUsage" } ;
+    { "WORD" "wCollectionNumber" }
+    { "WORD" "wDesignatorIndex" }
+    { "WORD" "wUsagePage" }
+    { "WORD" "wUsage" }
+    { "DWORD" "dwDimension" }
+    { "WORD" "wExponent" }
+    { "WORD" "wReportId" } ;
 TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPDIDEVICEOBJECTINSTANCEW
 TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPCDIDEVICEOBJECTINSTANCEW
 C-STRUCT: DIDEVICEOBJECTDATA
@@ -661,3 +667,21 @@ FUNCTION: HRESULT DirectInput8Create ( HINSTANCE hinst, DWORD dwVersion, REFIID
 : DIPROP_USERNAME            25 <alien> ; inline
 : DIPROP_TYPENAME            26 <alien> ; inline
 
+: GUID_XAxis          GUID: {A36D02E0-C9F3-11CF-BFC7-444553540000} ; inline
+: GUID_YAxis          GUID: {A36D02E1-C9F3-11CF-BFC7-444553540000} ; inline
+: GUID_ZAxis          GUID: {A36D02E2-C9F3-11CF-BFC7-444553540000} ; inline
+: GUID_RxAxis         GUID: {A36D02F4-C9F3-11CF-BFC7-444553540000} ; inline
+: GUID_RyAxis         GUID: {A36D02F5-C9F3-11CF-BFC7-444553540000} ; inline
+: GUID_RzAxis         GUID: {A36D02E3-C9F3-11CF-BFC7-444553540000} ; inline
+: GUID_Slider         GUID: {A36D02E4-C9F3-11CF-BFC7-444553540000} ; inline
+: GUID_Button         GUID: {A36D02F0-C9F3-11CF-BFC7-444553540000} ; inline
+: GUID_Key            GUID: {55728220-D33C-11CF-BFC7-444553540000} ; inline
+: GUID_POV            GUID: {A36D02F2-C9F3-11CF-BFC7-444553540000} ; inline
+: GUID_Unknown        GUID: {A36D02F3-C9F3-11CF-BFC7-444553540000} ; inline
+: GUID_SysMouse       GUID: {6F1D2B60-D5A0-11CF-BFC7-444553540000} ; inline
+: GUID_SysKeyboard    GUID: {6F1D2B61-D5A0-11CF-BFC7-444553540000} ; inline
+: GUID_Joystick       GUID: {6F1D2B70-D5A0-11CF-BFC7-444553540000} ; inline
+: GUID_SysMouseEm     GUID: {6F1D2B80-D5A0-11CF-BFC7-444553540000} ; inline
+: GUID_SysMouseEm2    GUID: {6F1D2B81-D5A0-11CF-BFC7-444553540000} ; inline
+: GUID_SysKeyboardEm  GUID: {6F1D2B82-D5A0-11CF-BFC7-444553540000} ; inline
+: GUID_SysKeyboardEm2 GUID: {6F1D2B83-D5A0-11CF-BFC7-444553540000} ; inline

extra/windows/ole32/ole32.factor

@@ -1,5 +1,5 @@
 USING: alien alien.syntax alien.c-types alien.strings math
-kernel sequences windows windows.types
+kernel sequences windows windows.types debugger io accessors
 math.order ;
 IN: windows.ole32
 
@@ -115,10 +115,14 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
 : succeeded? ( hresult -- ? )
     0 HEX: 7FFFFFFF between? ;
 
+TUPLE: ole32-error error-code ;
+C: <ole32-error> ole32-error
+
+M: ole32-error error.
+    "COM method failed: " print error-code>> (win32-error-string) print ;
+
 : ole32-error ( hresult -- )
-    dup succeeded? [
+    dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
-        drop
-    ] [ (win32-error-string) throw ] if ;
 
 : ole-initialize ( -- )
     f OleInitialize ole32-error ;