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

diff --git a/basis/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor
index 26d57871d72daa0e684f5ccbc32b6779ff3785fe..0fed15931df13a7be31868b240c0ceb24d18a133 100755 (executable)
--- 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 ;
 
 : <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

diff --git a/basis/game-input/dinput/keys-array/keys-array.factor b/basis/game-input/dinput/keys-array/keys-array.factor
index 12ad07244985d3cf84ae008232fd556c6d93bab6..9a84747dd8fee521bd2b099f7e9b893a2d8d44a7 100755 (executable)
--- 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> 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