From 67dd3ff6b6e38b2832d58e7070dab8b743cf40e5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 31 Aug 2009 11:31:01 -0500 Subject: [PATCH] clean up some game-input.dinput code to take advantage of structs and specialized arrays --- basis/game-input/dinput/dinput.factor | 88 +++++++++---------- .../dinput/keys-array/keys-array.factor | 6 +- 2 files changed, 46 insertions(+), 48 deletions(-) diff --git a/basis/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor index 26d57871d7..0fed15931d 100755 --- a/basis/game-input/dinput/dinput.factor +++ b/basis/game-input/dinput/dinput.factor @@ -39,12 +39,14 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ get IDirectInputDevice8W::SetDataFormat ole32-error ; : ( size -- DIPROPDWORD ) - "DIPROPDWORD" - "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 [ + 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 @@ -63,7 +65,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ GUID_SysKeyboard device-for-guid [ configure-keyboard ] [ +keyboard-device+ set-global ] bi - 256 keyboard-state boa + 256 256 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 mouse-state boa +mouse-state+ set-global - MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" + MOUSE-BUFFER-SIZE DIDEVICEOBJECTDATA +mouse-buffer+ set-global ; : device-info ( device -- DIDEVICEIMAGEINFOW ) - "DIDEVICEINSTANCEW" - "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize - [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ; + DIDEVICEINSTANCEW + DIDEVICEINSTANCEW heap-size >>dwSize + [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ; inline : device-caps ( device -- DIDEVCAPS ) - "DIDEVCAPS" - "DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize - [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ; - -: ( memory -- byte-array ) - "GUID" heap-size memory>byte-array ; + DIDEVCAPS + DIDEVCAPS heap-size >>dwSize + [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ; inline : device-guid ( device -- guid ) - device-info DIDEVICEINSTANCEW-guidInstance ; + 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 { + 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 >>buttons ] - [ DIDEVCAPS-dwPOVs zero? f pov-neutral ? >>pov ] bi + [ dwButtons>> f >>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 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 ; + handle>> device-info guidProduct>> ; 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 ; + [ 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 >>buttons ] } 2cleave ; : read-device-buffer ( device buffer count -- buffer count' ) - [ "DIDEVICEOBJECTDATA" heap-size ] 2dip + [ DIDEVICEOBJECTDATA heap-size ] 2dip [ 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 [ get-device-state ] keep ] + swap [ DIJOYSTATE2 [ get-device-state ] keep ] [ fill-controller-state ] [ drop f ] with-acquisition ; M: dinput-game-input-backend read-controller diff --git a/basis/game-input/dinput/keys-array/keys-array.factor b/basis/game-input/dinput/keys-array/keys-array.factor index 12ad072449..9a84747dd8 100755 --- a/basis/game-input/dinput/keys-array/keys-array.factor +++ b/basis/game-input/dinput/keys-array/keys-array.factor @@ -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 : >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 -- 2.34.1