commit
690b744959
|
@ -8,6 +8,15 @@ generalizations macros continuations locals ;
|
||||||
|
|
||||||
IN: combinators.lib
|
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
|
! Generalized versions of core combinators
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Joe Groff
|
|
@ -0,0 +1,151 @@
|
||||||
|
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 ;
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
DirectInput backend for game-input
|
|
@ -0,0 +1,4 @@
|
||||||
|
input
|
||||||
|
gamepads
|
||||||
|
joysticks
|
||||||
|
windows
|
|
@ -252,15 +252,15 @@ M: iokit-game-input-backend close-game-input
|
||||||
M: iokit-game-input-backend get-controllers ( -- sequence )
|
M: iokit-game-input-backend get-controllers ( -- sequence )
|
||||||
+controller-states+ get keys [ controller boa ] map ;
|
+controller-states+ get keys [ controller boa ] map ;
|
||||||
|
|
||||||
M: iokit-game-input-backend manufacturer ( controller -- string )
|
M: iokit-game-input-backend product-string ( controller -- string )
|
||||||
handle>> kIOHIDManufacturerKey device-property ;
|
handle>>
|
||||||
M: iokit-game-input-backend product ( controller -- string )
|
[ kIOHIDManufacturerKey device-property ]
|
||||||
handle>> kIOHIDProductKey device-property ;
|
[ kIOHIDProductKey device-property ] bi 2array " " join ;
|
||||||
M: iokit-game-input-backend vendor-id ( controller -- integer )
|
|
||||||
handle>> kIOHIDVendorIDKey device-property ;
|
|
||||||
M: iokit-game-input-backend product-id ( controller -- integer )
|
M: iokit-game-input-backend product-id ( controller -- integer )
|
||||||
handle>> kIOHIDProductIDKey device-property ;
|
handle>>
|
||||||
M: iokit-game-input-backend location-id ( controller -- integer )
|
[ kIOHIDVendorIDKey device-property ]
|
||||||
|
[ kIOHIDProductIDKey device-property ] bi 2array ;
|
||||||
|
M: iokit-game-input-backend instance-id ( controller -- integer )
|
||||||
handle>> kIOHIDLocationIDKey device-property ;
|
handle>> kIOHIDLocationIDKey device-property ;
|
||||||
|
|
||||||
M: iokit-game-input-backend read-controller ( controller -- controller-state )
|
M: iokit-game-input-backend read-controller ( controller -- controller-state )
|
||||||
|
|
|
@ -3,19 +3,19 @@ sequences strings math ;
|
||||||
IN: game-input
|
IN: game-input
|
||||||
|
|
||||||
ARTICLE: "game-input" "Game controller 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:"
|
"The game input interface must be initialized before being used:"
|
||||||
{ $subsection open-game-input }
|
{ $subsection open-game-input }
|
||||||
{ $subsection close-game-input }
|
{ $subsection close-game-input }
|
||||||
{ $subsection with-game-input }
|
{ $subsection with-game-input }
|
||||||
"Once the game input interface is open, connected controller devices can be enumerated:"
|
"Once the game input interface is open, connected controller devices can be enumerated:"
|
||||||
{ $subsection get-controllers }
|
{ $subsection get-controllers }
|
||||||
|
{ $subsection find-controller-products }
|
||||||
|
{ $subsection find-controller-instance }
|
||||||
"These " { $link controller } " objects can be queried of their identity:"
|
"These " { $link controller } " objects can be queried of their identity:"
|
||||||
{ $subsection manufacturer }
|
{ $subsection product-string }
|
||||||
{ $subsection product }
|
|
||||||
{ $subsection vendor-id }
|
|
||||||
{ $subsection product-id }
|
{ $subsection product-id }
|
||||||
{ $subsection location-id }
|
{ $subsection instance-id }
|
||||||
"A hook is provided for invoking the system calibration tool:"
|
"A hook is provided for invoking the system calibration tool:"
|
||||||
{ $subsection calibrate-controller }
|
{ $subsection calibrate-controller }
|
||||||
"The current state of a controller or the keyboard can be read:"
|
"The current state of a controller or the keyboard can be read:"
|
||||||
|
@ -28,7 +28,7 @@ HELP: open-game-input
|
||||||
{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails." } ;
|
{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails." } ;
|
||||||
|
|
||||||
HELP: close-game-input
|
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
|
HELP: with-game-input
|
||||||
{ $values { "quot" quotation } }
|
{ $values { "quot" quotation } }
|
||||||
|
@ -38,47 +38,47 @@ HELP: with-game-input
|
||||||
|
|
||||||
HELP: get-controllers
|
HELP: get-controllers
|
||||||
{ $values { "sequence" "A " { $link sequence } " of " { $link controller } "s" } }
|
{ $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
|
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." } ;
|
{ $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
|
HELP: product-string
|
||||||
{ $values { "controller" controller } { "string" string } }
|
{ $values { "controller" controller } { "string" string } }
|
||||||
{ $description "Returns a human-readable string describing 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
|
|
||||||
{ $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" } "." } ;
|
|
||||||
|
|
||||||
HELP: product-id
|
HELP: product-id
|
||||||
{ $values { "controller" controller } { "integer" integer } }
|
{ $values { "controller" controller } { "id" "A unique identifier" } }
|
||||||
{ $description "Returns an identifier uniquely representing the kind of game controller device represented by " { $snippet "controller" } "." } ;
|
{ $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
|
HELP: instance-id
|
||||||
{ $values { "controller" controller } { "integer" integer } }
|
{ $values { "controller" controller } { "id" "A unique identifier" } }
|
||||||
{ $description "Returns an identifier uniquely representing the game controller device represented by " { $snippet "controller" } "'s location in the system." } ;
|
{ $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
|
HELP: calibrate-controller
|
||||||
{ $values { "controller" 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
|
HELP: read-controller
|
||||||
{ $values { "controller" controller } { "controller-state" controller-state } }
|
{ $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
|
{ controller-state controller read-controller } related-words
|
||||||
|
|
||||||
HELP: read-keyboard
|
HELP: read-keyboard
|
||||||
{ $values { "keyboard-state" keyboard-state } }
|
{ $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." }
|
{ $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
|
HELP: controller-state
|
||||||
{ $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:"
|
{ $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:"
|
||||||
|
@ -109,10 +109,12 @@ HELP: controller-state
|
||||||
{ { $link pov-up-left } }
|
{ { $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)." }
|
{ "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
|
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." }
|
{ $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
|
{ keyboard-state read-keyboard } related-words
|
||||||
|
|
||||||
|
ABOUT: "game-input"
|
||||||
|
|
|
@ -1,4 +1,5 @@
|
||||||
USING: arrays accessors continuations kernel symbols ;
|
USING: arrays accessors continuations kernel symbols
|
||||||
|
combinators.lib sequences ;
|
||||||
IN: game-input
|
IN: game-input
|
||||||
|
|
||||||
SYMBOL: game-input-backend
|
SYMBOL: game-input-backend
|
||||||
|
@ -22,11 +23,17 @@ SYMBOLS:
|
||||||
|
|
||||||
HOOK: get-controllers game-input-backend ( -- sequence )
|
HOOK: get-controllers game-input-backend ( -- sequence )
|
||||||
|
|
||||||
HOOK: manufacturer game-input-backend ( controller -- string )
|
HOOK: product-string game-input-backend ( controller -- string )
|
||||||
HOOK: product game-input-backend ( controller -- string )
|
HOOK: product-id game-input-backend ( controller -- id )
|
||||||
HOOK: vendor-id game-input-backend ( controller -- integer )
|
HOOK: instance-id game-input-backend ( controller -- id )
|
||||||
HOOK: product-id game-input-backend ( controller -- integer )
|
|
||||||
HOOK: location-id game-input-backend ( controller -- integer )
|
: 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: read-controller game-input-backend ( controller -- controller-state )
|
||||||
HOOK: calibrate-controller game-input-backend ( controller -- )
|
HOOK: calibrate-controller game-input-backend ( controller -- )
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
USING: windows.dinput windows.kernel32 windows.ole32 windows.com
|
USING: windows.dinput windows.kernel32 windows.ole32 windows.com
|
||||||
windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces
|
windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces
|
||||||
combinators sequences symbols fry math accessors macros words quotations
|
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
|
IN: windows.dinput.constants
|
||||||
|
|
||||||
! Some global variables aren't provided by the DirectInput DLL (they're in the
|
! Some global variables aren't provided by the DirectInput DLL (they're in the
|
||||||
|
|
|
@ -31,9 +31,11 @@ TYPEDEF: void* LPDIENUMCREATEDEFFECTOBJECTSCALLBACK
|
||||||
[ "BOOL" { "LPDIRECTINPUTEFFECT" "LPVOID" } "stdcall" ]
|
[ "BOOL" { "LPDIRECTINPUTEFFECT" "LPVOID" } "stdcall" ]
|
||||||
dip alien-callback ; inline
|
dip alien-callback ; inline
|
||||||
TYPEDEF: void* LPDIENUMEFFECTSINFILECALLBACK
|
TYPEDEF: void* LPDIENUMEFFECTSINFILECALLBACK
|
||||||
|
: LPDIENUMEFFECTSINFILECALLBACK
|
||||||
[ "BOOL" { "LPCDIFILEEFFECT" "LPVOID" } "stdcall" ]
|
[ "BOOL" { "LPCDIFILEEFFECT" "LPVOID" } "stdcall" ]
|
||||||
dip alien-callback ; inline
|
dip alien-callback ; inline
|
||||||
TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW
|
TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW
|
||||||
|
: LPDIENUMDEVICEOBJECTSCALLBACKW
|
||||||
[ "BOOL" { "LPCDIDEVICEOBJECTINSTANCE" "LPVOID" } "stdcall" ]
|
[ "BOOL" { "LPCDIDEVICEOBJECTINSTANCE" "LPVOID" } "stdcall" ]
|
||||||
dip alien-callback ; inline
|
dip alien-callback ; inline
|
||||||
|
|
||||||
|
@ -562,3 +564,17 @@ SYMBOL: +dinput+
|
||||||
: delete-dinput ( -- )
|
: delete-dinput ( -- )
|
||||||
+dinput+ [ com-release f ] change ;
|
+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
|
||||||
|
|
|
@ -528,6 +528,27 @@ C-STRUCT: TRACKMOUSEEVENT
|
||||||
{ "DWORD" "dwHoverTime" } ;
|
{ "DWORD" "dwHoverTime" } ;
|
||||||
TYPEDEF: TRACKMOUSEEVENT* LPTRACKMOUSEEVENT
|
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
|
LIBRARY: user32
|
||||||
|
|
||||||
FUNCTION: HKL ActivateKeyboardLayout ( HKL hkl, UINT Flags ) ;
|
FUNCTION: HKL ActivateKeyboardLayout ( HKL hkl, UINT Flags ) ;
|
||||||
|
@ -1176,8 +1197,9 @@ ALIAS: RegisterClassEx RegisterClassExW
|
||||||
|
|
||||||
! FUNCTION: RegisterClipboardFormatA
|
! FUNCTION: RegisterClipboardFormatA
|
||||||
! FUNCTION: RegisterClipboardFormatW
|
! FUNCTION: RegisterClipboardFormatW
|
||||||
! FUNCTION: RegisterDeviceNotificationA
|
FUNCTION: HANDLE RegisterDeviceNotificationA ( HANDLE hRecipient, LPVOID NotificationFilter, DWORD Flags ) ;
|
||||||
! FUNCTION: RegisterDeviceNotificationW
|
FUNCTION: HANDLE RegisterDeviceNotificationW ( HANDLE hRecipient, LPVOID NotificationFilter, DWORD Flags ) ;
|
||||||
|
ALIAS: RegisterDeviceNotification RegisterDeviceNotificationW
|
||||||
! FUNCTION: RegisterHotKey
|
! FUNCTION: RegisterHotKey
|
||||||
! FUNCTION: RegisterLogonProcess
|
! FUNCTION: RegisterLogonProcess
|
||||||
! FUNCTION: RegisterMessagePumpHook
|
! FUNCTION: RegisterMessagePumpHook
|
||||||
|
@ -1344,7 +1366,7 @@ FUNCTION: BOOL TranslateMessage ( MSG* lpMsg ) ;
|
||||||
! FUNCTION: UnpackDDElParam
|
! FUNCTION: UnpackDDElParam
|
||||||
FUNCTION: BOOL UnregisterClassW ( LPCWSTR lpClassName, HINSTANCE hInstance ) ;
|
FUNCTION: BOOL UnregisterClassW ( LPCWSTR lpClassName, HINSTANCE hInstance ) ;
|
||||||
ALIAS: UnregisterClass UnregisterClassW
|
ALIAS: UnregisterClass UnregisterClassW
|
||||||
! FUNCTION: UnregisterDeviceNotification
|
FUNCTION: BOOL UnregisterDeviceNotification ( HANDLE hDevNotify ) ;
|
||||||
! FUNCTION: UnregisterHotKey
|
! FUNCTION: UnregisterHotKey
|
||||||
! FUNCTION: UnregisterMessagePumpHook
|
! FUNCTION: UnregisterMessagePumpHook
|
||||||
! FUNCTION: UnregisterUserApiHook
|
! FUNCTION: UnregisterUserApiHook
|
||||||
|
|
Loading…
Reference in New Issue