steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

clean up some game-input.dinput code to take advantage of structs and specialized arrays

db4
Joe Groff 2009-08-31 11:31:01 -05:00
parent 43f81d3835
commit 67dd3ff6b6
2 changed files with 46 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
basis/game-input/dinput/dinput.factor
View File

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

6
basis/game-input/dinput/keys-array/keys-array.factor
View File

@ -2,13 +2,15 @@ USING: sequences sequences.private math alien.c-types
accessors ; accessors ;
IN: game-input.dinput.keys-array 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 C: <keys-array> keys-array
: >key ( byte -- ? ) : >key ( byte -- ? )
HEX: 80 bitand c-bool> ; 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 ; M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
INSTANCE: keys-array sequence INSTANCE: keys-array sequence