clean up some game-input.dinput code to take advantage of structs and specialized arrays
Joe Groff
parent
43f81d3835
commit
67dd3ff6b6
|
|
@ -39,12 +39,14 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
get IDirectInputDevice8W::SetDataFormat ole32-error ;
|
||||
|
||||
: <buffer-size-diprop> ( size -- DIPROPDWORD )
|
||||
"DIPROPDWORD" <c-object>
|
||||
"DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize
|
||||
"DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize
|
||||
0 over set-DIPROPHEADER-dwObj
|
||||
DIPH_DEVICE over set-DIPROPHEADER-dwHow
|
||||
swap over set-DIPROPDWORD-dwData ;
|
||||
DIPROPDWORD <struct> [
|
||||
diph>>
|
||||
DIPROPDWORD heap-size >>dwSize
|
||||
DIPROPHEADER heap-size >>dwHeaderSize
|
||||
0 >>dwObj
|
||||
DIPH_DEVICE >>dwHow
|
||||
drop
|
||||
] keep swap >>dwData ;
|
||||
|
||||
: set-buffer-size ( device size -- )
|
||||
DIPROP_BUFFERSIZE swap <buffer-size-diprop>
|
||||
|
|
@ -63,7 +65,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
GUID_SysKeyboard device-for-guid
|
||||
[ configure-keyboard ]
|
||||
[ +keyboard-device+ set-global ] bi
|
||||
256 <byte-array> <keys-array> keyboard-state boa
|
||||
256 <byte-array> 256 <keys-array> keyboard-state boa
|
||||
+keyboard-state+ set-global ;
|
||||
|
||||
: find-mouse ( -- )
|
||||
|
|
@ -72,23 +74,20 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
[ +mouse-device+ set-global ] bi
|
||||
0 0 0 0 8 f <array> mouse-state boa
|
||||
+mouse-state+ set-global
|
||||
MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" <c-array>
|
||||
MOUSE-BUFFER-SIZE DIDEVICEOBJECTDATA <struct-array>
|
||||
+mouse-buffer+ set-global ;
|
||||
|
||||
: device-info ( device -- DIDEVICEIMAGEINFOW )
|
||||
"DIDEVICEINSTANCEW" <c-object>
|
||||
"DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
|
||||
[ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ;
|
||||
DIDEVICEINSTANCEW <struct>
|
||||
DIDEVICEINSTANCEW heap-size >>dwSize
|
||||
[ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ; inline
|
||||
: device-caps ( device -- DIDEVCAPS )
|
||||
"DIDEVCAPS" <c-object>
|
||||
"DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize
|
||||
[ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ;
|
||||
|
||||
: <guid> ( memory -- byte-array )
|
||||
"GUID" heap-size memory>byte-array ;
|
||||
DIDEVCAPS <struct>
|
||||
DIDEVCAPS heap-size >>dwSize
|
||||
[ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ; inline
|
||||
|
||||
: device-guid ( device -- guid )
|
||||
device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
|
||||
device-info guidInstance>> ; inline
|
||||
|
||||
: device-attached? ( device -- ? )
|
||||
+dinput+ get swap device-guid
|
||||
|
|
@ -97,7 +96,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
: find-device-axes-callback ( -- alien )
|
||||
[ ! ( lpddoi pvRef -- BOOL )
|
||||
+controller-devices+ get at
|
||||
swap DIDEVICEOBJECTINSTANCEW-guidType <guid> {
|
||||
swap guidType>> {
|
||||
{ [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
|
||||
{ [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
|
||||
{ [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
|
||||
|
|
@ -118,8 +117,8 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
: 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
|
||||
[ dwButtons>> f <array> >>buttons ]
|
||||
[ dwPOVs>> zero? f pov-neutral ? >>pov ] bi
|
||||
find-device-axes ;
|
||||
|
||||
: device-known? ( guid -- ? )
|
||||
|
|
@ -129,12 +128,12 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
device-for-guid {
|
||||
[ configure-controller ]
|
||||
[ controller-state-template ]
|
||||
[ dup device-guid +controller-guids+ get set-at ]
|
||||
[ dup device-guid clone +controller-guids+ get set-at ]
|
||||
[ +controller-devices+ get set-at ]
|
||||
} cleave ;
|
||||
|
||||
: add-controller ( guid -- )
|
||||
dup <guid> device-known? [ drop ] [ (add-controller) ] if ;
|
||||
dup device-known? [ drop ] [ (add-controller) ] if ;
|
||||
|
||||
: remove-controller ( device -- )
|
||||
[ +controller-devices+ get delete-at ]
|
||||
|
|
@ -143,9 +142,9 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
|
||||
: find-controller-callback ( -- alien )
|
||||
[ ! ( lpddi pvRef -- BOOL )
|
||||
drop DIDEVICEINSTANCEW-guidInstance add-controller
|
||||
drop guidInstance>> add-controller
|
||||
DIENUM_CONTINUE
|
||||
] LPDIENUMDEVICESCALLBACKW ;
|
||||
] LPDIENUMDEVICESCALLBACKW ; inline
|
||||
|
||||
: find-controllers ( -- )
|
||||
+dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
|
||||
|
|
@ -252,11 +251,11 @@ M: dinput-game-input-backend get-controllers
|
|||
[ drop controller boa ] { } assoc>map ;
|
||||
|
||||
M: dinput-game-input-backend product-string
|
||||
handle>> device-info DIDEVICEINSTANCEW-tszProductName
|
||||
handle>> device-info tszProductName>>
|
||||
utf16n alien>string ;
|
||||
|
||||
M: dinput-game-input-backend product-id
|
||||
handle>> device-info DIDEVICEINSTANCEW-guidProduct <guid> ;
|
||||
handle>> device-info guidProduct>> <guid> ;
|
||||
M: dinput-game-input-backend instance-id
|
||||
handle>> device-guid ;
|
||||
|
||||
|
|
@ -273,38 +272,36 @@ CONSTANT: pov-values
|
|||
}
|
||||
|
||||
: >axis ( long -- float )
|
||||
32767 - 32767.0 /f ;
|
||||
32767 - 32767.0 /f ; inline
|
||||
: >slider ( long -- float )
|
||||
65535.0 /f ;
|
||||
65535.0 /f ; inline
|
||||
: >pov ( long -- symbol )
|
||||
dup HEX: FFFF bitand HEX: FFFF =
|
||||
[ drop pov-neutral ]
|
||||
[ 2750 + 4500 /i pov-values nth ] if ;
|
||||
: >buttons ( alien length -- array )
|
||||
memory>byte-array <keys-array> ;
|
||||
[ 2750 + 4500 /i pov-values nth ] if ; inline
|
||||
|
||||
: (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
|
||||
[ drop ] compose [ 2drop ] if ; inline
|
||||
|
||||
: fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
|
||||
{
|
||||
[ over x>> [ DIJOYSTATE2-lX >axis >>x ] (fill-if) ]
|
||||
[ over y>> [ DIJOYSTATE2-lY >axis >>y ] (fill-if) ]
|
||||
[ over z>> [ DIJOYSTATE2-lZ >axis >>z ] (fill-if) ]
|
||||
[ over rx>> [ DIJOYSTATE2-lRx >axis >>rx ] (fill-if) ]
|
||||
[ over ry>> [ DIJOYSTATE2-lRy >axis >>ry ] (fill-if) ]
|
||||
[ over rz>> [ DIJOYSTATE2-lRz >axis >>rz ] (fill-if) ]
|
||||
[ over slider>> [ DIJOYSTATE2-rglSlider *long >slider >>slider ] (fill-if) ]
|
||||
[ over pov>> [ DIJOYSTATE2-rgdwPOV *uint >pov >>pov ] (fill-if) ]
|
||||
[ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
|
||||
[ over x>> [ lX>> >axis >>x ] (fill-if) ]
|
||||
[ over y>> [ lY>> >axis >>y ] (fill-if) ]
|
||||
[ over z>> [ lZ>> >axis >>z ] (fill-if) ]
|
||||
[ over rx>> [ lRx>> >axis >>rx ] (fill-if) ]
|
||||
[ over ry>> [ lRy>> >axis >>ry ] (fill-if) ]
|
||||
[ over rz>> [ lRz>> >axis >>rz ] (fill-if) ]
|
||||
[ over slider>> [ rglSlider>> first >slider >>slider ] (fill-if) ]
|
||||
[ over pov>> [ rgdwPOV>> first >pov >>pov ] (fill-if) ]
|
||||
[ rgbButtons>> over buttons>> length <keys-array> >>buttons ]
|
||||
} 2cleave ;
|
||||
|
||||
: read-device-buffer ( device buffer count -- buffer count' )
|
||||
[ "DIDEVICEOBJECTDATA" heap-size ] 2dip <uint>
|
||||
[ DIDEVICEOBJECTDATA heap-size ] 2dip <uint>
|
||||
[ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
|
||||
|
||||
: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
|
||||
[ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-dwOfs ] bi {
|
||||
[ dwData>> 32 >signed ] [ dwOfs>> ] bi {
|
||||
{ DIMOFS_X [ [ + ] curry change-dx ] }
|
||||
{ DIMOFS_Y [ [ + ] curry change-dy ] }
|
||||
{ DIMOFS_Z [ [ + ] curry change-scroll-dy ] }
|
||||
|
|
@ -312,8 +309,7 @@ CONSTANT: pov-values
|
|||
} case ;
|
||||
|
||||
: fill-mouse-state ( buffer count -- state )
|
||||
[ +mouse-state+ get ] 2dip swap
|
||||
[ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ;
|
||||
[ +mouse-state+ get ] 2dip swap [ nth (fill-mouse-state) ] curry each ;
|
||||
|
||||
: get-device-state ( device byte-array -- )
|
||||
[ dup IDirectInputDevice8W::Poll ole32-error ] dip
|
||||
|
|
@ -321,7 +317,7 @@ CONSTANT: pov-values
|
|||
IDirectInputDevice8W::GetDeviceState ole32-error ;
|
||||
|
||||
: (read-controller) ( handle template -- state )
|
||||
swap [ "DIJOYSTATE2" heap-size <byte-array> [ get-device-state ] keep ]
|
||||
swap [ DIJOYSTATE2 <struct> [ get-device-state ] keep ]
|
||||
[ fill-controller-state ] [ drop f ] with-acquisition ;
|
||||
|
||||
M: dinput-game-input-backend read-controller
|
||||
|
|
|
|||
|
|
@ -2,13 +2,15 @@ USING: sequences sequences.private math alien.c-types
|
|||
accessors ;
|
||||
IN: game-input.dinput.keys-array
|
||||
|
||||
TUPLE: keys-array underlying ;
|
||||
TUPLE: keys-array
|
||||
{ underlying sequence read-only }
|
||||
{ length integer read-only } ;
|
||||
C: <keys-array> keys-array
|
||||
|
||||
: >key ( byte -- ? )
|
||||
HEX: 80 bitand c-bool> ;
|
||||
|
||||
M: keys-array length underlying>> length ;
|
||||
M: keys-array length length>> ;
|
||||
M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
|
||||
|
||||
INSTANCE: keys-array sequence
|
||||
|
|
|
|||
Loading…
Reference in New Issue