-USING: accessors alien alien.c-types alien.strings arrays
-assocs byte-arrays combinators combinators.short-circuit
-continuations game.input game.input.dinput.keys-array
-io.encodings.utf16 io.encodings.utf16n kernel locals math
-math.bitwise math.rectangles namespaces parser sequences
-shuffle specialized-arrays ui.backend.windows vectors
-windows.com windows.directx.dinput
-windows.directx.dinput.constants .errors windows.kernel32
-windows.messages .ole32 windows.user32 classes.struct
-alien.data ;
+USING: accessors alien alien.c-types alien.data alien.strings
+arrays assocs byte-arrays classes.struct combinators
+combinators.short-circuit game.input
+game.input.dinput.keys-array kernel math math.bitwise
+math.rectangles namespaces sequences specialized-arrays
+ui.backend.windows vectors windows.com windows.directx.dinput
+windows.directx.dinput.constants windows.errors windows.kernel32
+windows.messages windows.ole32 windows.user32 ;
SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA
IN: game.input.dinput
: create-dinput ( -- )
f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
- f <void*> [ f DirectInput8Create ole32-error ] keep *void*
+ f void* <ref> [ f DirectInput8Create check-ole32-error ] keep void* deref
+dinput+ set-global ;
: delete-dinput ( -- )
+dinput+ [ com-release f ] change-global ;
: device-for-guid ( guid -- device )
- +dinput+ get swap f <void*>
- [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
+ +dinput+ get-global swap f void* <ref>
+ [ f IDirectInput8W::CreateDevice check-ole32-error ] keep void* deref ;
: set-coop-level ( device -- )
- +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
- IDirectInputDevice8W::SetCooperativeLevel ole32-error ;
+ +device-change-window+ get-global DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
+ IDirectInputDevice8W::SetCooperativeLevel check-ole32-error ; inline
: set-data-format ( device format-symbol -- )
- get IDirectInputDevice8W::SetDataFormat ole32-error ;
+ get-global IDirectInputDevice8W::SetDataFormat check-ole32-error ; inline
: <buffer-size-diprop> ( size -- DIPROPDWORD )
- DIPROPDWORD <struct> [
+ DIPROPDWORD new [
diph>>
DIPROPDWORD heap-size >>dwSize
DIPROPHEADER heap-size >>dwHeaderSize
: set-buffer-size ( device size -- )
DIPROP_BUFFERSIZE swap <buffer-size-diprop>
- IDirectInputDevice8W::SetProperty ole32-error ;
+ IDirectInputDevice8W::SetProperty check-ole32-error ;
: configure-keyboard ( keyboard -- )
[ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
GUID_SysMouse device-for-guid
[ configure-mouse ] [ +mouse-device+ set-global ] bi
0 0 0 0 8 f <array> mouse-state boa +mouse-state+ set-global
- MOUSE-BUFFER-SIZE <DIDEVICEOBJECTDATA-array> +mouse-buffer+ set-global ;
+ MOUSE-BUFFER-SIZE DIDEVICEOBJECTDATA <c-array> +mouse-buffer+ set-global ;
: device-info ( device -- DIDEVICEIMAGEINFOW )
- DIDEVICEINSTANCEW <struct>
+ DIDEVICEINSTANCEW new
DIDEVICEINSTANCEW heap-size >>dwSize
- [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ; inline
+ [ IDirectInputDevice8W::GetDeviceInfo check-ole32-error ] keep ; inline
: device-caps ( device -- DIDEVCAPS )
- DIDEVCAPS <struct>
+ DIDEVCAPS new
DIDEVCAPS heap-size >>dwSize
- [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ; inline
+ [ IDirectInputDevice8W::GetCapabilities check-ole32-error ] keep ; inline
: device-guid ( device -- guid )
device-info guidInstance>> ; inline
+dinput+ get swap device-guid
IDirectInput8W::GetDeviceStatus S_OK = ;
+: (find-device-axes-callback) ( lpddoi pvRef -- BOOL )
+ +controller-devices+ get-global at
+ swap guidType>> {
+ { [ 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 ;
+
: find-device-axes-callback ( -- alien )
- [ ! ( lpddoi pvRef -- BOOL )
- [ DIDEVICEOBJECTINSTANCEW memory>struct ] dip
- +controller-devices+ get at
- swap guidType>> {
- { [ 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-callback) ] LPDIENUMDEVICEOBJECTSCALLBACKW ;
: find-device-axes ( device controller-state -- controller-state )
- swap [ +controller-devices+ get set-at ] 2keep
+ swap [ +controller-devices+ get-global set-at ] 2keep
find-device-axes-callback over DIDFT_AXIS
- IDirectInputDevice8W::EnumObjects ole32-error ;
+ IDirectInputDevice8W::EnumObjects check-ole32-error ;
: controller-state-template ( device -- controller-state )
controller-state new
find-device-axes ;
: device-known? ( guid -- ? )
- +controller-guids+ get key? ; inline
+ +controller-guids+ get-global key? ; inline
: (add-controller) ( guid -- )
device-for-guid {
[ configure-controller ]
[ controller-state-template ]
- [ dup device-guid clone +controller-guids+ get set-at ]
- [ +controller-devices+ get set-at ]
+ [ dup device-guid clone +controller-guids+ get-global set-at ]
+ [ +controller-devices+ get-global set-at ]
} cleave ;
: add-controller ( guid -- )
dup device-known? [ drop ] [ (add-controller) ] if ;
: remove-controller ( device -- )
- [ +controller-devices+ get delete-at ]
- [ device-guid +controller-guids+ get delete-at ]
+ [ +controller-devices+ get-global delete-at ]
+ [ device-guid +controller-guids+ get-global delete-at ]
[ com-release ] tri ;
+: (find-controller-callback) ( lpddi pvRef -- BOOL )
+ drop guidInstance>> add-controller
+ DIENUM_CONTINUE ;
+
: find-controller-callback ( -- alien )
- [ ! ( lpddi pvRef -- BOOL )
- drop DIDEVICEINSTANCEW memory>struct guidInstance>> add-controller
- DIENUM_CONTINUE
- ] LPDIENUMDEVICESCALLBACKW ; inline
+ [ (find-controller-callback) ] LPDIENUMDEVICESCALLBACKW ;
: find-controllers ( -- )
- +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
- f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ;
+ +dinput+ get-global DI8DEVCLASS_GAMECTRL find-controller-callback
+ f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices check-ole32-error ;
: set-up-controllers ( -- )
4 <vector> +controller-devices+ set-global
find-controllers ;
: find-and-remove-detached-devices ( -- )
- +controller-devices+ get keys
- [ device-attached? not ] filter
+ +controller-devices+ get-global keys
+ [ device-attached? ] reject
[ remove-controller ] each ;
: ?device-interface ( dbt-broadcast-hdr -- ? )
<alien> DEV_BROADCAST_HDR memory>struct ;
: handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
- [ 2drop ] 2dip swap {
+ 2nipd swap {
{ [ dup DBT_DEVICEARRIVAL = ] [ drop <DEV_BROADCAST_HDR> device-arrived ] }
{ [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <DEV_BROADCAST_HDR> device-removed ] }
[ 2drop ]
{ 0 0 } >>dim ;
: (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
- DEV_BROADCAST_DEVICEW <struct>
+ DEV_BROADCAST_DEVICEW new
DEV_BROADCAST_DEVICEW heap-size >>dbcc_size
DBT_DEVTYP_DEVICEINTERFACE >>dbcc_devicetype ;
delete-dinput ;
M: dinput-game-input-backend (reset-game-input)
- global [
+ [
{
+dinput+ +keyboard-device+ +keyboard-state+
+controller-devices+ +controller-guids+
+device-change-window+ +device-change-handle+
} [ off ] each
- ] bind ;
+ ] with-global ;
M: dinput-game-input-backend get-controllers
- +controller-devices+ get
+ +controller-devices+ get-global
[ drop controller boa ] { } assoc>map ;
M: dinput-game-input-backend product-string
handle>> device-info tszProductName>>
- utf16n alien>string ;
+ alien>native-string ;
M: dinput-game-input-backend product-id
handle>> device-info guidProduct>> ;
: >slider ( long -- float )
65535.0 /f ; inline
: >pov ( long -- symbol )
- dup HEX: FFFF bitand HEX: FFFF =
+ dup 0xFFFF bitand 0xFFFF =
[ drop pov-neutral ]
[ 2750 + 4500 /i pov-values nth ] if ; inline
} 2cleave ;
: read-device-buffer ( device buffer count -- buffer count' )
- [ DIDEVICEOBJECTDATA heap-size ] 2dip <uint>
- [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
+ [ DIDEVICEOBJECTDATA heap-size ] 2dip uint <ref>
+ [ 0 IDirectInputDevice8W::GetDeviceData check-ole32-error ] 2keep uint deref ;
: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
[ dwData>> 32 >signed ] [ dwOfs>> ] bi {
} case ;
: fill-mouse-state ( buffer count -- state )
- [ +mouse-state+ get ] 2dip swap [ nth (fill-mouse-state) ] curry each ;
+ <iota> [ +mouse-state+ get-global ] 2dip swap [ nth (fill-mouse-state) ] curry each ;
: get-device-state ( device DIJOYSTATE2 -- )
- [ dup IDirectInputDevice8W::Poll ole32-error ] dip
+ [ dup IDirectInputDevice8W::Poll check-ole32-error ] dip
[ byte-length ] keep
- IDirectInputDevice8W::GetDeviceState ole32-error ;
+ IDirectInputDevice8W::GetDeviceState check-ole32-error ;
: (read-controller) ( handle template -- state )
- swap [ DIJOYSTATE2 <struct> [ get-device-state ] keep ]
+ swap [ DIJOYSTATE2 new [ get-device-state ] keep ]
[ fill-controller-state ] [ drop f ] with-acquisition ;
M: dinput-game-input-backend read-controller
- handle>> dup +controller-devices+ get at
+ handle>> dup +controller-devices+ get-global at
[ (read-controller) ] [ drop f ] if* ;
M: dinput-game-input-backend calibrate-controller
- handle>> f 0 IDirectInputDevice8W::RunControlPanel ole32-error ;
+ handle>> f 0 IDirectInputDevice8W::RunControlPanel check-ole32-error ;
M: dinput-game-input-backend read-keyboard
- +keyboard-device+ get
- [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
+ +keyboard-device+ get-global
+ [ +keyboard-state+ get-global [ keys>> underlying>> get-device-state ] keep ]
[ ] [ f ] with-acquisition ;
M: dinput-game-input-backend read-mouse
- +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ]
+ +mouse-device+ get-global [ +mouse-buffer+ get-global MOUSE-BUFFER-SIZE read-device-buffer ]
[ fill-mouse-state ] [ f ] with-acquisition ;
M: dinput-game-input-backend reset-mouse
- +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ]
+ +mouse-device+ get-global [ f MOUSE-BUFFER-SIZE read-device-buffer ]
[ 2drop ] [ ] with-acquisition
- +mouse-state+ get
+ +mouse-state+ get-global
0 >>dx
0 >>dy
0 >>scroll-dx
projects / factor.git / blobdiff