IN: combinators.lib
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Currying cleave combinators
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bi+ ( obj quot quot -- quot' quot' )
+ [ [ curry ] curry ] bi@ bi ;
+: tri+ ( obj quot quot quot -- quot' quot' quot' )
+ [ [ curry ] curry ] tri@ tri ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Generalized versions of core combinators
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- /dev/null
+USING: windows.dinput windows.dinput.constants game-input
+symbols alien.c-types windows.ole32 namespaces assocs kernel
+arrays hashtables windows.kernel32 windows.com windows.dinput
+shuffle windows.user32 windows.messages sequences combinators
+math.geometry.rect ui.windows accessors math windows ;
+IN: game-input.backend.dinput
+
+SINGLETON: dinput-game-input-backend
+
+SYMBOLS: +dinput+ +keyboard-device+ +controller-devices+
+ +device-change-window+ +device-change-handle+ ;
+
+: create-dinput ( -- )
+ f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
+ f <void*> [ f DirectInput8Create ole32-error ] keep *void*
+ +dinput+ set-global ;
+
+: delete-dinput ( -- )
+ +dinput+ global [ com-release f ] change-at ;
+
+: device-for-guid ( guid -- device )
+ +dinput+ get swap f <void*>
+ [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
+
+: configure-keyboard ( keyboard -- keyboard )
+ ;
+: configure-controller ( controller -- controller )
+ ;
+
+: find-keyboard ( -- )
+ GUID_SysKeyboard get device-for-guid
+ configure-keyboard
+ +keyboard-device+ set-global ;
+
+: controller-device? ( device -- ? )
+ "DIDEVICEINSTANCEW" <c-object>
+ "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
+ [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep
+ DIDEVICEINSTANCEW-dwDevType GET_DIDEVICE_TYPE
+ DI8DEVTYPE_KEYBOARD DI8DEVTYPE_MOUSE 2array member? not ;
+
+: device-attached? ( guid -- ? )
+ +dinput+ get swap IDirectInput8W::GetDeviceStatus
+ [ ole32-error ] [ S_OK = ] bi ;
+
+: add-controller ( guid -- )
+ [ device-for-guid configure-controller ]
+ [ "GUID" heap-size memory>byte-array ] bi
+ [ +controller-devices+ get set-at ]
+ [ drop com-release ] if ;
+
+: remove-controller ( guid -- )
+ "GUID" heap-size memory>byte-array
+ +controller-devices+ get [ com-release f ] change-at ;
+
+: find-controller-callback ( -- alien )
+ [ ! ( lpddi pvRef -- ? )
+ drop DIDEVICEINSTANCEW-guidInstance add-controller
+ DIENUM_CONTINUE
+ ] LPDIENUMDEVICESCALLBACKW ;
+
+: find-controllers ( -- )
+ 4 <hashtable> +controller-devices+ set-global
+ +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
+ f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ;
+
+: find-device ( DEV_BROADCAST_DEVICEW -- guid/f )
+ +dinput+ get swap
+ [ DEV_BROADCAST_DEVICEW-dbcc_classguid ]
+ [ DEV_BROADCAST_DEVICEW-dbcc_name ] bi
+ f <void*>
+ [ IDirectInput8W::FindDevice ] keep *void*
+ swap succeeded? [ drop f ] unless ;
+
+: find-and-add-device ( DEV_BROADCAST_DEVICEW -- )
+ find-device [ add-controller ] when* ;
+: find-and-remove-detached-devices ( -- )
+ +controller-devices+ get [
+ drop dup device-attached? [ drop ] [ remove-controller ] if
+ ] assoc-each ;
+
+: device-interface? ( dbt-broadcast-hdr -- ? )
+ DEV_BROADCAST_HDR-dbch_devicetype DBT_DEVTYP_DEVICEINTERFACE = ;
+
+: device-arrived ( dbt-broadcast-hdr -- )
+ dup device-interface? [ find-and-add-device ] [ drop ] if ;
+
+: device-removed ( dbt-broadcast-hdr -- )
+ device-interface? [ find-and-remove-detached-devices ] when ;
+
+: 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 ;
+: <zero-window-rect> ( -- window-rect )
+ window-rect new
+ { 0 0 } >>window-loc
+ { 0 0 } >>loc
+ { 0 0 } >>dim ;
+
+: (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
+ "DEV_BROADCAST_DEVICEW" <c-object>
+ "DEV_BROADCAST_DEVICEW" heap-size over set-DEV_BROADCAST_DEVICEW-dbcc_size
+ DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
+
+: create-device-change-window ( -- )
+ <zero-window-rect> 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+ global
+ [ UnregisterDeviceNotification drop f ] change-at
+ +device-change-window+ global
+ [ DestroyWindow win32-error=0/f f ] change-at ;
+
+: add-wm-devicechange ( -- )
+ create-device-change-window
+ [ 4dup handle-wm-devicechange DefWindowProc ] WM_DEVICECHANGE add-wm-handler ;
+
+: remove-wm-devicechange ( -- )
+ WM_DEVICECHANGE wm-handlers get-global delete-at
+ close-device-change-window ;
+
+: release-controllers ( -- )
+ +controller-devices+ global [
+ [ nip com-release ] assoc-each f
+ ] change-at ;
+
+: release-keyboard ( -- )
+ +keyboard-device+ global [ com-release f ] change-at ;
+
+M: dinput-game-input-backend open-game-input
+ create-dinput
+ find-keyboard
+ find-controllers ;
+
+M: dinput-game-input-backend close-game-input
+ release-controllers
+ release-keyboard
+ delete-dinput ;
+
--- /dev/null
+DirectInput backend for game-input
--- /dev/null
+input
+gamepads
+joysticks
+windows
M: iokit-game-input-backend get-controllers ( -- sequence )
+controller-states+ get keys [ controller boa ] map ;
-M: iokit-game-input-backend manufacturer ( controller -- string )
- handle>> kIOHIDManufacturerKey device-property ;
-M: iokit-game-input-backend product ( controller -- string )
- handle>> kIOHIDProductKey device-property ;
-M: iokit-game-input-backend vendor-id ( controller -- integer )
- handle>> kIOHIDVendorIDKey device-property ;
+M: iokit-game-input-backend product-string ( controller -- string )
+ handle>>
+ [ kIOHIDManufacturerKey device-property ]
+ [ kIOHIDProductKey device-property ] bi 2array " " join ;
M: iokit-game-input-backend product-id ( controller -- integer )
- handle>> kIOHIDProductIDKey device-property ;
-M: iokit-game-input-backend location-id ( controller -- integer )
+ handle>>
+ [ kIOHIDVendorIDKey device-property ]
+ [ kIOHIDProductIDKey device-property ] bi 2array ;
+M: iokit-game-input-backend instance-id ( controller -- integer )
handle>> kIOHIDLocationIDKey device-property ;
M: iokit-game-input-backend read-controller ( controller -- controller-state )
IN: game-input
ARTICLE: "game-input" "Game controller input"
-"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface to for polling raw keyboard input." $nl
+"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard input." $nl
"The game input interface must be initialized before being used:"
{ $subsection open-game-input }
{ $subsection close-game-input }
{ $subsection with-game-input }
"Once the game input interface is open, connected controller devices can be enumerated:"
{ $subsection get-controllers }
+{ $subsection find-controller-products }
+{ $subsection find-controller-instance }
"These " { $link controller } " objects can be queried of their identity:"
-{ $subsection manufacturer }
-{ $subsection product }
-{ $subsection vendor-id }
+{ $subsection product-string }
{ $subsection product-id }
-{ $subsection location-id }
+{ $subsection instance-id }
"A hook is provided for invoking the system calibration tool:"
{ $subsection calibrate-controller }
"The current state of a controller or the keyboard can be read:"
{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails." } ;
HELP: close-game-input
-{ $description "Closes the game input interface, releasing any allocated resources." } ;
+{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid." } ;
HELP: with-game-input
{ $values { "quot" quotation } }
HELP: get-controllers
{ $values { "sequence" "A " { $link sequence } " of " { $link controller } "s" } }
-{ $description "Returns a " { $link sequence } " of " { $link controller } " objects representing the currently connected game controllers." } ;
+{ $description "Returns a " { $link sequence } " of " { $link controller } " objects representing the currently connected game controllers. The order of the controller objects in the sequence is not significant or guaranteed to be stable between calls to " { $snippet "get-controllers" } "." } ;
+
+HELP: find-controller-products
+{ $values { "product-id" "A product ID as returned by " { $link product-id } } { "sequence" "A " { $link sequence } " of " { $link controller } "s" } }
+{ $description "Returns a " { $link sequence } " of " { $link controller } " objects representing the currently connected game controllers with the given " { $link product-id } ". The order of the controller objects in the sequence is not significant or guaranteed to be stable between calls to " { $snippet "find-controller-products" } "." } ;
+
+HELP: find-controller-instance
+{ $values { "product-id" "A product ID as returned by " { $link product-id } } { "instance-id" "An instance ID as returned by " { $link instance-id } "." } { "controller/f" "A " { $link controller } " object, or " { $link f } } }
+{ $description "Returns the " { $link controller } " instance identified by " { $snippet "product-id" } " and " { $snippet "instance-id" } ". If the identified device is not currently attached, " { $link f } " is returned." } ;
HELP: controller
{ $class-description "Objects of this class represent game controller devices such as joysticks and gamepads. They should be treated as opaque by client code." } ;
-HELP: manufacturer
-{ $values { "controller" controller } { "string" string } }
-{ $description "Returns a human-readable string describing the manufacturer of the game controller device represented by " { $snippet "controller" } "." } ;
-
-HELP: product
+HELP: product-string
{ $values { "controller" controller } { "string" string } }
-{ $description "Returns a human-readable string describing the game controller device represented by " { $snippet "controller" } "." } ;
-
-HELP: vendor-id
-{ $values { "controller" controller } { "integer" integer } }
-{ $description "Returns an identifier uniquely representing the manufacturer of the game controller device represented by " { $snippet "controller" } "." } ;
+{ $description "Returns a human-readable string describing the game controller device represented by " { $snippet "controller" } ". This string is not necessarily unique to the product or instance; to uniquely identify the device, see " { $link product-id } " and " { $link instance-id } "." } ;
HELP: product-id
-{ $values { "controller" controller } { "integer" integer } }
-{ $description "Returns an identifier uniquely representing the kind of game controller device represented by " { $snippet "controller" } "." } ;
+{ $values { "controller" controller } { "id" "A unique identifier" } }
+{ $description "Returns an identifier uniquely representing the kind of game controller device represented by " { $snippet "controller" } ". This identifier will be the same for devices of the same make and manufacturer. The type of the identifier value is platform-specific, but equivalent " { $snippet "product-id" } "s are guaranteed to be testable with the " { $link = } " word. The identifier can be used to find devices of the same kind with the " { $link find-controller-products } " word." } ;
-HELP: location-id
-{ $values { "controller" controller } { "integer" integer } }
-{ $description "Returns an identifier uniquely representing the game controller device represented by " { $snippet "controller" } "'s location in the system." } ;
+HELP: instance-id
+{ $values { "controller" controller } { "id" "A unique identifier" } }
+{ $description "Returns an identifier uniquely representing the game controller device represented by " { $snippet "controller" } ". This identifier paired with the device's " { $link product-id } " provides a unique identifier for a particular device that persists between reboots (but not necessarily between computers). This unique identifier can be used to find the same device again with the " { $snippet find-controller-instance } " word. Depending on the platform, the instance-id may change if the device is plugged into a different port. The type of the identifier value is platform-specific, but equivalent " { $snippet instance-id } "s are guaranteed to be testable with the " { $link = } " word." } ;
-{ manufacturer product-id vendor-id product-id location-id } related-words
+{ product-string product-id instance-id find-controller-products find-controller-instance } related-words
HELP: calibrate-controller
{ $values { "controller" controller } }
-{ $description "Invokes the operating system's calibration tool for " { $snippet "controller" } ". If the operating system does not have a calibration tool, does nothing." } ;
+{ $description "Invokes the operating system's calibration tool for " { $snippet "controller" } ". If the operating system does not have a calibration tool, this word does nothing." } ;
HELP: read-controller
{ $values { "controller" controller } { "controller-state" controller-state } }
-{ $description "Reads the current state of " { $snippet "controller" } ". See the documentation for the " { $link controller-state } " class for details of the returned value's format." } ;
+{ $description "Reads the current state of " { $snippet "controller" } ". See the documentation for the " { $link controller-state } " class for details of the returned value's format. If the device is no longer available, " { $link f } " is returned." } ;
{ controller-state controller read-controller } related-words
HELP: read-keyboard
{ $values { "keyboard-state" keyboard-state } }
{ $description "Reads the current raw state of the keyboard. See the documentation for the " { $link keyboard-state } " class for details on the returned value's format." }
-{ $warning "The keyboard state returned by this word is unprocessed by any keymaps, key repeat settings, or other operating environment postprocessing. Because of this, " { $snippet "read-keyboard" } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is necessary; see " { $link "keyboard-gestures" } "." } ;
+{ $warning "The keyboard state returned by this word is unprocessed by any keymaps, modifier keys, key repeat settings, or other operating environment postprocessing. Because of this, " { $snippet "read-keyboard" } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
HELP: controller-state
{ $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:"
{ { $link pov-up-left } }
} }
{ "For each element of the " { $snippet "buttons" } " array, " { $link f } " indicates that the corresponding button is released. If the button is pressed, a value between 0.0 and 1.0 is returned indicating the pressure on the button (or simply 1.0 if the device's buttons are on/off only)." }
- { "A value of " { $link f } " in any slot (besides the elements of " { $snippet "buttons" } ") indicates that the corresponding axis is not present on the device." } } } ;
+ { "A value of " { $link f } " in any slot (besides the elements of " { $snippet "buttons" } ") indicates that the corresponding element is not present on the device." } } } ;
HELP: keyboard-state
{ $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined under usage page 7 of the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game-input.scancodes" } " vocabulary." }
-{ $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game-input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is necessary; see " { $link "keyboard-gestures" } "." } ;
+{ $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps, modifier keys, or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game-input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
{ keyboard-state read-keyboard } related-words
+
+ABOUT: "game-input"
-USING: arrays accessors continuations kernel symbols ;
+USING: arrays accessors continuations kernel symbols
+combinators.lib sequences ;
IN: game-input
SYMBOL: game-input-backend
HOOK: get-controllers game-input-backend ( -- sequence )
-HOOK: manufacturer game-input-backend ( controller -- string )
-HOOK: product game-input-backend ( controller -- string )
-HOOK: vendor-id game-input-backend ( controller -- integer )
-HOOK: product-id game-input-backend ( controller -- integer )
-HOOK: location-id game-input-backend ( controller -- integer )
+HOOK: product-string game-input-backend ( controller -- string )
+HOOK: product-id game-input-backend ( controller -- id )
+HOOK: instance-id game-input-backend ( controller -- id )
+
+: find-controller-products ( product-id -- sequence )
+ get-controllers [ product-id = ] with filter ;
+: find-controller-instance ( product-id instance-id -- controller/f )
+ get-controllers [
+ [ product-id = ]
+ [ instance-id = ] bi+ bi* and
+ ] 2with find nip ;
HOOK: read-controller game-input-backend ( controller -- controller-state )
HOOK: calibrate-controller game-input-backend ( controller -- )
USING: windows.dinput windows.kernel32 windows.ole32 windows.com
windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces
combinators sequences symbols fry math accessors macros words quotations
-libc continuations generalizations splitting locals assocs ;
+libc continuations generalizations splitting locals assocs init ;
IN: windows.dinput.constants
! Some global variables aren't provided by the DirectInput DLL (they're in the
[ "BOOL" { "LPDIRECTINPUTEFFECT" "LPVOID" } "stdcall" ]
dip alien-callback ; inline
TYPEDEF: void* LPDIENUMEFFECTSINFILECALLBACK
+: LPDIENUMEFFECTSINFILECALLBACK
[ "BOOL" { "LPCDIFILEEFFECT" "LPVOID" } "stdcall" ]
dip alien-callback ; inline
TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW
+: LPDIENUMDEVICEOBJECTSCALLBACKW
[ "BOOL" { "LPCDIDEVICEOBJECTINSTANCE" "LPVOID" } "stdcall" ]
dip alien-callback ; inline
: DISCL_BACKGROUND HEX: 00000008 ; inline
: DISCL_NOWINKEY HEX: 00000010 ; inline
-SYMBOL: +dinput+
-
-: create-dinput ( -- )
- f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
- f <void*> [ f DirectInput8Create ole32-error ] keep *void*
- +dinput+ set ;
-
-: delete-dinput ( -- )
- +dinput+ [ com-release f ] change ;
+: DI8DEVTYPE_DEVICE HEX: 11 ; inline
+: DI8DEVTYPE_MOUSE HEX: 12 ; inline
+: DI8DEVTYPE_KEYBOARD HEX: 13 ; inline
+: DI8DEVTYPE_JOYSTICK HEX: 14 ; inline
+: DI8DEVTYPE_GAMEPAD HEX: 15 ; inline
+: DI8DEVTYPE_DRIVING HEX: 16 ; inline
+: DI8DEVTYPE_FLIGHT HEX: 17 ; inline
+: DI8DEVTYPE_1STPERSON HEX: 18 ; inline
+: DI8DEVTYPE_DEVICECTRL HEX: 19 ; inline
+: DI8DEVTYPE_SCREENPOINTER HEX: 1A ; inline
+: DI8DEVTYPE_REMOTE HEX: 1B ; inline
+: DI8DEVTYPE_SUPPLEMENTAL HEX: 1C ; inline
+: GET_DIDEVICE_TYPE ( dwType -- type ) HEX: FF bitand ; inline
{ "DWORD" "dwHoverTime" } ;
TYPEDEF: TRACKMOUSEEVENT* LPTRACKMOUSEEVENT
+: DBT_DEVICEARRIVAL HEX: 8000 ; inline
+: DBT_DEVICEREMOVECOMPLETE HEX: 8004 ; inline
+
+: DBT_DEVTYP_DEVICEINTERFACE 5 ; inline
+
+: DEVICE_NOTIFY_WINDOW_HANDLE 0 ; inline
+: DEVICE_NOTIFY_SERVICE_HANDLE 1 ; inline
+
+: DEVICE_NOTIFY_ALL_INTERFACE_CLASSES 4 ; inline
+
+C-STRUCT: DEV_BROADCAST_HDR
+ { "DWORD" "dbch_size" }
+ { "DWORD" "dbch_devicetype" }
+ { "DWORD" "dbch_reserved" } ;
+C-STRUCT: DEV_BROADCAST_DEVICEW
+ { "DWORD" "dbcc_size" }
+ { "DWORD" "dbcc_devicetype" }
+ { "DWORD" "dbcc_reserved" }
+ { "GUID" "dbcc_classguid" }
+ { "WCHAR[1]" "dbcc_name" } ;
+
LIBRARY: user32
FUNCTION: HKL ActivateKeyboardLayout ( HKL hkl, UINT Flags ) ;
! FUNCTION: RegisterClipboardFormatA
! FUNCTION: RegisterClipboardFormatW
-! FUNCTION: RegisterDeviceNotificationA
-! FUNCTION: RegisterDeviceNotificationW
+FUNCTION: HANDLE RegisterDeviceNotificationA ( HANDLE hRecipient, LPVOID NotificationFilter, DWORD Flags ) ;
+FUNCTION: HANDLE RegisterDeviceNotificationW ( HANDLE hRecipient, LPVOID NotificationFilter, DWORD Flags ) ;
+ALIAS: RegisterDeviceNotification RegisterDeviceNotificationW
! FUNCTION: RegisterHotKey
! FUNCTION: RegisterLogonProcess
! FUNCTION: RegisterMessagePumpHook
! FUNCTION: UnpackDDElParam
FUNCTION: BOOL UnregisterClassW ( LPCWSTR lpClassName, HINSTANCE hInstance ) ;
ALIAS: UnregisterClass UnregisterClassW
-! FUNCTION: UnregisterDeviceNotification
+FUNCTION: BOOL UnregisterDeviceNotification ( HANDLE hDevNotify ) ;
! FUNCTION: UnregisterHotKey
! FUNCTION: UnregisterMessagePumpHook
! FUNCTION: UnregisterUserApiHook
projects / factor.git / commitdiff