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 windows.kernel32 windows.messages windows.ole32 windows.errors windows.user32 classes.struct alien.data ; SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA IN: game.input.dinput CONSTANT: MOUSE-BUFFER-SIZE 16 SINGLETON: dinput-game-input-backend dinput-game-input-backend game-input-backend set-global SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ +controller-devices+ +controller-guids+ +device-change-window+ +device-change-handle+ +mouse-device+ +mouse-state+ +mouse-buffer+ ; : create-dinput ( -- ) f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid f [ f DirectInput8Create ole32-error ] keep *void* +dinput+ set-global ; : delete-dinput ( -- ) +dinput+ [ com-release f ] change-global ; : device-for-guid ( guid -- device ) +dinput+ get swap f [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ; : set-coop-level ( device -- ) +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor IDirectInputDevice8W::SetCooperativeLevel ole32-error ; : set-data-format ( device format-symbol -- ) get IDirectInputDevice8W::SetDataFormat ole32-error ; : ( size -- DIPROPDWORD ) 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 IDirectInputDevice8W::SetProperty ole32-error ; : configure-keyboard ( keyboard -- ) [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ; : configure-mouse ( mouse -- ) [ c_dfDIMouse2 set-data-format ] [ MOUSE-BUFFER-SIZE set-buffer-size ] [ set-coop-level ] tri ; : configure-controller ( controller -- ) [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ; : find-keyboard ( -- ) GUID_SysKeyboard device-for-guid [ configure-keyboard ] [ +keyboard-device+ set-global ] bi 256 256 keyboard-state boa +keyboard-state+ set-global ; : find-mouse ( -- ) GUID_SysMouse device-for-guid [ configure-mouse ] [ +mouse-device+ set-global ] bi 0 0 0 0 8 f mouse-state boa +mouse-state+ set-global MOUSE-BUFFER-SIZE +mouse-buffer+ set-global ; : device-info ( device -- DIDEVICEIMAGEINFOW ) DIDEVICEINSTANCEW DIDEVICEINSTANCEW heap-size >>dwSize [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ; inline : device-caps ( device -- DIDEVCAPS ) DIDEVCAPS DIDEVCAPS heap-size >>dwSize [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ; inline : device-guid ( device -- guid ) device-info guidInstance>> ; inline : device-attached? ( device -- ? ) +dinput+ get swap device-guid IDirectInput8W::GetDeviceStatus S_OK = ; : 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 ( device controller-state -- controller-state ) swap [ +controller-devices+ get set-at ] 2keep find-device-axes-callback over DIDFT_AXIS IDirectInputDevice8W::EnumObjects ole32-error ; : controller-state-template ( device -- controller-state ) controller-state new over device-caps [ dwButtons>> f >>buttons ] [ dwPOVs>> zero? f pov-neutral ? >>pov ] bi find-device-axes ; : device-known? ( guid -- ? ) +controller-guids+ get 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 ] } 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 ] [ com-release ] tri ; : find-controller-callback ( -- alien ) [ ! ( lpddi pvRef -- BOOL ) drop DIDEVICEINSTANCEW memory>struct guidInstance>> add-controller DIENUM_CONTINUE ] LPDIENUMDEVICESCALLBACKW ; inline : find-controllers ( -- ) +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ; : set-up-controllers ( -- ) 4 +controller-devices+ set-global 4 +controller-guids+ set-global find-controllers ; : find-and-remove-detached-devices ( -- ) +controller-devices+ get keys [ device-attached? not ] filter [ remove-controller ] each ; : ?device-interface ( dbt-broadcast-hdr -- ? ) dup dbch_devicetype>> DBT_DEVTYP_DEVICEINTERFACE = [ >c-ptr DEV_BROADCAST_DEVICEW memory>struct ] [ drop f ] if ; inline : device-arrived ( dbt-broadcast-hdr -- ) ?device-interface [ find-controllers ] when ; inline : device-removed ( dbt-broadcast-hdr -- ) ?device-interface [ find-and-remove-detached-devices ] when ; inline : ( wParam -- struct ) DEV_BROADCAST_HDR memory>struct ; : handle-wm-devicechange ( hWnd uMsg wParam lParam -- ) [ 2drop ] 2dip swap { { [ dup DBT_DEVICEARRIVAL = ] [ drop device-arrived ] } { [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop device-removed ] } [ 2drop ] } cond ; TUPLE: window-rect < rect window-loc ; : ( -- window-rect ) window-rect new { 0 0 } >>window-loc { 0 0 } >>loc { 0 0 } >>dim ; : (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW ) DEV_BROADCAST_DEVICEW DEV_BROADCAST_DEVICEW heap-size >>dbcc_size DBT_DEVTYP_DEVICEINTERFACE >>dbcc_devicetype ; : create-device-change-window ( -- ) WS_OVERLAPPEDWINDOW 0 create-window [ (device-notification-filter) DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor RegisterDeviceNotification +device-change-handle+ set-global ] [ +device-change-window+ set-global ] bi ; : close-device-change-window ( -- ) +device-change-handle+ [ UnregisterDeviceNotification drop f ] change-global +device-change-window+ [ DestroyWindow win32-error=0/f f ] change-global ; : add-wm-devicechange ( -- ) [ 4dup handle-wm-devicechange DefWindowProc ] WM_DEVICECHANGE add-wm-handler ; : remove-wm-devicechange ( -- ) WM_DEVICECHANGE wm-handlers get-global delete-at ; : release-controllers ( -- ) +controller-devices+ [ [ drop com-release ] assoc-each f ] change-global f +controller-guids+ set-global ; : release-keyboard ( -- ) +keyboard-device+ [ com-release f ] change-global f +keyboard-state+ set-global ; : release-mouse ( -- ) +mouse-device+ [ com-release f ] change-global f +mouse-state+ set-global ; M: dinput-game-input-backend (open-game-input) create-dinput create-device-change-window find-keyboard find-mouse set-up-controllers add-wm-devicechange ; M: dinput-game-input-backend (close-game-input) remove-wm-devicechange release-controllers release-mouse release-keyboard close-device-change-window 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 ; M: dinput-game-input-backend get-controllers +controller-devices+ get [ drop controller boa ] { } assoc>map ; M: dinput-game-input-backend product-string handle>> device-info tszProductName>> utf16n alien>string ; M: dinput-game-input-backend product-id handle>> device-info guidProduct>> ; M: dinput-game-input-backend instance-id handle>> device-guid ; :: with-acquisition ( device acquired-quot succeeded-quot failed-quot -- result/f ) device { [ ] [ IDirectInputDevice8W::Acquire succeeded? ] } 1&& [ device acquired-quot call succeeded-quot call ] failed-quot if ; inline CONSTANT: pov-values { pov-up pov-up-right pov-right pov-down-right pov-down pov-down-left pov-left pov-up-left } : >axis ( long -- float ) 32767 - 32767.0 /f ; inline : >slider ( long -- float ) 65535.0 /f ; inline : >pov ( long -- symbol ) dup HEX: FFFF bitand HEX: FFFF = [ drop pov-neutral ] [ 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>> [ 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 [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ; : (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state ) [ dwData>> 32 >signed ] [ dwOfs>> ] bi { { DIMOFS_X [ [ + ] curry change-dx ] } { DIMOFS_Y [ [ + ] curry change-dy ] } { DIMOFS_Z [ [ + ] curry change-scroll-dy ] } [ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot [ buttons>> set-nth ] keep ] } case ; : fill-mouse-state ( buffer count -- state ) iota [ +mouse-state+ get ] 2dip swap [ nth (fill-mouse-state) ] curry each ; : get-device-state ( device DIJOYSTATE2 -- ) [ dup IDirectInputDevice8W::Poll ole32-error ] dip [ byte-length ] keep IDirectInputDevice8W::GetDeviceState ole32-error ; : (read-controller) ( handle template -- state ) swap [ DIJOYSTATE2 [ get-device-state ] keep ] [ fill-controller-state ] [ drop f ] with-acquisition ; M: dinput-game-input-backend read-controller handle>> dup +controller-devices+ get at [ (read-controller) ] [ drop f ] if* ; M: dinput-game-input-backend calibrate-controller handle>> f 0 IDirectInputDevice8W::RunControlPanel ole32-error ; M: dinput-game-input-backend read-keyboard +keyboard-device+ get [ +keyboard-state+ get [ 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 ] [ fill-mouse-state ] [ f ] with-acquisition ; M: dinput-game-input-backend reset-mouse +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ] [ 2drop ] [ ] with-acquisition +mouse-state+ get 0 >>dx 0 >>dy 0 >>scroll-dx 0 >>scroll-dy drop ;