+++ /dev/null
-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.dinput windows.dinput.constants
-windows.errors windows.kernel32 windows.messages
-windows.ole32 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 <void*> [ 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 <void*>
- [ 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 ;
-
-: <buffer-size-diprop> ( size -- DIPROPDWORD )
- 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>
- 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 <byte-array> 256 <keys-array> 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 <array> mouse-state boa +mouse-state+ set-global
- MOUSE-BUFFER-SIZE <DIDEVICEOBJECTDATA-array> +mouse-buffer+ set-global ;
-
-: device-info ( device -- DIDEVICEIMAGEINFOW )
- DIDEVICEINSTANCEW <struct>
- DIDEVICEINSTANCEW heap-size >>dwSize
- [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ; inline
-: device-caps ( device -- DIDEVCAPS )
- DIDEVCAPS <struct>
- 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 <array> >>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 <vector> +controller-devices+ set-global
- 4 <vector> +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
-
-: <DEV_BROADCAST_HDR> ( wParam -- struct )
- <alien> DEV_BROADCAST_HDR memory>struct ;
-
-: handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
- [ 2drop ] 2dip swap {
- { [ dup DBT_DEVICEARRIVAL = ] [ drop <DEV_BROADCAST_HDR> device-arrived ] }
- { [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <DEV_BROADCAST_HDR> 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 <struct>
- DEV_BROADCAST_DEVICEW heap-size >>dbcc_size
- DBT_DEVTYP_DEVICEINTERFACE >>dbcc_devicetype ;
-
-: create-device-change-window ( -- )
- <zero-window-rect> 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 <keys-array> >>buttons ]
- } 2cleave ;
-
-: read-device-buffer ( device buffer count -- buffer count' )
- [ DIDEVICEOBJECTDATA heap-size ] 2dip <uint>
- [ 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 )
- [ +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 <struct> [ 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 ;
+++ /dev/null
-USING: sequences sequences.private math
-accessors alien.data ;
-IN: game-input.dinput.keys-array
-
-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 length>> ;
-M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
-
-INSTANCE: keys-array sequence
-
+++ /dev/null
-DirectInput backend for game-input
+++ /dev/null
-unportable
-games
+++ /dev/null
-USING: help.markup help.syntax kernel ui.gestures quotations
-sequences strings math ;
-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 for polling raw keyboard and mouse input." $nl
-"The game input interface must be initialized before being used:"
-{ $subsections
- open-game-input
- close-game-input
- with-game-input
-}
-"Once the game input interface is open, connected controller devices can be enumerated:"
-{ $subsections
- get-controllers
- find-controller-products
- find-controller-instance
-}
-"These " { $link controller } " objects can be queried of their identity:"
-{ $subsections
- product-string
- product-id
- instance-id
-}
-"A hook is provided for invoking the system calibration tool:"
-{ $subsections calibrate-controller }
-"The current state of a controller, the keyboard, and the mouse can be read:"
-{ $subsections
- read-controller
- read-keyboard
- read-mouse
- controller-state
- keyboard-state
- mouse-state
-} ;
-
-HELP: open-game-input
-{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. Calls to open-game-input are reference counted; each call to open-game-input needs a corresponding call to close-game-input to close the game input interface." } ;
-
-HELP: close-game-input
-{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid." } ;
-
-HELP: game-input-opened?
-{ $values { "?" "a boolean" } }
-{ $description "Returns true if the game input interface is open, false otherwise." } ;
-
-HELP: with-game-input
-{ $values { "quot" quotation } }
-{ $description "Initializes the game input interface for the dynamic extent of " { $snippet "quotation" } "." } ;
-
-{ open-game-input close-game-input with-game-input game-input-opened? } related-words
-
-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. 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: product-string
-{ $values { "controller" controller } { "string" string } }
-{ $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 } { "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: 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." } ;
-
-{ 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, 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. If the device is no longer available, " { $link f } " is returned." }
-{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "controller-state" } " object next time " { $snippet "read-controller" } " is called on the same controller. You should " { $link clone } " any values from the returned tuple you need to preserve." } ;
-
-{ 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 "For efficiency, the implementation may reuse the returned " { $snippet "keyboard-state" } " object next time " { $snippet "read-keyboard" } " is called. You should " { $link clone } " any values from the returned tuple you need to preserve."
-$nl "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: read-mouse
-{ $values { "mouse-state" mouse-state } }
-{ $description "Reads the current mouse state relative to either when the game input interface was opened with " { $link open-game-input } " or when the mouse state was reset with " { $link reset-mouse } "." }
-{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "mouse-state" } " object for future " { $snippet "read-mouse" } " or " { $snippet "reset-mouse" } " calls. You should " { $link clone } " the " { $snippet "mouse-state" } " object if you need to preserve it." } ;
-
-HELP: reset-mouse
-{ $description "Resets the mouse state. Future " { $link read-mouse } " values will be relative to the time this word is called." } ;
-
-HELP: controller-state
-{ $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:"
-{ $list
- { { $snippet "x" } " contains the position of the device's X axis." }
- { { $snippet "y" } " contains the position of the device's Y axis." }
- { { $snippet "z" } " contains the position of the device's Z axis, if any." }
- { { $snippet "rx" } " contains the rotational position of the device's X axis, if available." }
- { { $snippet "ry" } " contains the rotational position of the device's Y axis, if available." }
- { { $snippet "rz" } " contains the rotational position of the device's Z axis, if available." }
- { { $snippet "slider" } " contains the position of the device's throttle slider, if any." }
- { { $snippet "pov" } " contains the state of the device's POV hat, if any." }
- { { $snippet "buttons" } " contains a sequence of values indicating the state of every button on the device." }
-}
-"The values are formatted as follows:"
-{ $list
- { "For the axis slots (" { $snippet "x" } ", " { $snippet "y" } ", " { $snippet "z" } ", " { $snippet "rx" } ", " { $snippet "ry" } ", " { $snippet "rz" } "), a " { $link float } " value between -1.0 and 1.0 is returned." }
- { "For the " { $snippet "slider" } " slot, a value between 0.0 and 1.0 is returned." }
- { "For the " { $snippet "pov" } " slot, one of the following symbols is returned:" { $list
- { { $link pov-neutral } }
- { { $link pov-up } }
- { { $link pov-up-right } }
- { { $link pov-right } }
- { { $link pov-down-right } }
- { { $link pov-down } }
- { { $link pov-down-left } }
- { { $link pov-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)." }
- { "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, 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" } "." } ;
-
-HELP: mouse-state
-{ $class-description "The " { $link read-mouse } " word returns objects of this class. " { $snippet "mouse-state" } " objects have the following slots:"
-{ $list
- { { $snippet "dx" } " contains the mouse's X axis movement." }
- { { $snippet "dy" } " contains the mouse's Y axis movement." }
- { { $snippet "scroll-dx" } " contains the scroller's X axis movement." }
- { { $snippet "scroll-dy" } " contains the scroller's Y axis movement." }
- { { $snippet "buttons" } " contains a sequence of boolean values indicate the state of the mouse's buttons." }
-}
-"Mouse movement is recorded relative to when the game input interface was opened with " { $link open-game-input } " or the mouse state is reset with " { $link reset-mouse } "."
-} ;
-
-
-{ keyboard-state read-keyboard } related-words
-
-ABOUT: "game-input"
+++ /dev/null
-USING: ui game-input tools.test kernel system threads calendar
-combinators.short-circuit ;
-IN: game-input.tests
-
-os { [ windows? ] [ macosx? ] } 1|| [
- [ ] [ open-game-input ] unit-test
- [ ] [ 1 seconds sleep ] unit-test
- [ ] [ close-game-input ] unit-test
-] when
+++ /dev/null
-USING: arrays accessors continuations kernel math system
-sequences namespaces init vocabs vocabs.loader combinators ;
-IN: game-input
-
-SYMBOLS: game-input-backend game-input-opened ;
-
-game-input-opened [ 0 ] initialize
-
-HOOK: (open-game-input) game-input-backend ( -- )
-HOOK: (close-game-input) game-input-backend ( -- )
-HOOK: (reset-game-input) game-input-backend ( -- )
-
-HOOK: get-controllers game-input-backend ( -- sequence )
-
-HOOK: product-string game-input-backend ( controller -- string )
-HOOK: product-id game-input-backend ( controller -- id )
-HOOK: instance-id game-input-backend ( controller -- id )
-
-HOOK: read-controller game-input-backend ( controller -- controller-state )
-HOOK: calibrate-controller game-input-backend ( controller -- )
-
-HOOK: read-keyboard game-input-backend ( -- keyboard-state )
-
-HOOK: read-mouse game-input-backend ( -- mouse-state )
-
-HOOK: reset-mouse game-input-backend ( -- )
-
-: game-input-opened? ( -- ? )
- game-input-opened get zero? not ;
-
-<PRIVATE
-
-M: f (reset-game-input) ;
-
-: reset-game-input ( -- )
- (reset-game-input) ;
-
-[ reset-game-input ] "game-input" add-init-hook
-
-PRIVATE>
-
-ERROR: game-input-not-open ;
-
-: open-game-input ( -- )
- game-input-opened? [
- (open-game-input)
- ] unless
- game-input-opened [ 1 + ] change-global
- reset-mouse ;
-: close-game-input ( -- )
- game-input-opened [
- dup zero? [ game-input-not-open ] when
- 1 -
- ] change-global
- game-input-opened? [
- (close-game-input)
- reset-game-input
- ] unless ;
-
-: with-game-input ( quot -- )
- open-game-input [ close-game-input ] [ ] cleanup ; inline
-
-TUPLE: controller handle ;
-TUPLE: controller-state x y z rx ry rz slider pov buttons ;
-
-M: controller-state clone
- call-next-method dup buttons>> clone >>buttons ;
-
-SYMBOLS:
- pov-neutral
- pov-up pov-up-right pov-right pov-down-right
- pov-down pov-down-left pov-left pov-up-left ;
-
-: find-controller-products ( product-id -- sequence )
- get-controllers [ product-id = ] with filter ;
-: find-controller-instance ( product-id instance-id -- controller/f )
- get-controllers [
- tuck
- [ product-id = ]
- [ instance-id = ] 2bi* and
- ] with with find nip ;
-
-TUPLE: keyboard-state keys ;
-
-M: keyboard-state clone
- call-next-method dup keys>> clone >>keys ;
-
-TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ;
-
-M: mouse-state clone
- call-next-method dup buttons>> clone >>buttons ;
-
-{
- { [ os windows? ] [ "game-input.dinput" require ] }
- { [ os macosx? ] [ "game-input.iokit" require ] }
- { [ t ] [ ] }
-} cond
+++ /dev/null
-USING: cocoa cocoa.plists core-foundation iokit iokit.hid
-kernel cocoa.enumeration destructors math.parser cocoa.application
-sequences locals combinators.short-circuit threads
-namespaces assocs arrays combinators hints alien
-core-foundation.run-loop accessors sequences.private
-alien.c-types alien.data math parser game-input vectors
-bit-arrays ;
-IN: game-input.iokit
-
-SINGLETON: iokit-game-input-backend
-
-SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
-
-iokit-game-input-backend game-input-backend set-global
-
-: make-hid-manager ( -- alien )
- f 0 IOHIDManagerCreate ;
-
-: set-hid-manager-matching ( alien matching-seq -- )
- >plist IOHIDManagerSetDeviceMatchingMultiple ;
-
-: devices-from-hid-manager ( manager -- vector )
- [
- IOHIDManagerCopyDevices
- [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
- ] with-destructors ;
-
-CONSTANT: game-devices-matching-seq
- {
- H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses
- H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
- H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
- H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
- H{ { "DeviceUsage" 7 } { "DeviceUsagePage" 1 } } ! keypads
- H{ { "DeviceUsage" 8 } { "DeviceUsagePage" 1 } } ! multiaxis controllers
- }
-
-CONSTANT: buttons-matching-hash
- H{ { "UsagePage" 9 } { "Type" 2 } }
-CONSTANT: keys-matching-hash
- H{ { "UsagePage" 7 } { "Type" 2 } }
-CONSTANT: x-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 30 } { "Type" 1 } }
-CONSTANT: y-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 31 } { "Type" 1 } }
-CONSTANT: z-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 32 } { "Type" 1 } }
-CONSTANT: rx-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 33 } { "Type" 1 } }
-CONSTANT: ry-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 34 } { "Type" 1 } }
-CONSTANT: rz-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } }
-CONSTANT: slider-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } }
-CONSTANT: wheel-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 38 } { "Type" 1 } }
-CONSTANT: hat-switch-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } }
-
-: device-elements-matching ( device matching-hash -- vector )
- [
- >plist 0 IOHIDDeviceCopyMatchingElements
- [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
- ] with-destructors ;
-
-: button-count ( device -- button-count )
- buttons-matching-hash device-elements-matching length ;
-
-: ?axis ( device hash -- axis/f )
- device-elements-matching [ f ] [ first ] if-empty ;
-
-: ?x-axis ( device -- ? )
- x-axis-matching-hash ?axis ;
-: ?y-axis ( device -- ? )
- y-axis-matching-hash ?axis ;
-: ?z-axis ( device -- ? )
- z-axis-matching-hash ?axis ;
-: ?rx-axis ( device -- ? )
- rx-axis-matching-hash ?axis ;
-: ?ry-axis ( device -- ? )
- ry-axis-matching-hash ?axis ;
-: ?rz-axis ( device -- ? )
- rz-axis-matching-hash ?axis ;
-: ?slider ( device -- ? )
- slider-matching-hash ?axis ;
-: ?hat-switch ( device -- ? )
- hat-switch-matching-hash ?axis ;
-
-: device-property ( device key -- value )
- <NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
-: element-property ( element key -- value )
- <NSString> IOHIDElementGetProperty [ plist> ] [ f ] if* ;
-: set-element-property ( element key value -- )
- [ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
-: transfer-element-property ( element from-key to-key -- )
- [ dupd element-property ] dip swap
- [ set-element-property ] [ 2drop ] if* ;
-
-: mouse-device? ( device -- ? )
- 1 2 IOHIDDeviceConformsTo ;
-
-: controller-device? ( device -- ? )
- {
- [ 1 4 IOHIDDeviceConformsTo ]
- [ 1 5 IOHIDDeviceConformsTo ]
- [ 1 8 IOHIDDeviceConformsTo ]
- } 1|| ;
-
-: element-usage ( element -- {usage-page,usage} )
- [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
- 2array ;
-
-: button? ( element -- ? )
- IOHIDElementGetUsagePage 9 = ; inline
-: keyboard-key? ( element -- ? )
- IOHIDElementGetUsagePage 7 = ; inline
-: axis? ( element -- ? )
- IOHIDElementGetUsagePage 1 = ; inline
-
-: x-axis? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 30 = ; inline
-: y-axis? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 31 = ; inline
-: z-axis? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 32 = ; inline
-: rx-axis? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 33 = ; inline
-: ry-axis? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 34 = ; inline
-: rz-axis? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 35 = ; inline
-: slider? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 36 = ; inline
-: wheel? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 38 = ; inline
-: hat-switch? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 39 = ; inline
-
-CONSTANT: pov-values
- {
- pov-up pov-up-right pov-right pov-down-right
- pov-down pov-down-left pov-left pov-up-left
- pov-neutral
- }
-
-: button-value ( value -- f/(0,1] )
- IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
-: axis-value ( value -- [-1,1] )
- kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
-: mouse-axis-value ( value -- n )
- IOHIDValueGetIntegerValue ;
-: pov-value ( value -- pov-direction )
- IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
-
-: record-button ( state hid-value element -- )
- [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1 - ] tri* rot set-nth ;
-
-: record-controller ( controller-state value -- )
- dup IOHIDValueGetElement {
- { [ dup button? ] [ record-button ] }
- { [ dup axis? ] [ {
- { [ dup x-axis? ] [ drop axis-value >>x drop ] }
- { [ dup y-axis? ] [ drop axis-value >>y drop ] }
- { [ dup z-axis? ] [ drop axis-value >>z drop ] }
- { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
- { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
- { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
- { [ dup slider? ] [ drop axis-value >>slider drop ] }
- { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
- [ 3drop ]
- } cond ] }
- [ 3drop ]
- } cond ;
-
-HINTS: record-controller { controller-state alien } ;
-
-: ?set-nth ( value nth seq -- )
- 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
-
-: record-keyboard ( keyboard-state value -- )
- dup IOHIDValueGetElement dup keyboard-key? [
- [ IOHIDValueGetIntegerValue c-bool> ]
- [ IOHIDElementGetUsage ] bi*
- rot ?set-nth
- ] [ 3drop ] if ;
-
-HINTS: record-keyboard { bit-array alien } ;
-
-: record-mouse ( mouse-state value -- )
- dup IOHIDValueGetElement {
- { [ dup button? ] [ record-button ] }
- { [ dup axis? ] [ {
- { [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] }
- { [ dup y-axis? ] [ drop mouse-axis-value [ + ] curry change-dy drop ] }
- { [ dup wheel? ] [ drop mouse-axis-value [ + ] curry change-scroll-dx drop ] }
- { [ dup z-axis? ] [ drop mouse-axis-value [ + ] curry change-scroll-dy drop ] }
- [ 3drop ]
- } cond ] }
- [ 3drop ]
- } cond ;
-
-HINTS: record-mouse { mouse-state alien } ;
-
-M: iokit-game-input-backend read-mouse
- +mouse-state+ get ;
-
-M: iokit-game-input-backend reset-mouse
- +mouse-state+ get
- 0 >>dx
- 0 >>dy
- 0 >>scroll-dx
- 0 >>scroll-dy
- drop ;
-
-: default-calibrate-saturation ( element -- )
- [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
- [ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ]
- bi ;
-
-: default-calibrate-axis ( element -- )
- [ kIOHIDElementCalibrationMinKey -1.0 set-element-property ]
- [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
- [ default-calibrate-saturation ]
- tri ;
-
-: default-calibrate-slider ( element -- )
- [ kIOHIDElementCalibrationMinKey 0.0 set-element-property ]
- [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
- [ default-calibrate-saturation ]
- tri ;
-
-: (default) ( ? quot -- )
- [ f ] if* ; inline
-
-: <device-controller-state> ( device -- controller-state )
- {
- [ ?x-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?y-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?z-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?rx-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?ry-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?rz-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?slider [ default-calibrate-slider 0.0 ] (default) ]
- [ ?hat-switch pov-neutral and ]
- [ button-count f <array> ]
- } cleave controller-state boa ;
-
-: ?add-mouse-buttons ( device -- )
- button-count +mouse-state+ get buttons>>
- 2dup length >
- [ set-length ] [ 2drop ] if ;
-
-: device-matched-callback ( -- alien )
- [| context result sender device |
- {
- { [ device controller-device? ] [
- device <device-controller-state>
- device +controller-states+ get set-at
- ] }
- { [ device mouse-device? ] [ device ?add-mouse-buttons ] }
- [ ]
- } cond
- ] IOHIDDeviceCallback ;
-
-: device-removed-callback ( -- alien )
- [| context result sender device |
- device +controller-states+ get delete-at
- ] IOHIDDeviceCallback ;
-
-: device-input-callback ( -- alien )
- [| context result sender value |
- {
- { [ sender controller-device? ] [
- sender +controller-states+ get at value record-controller
- ] }
- { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] }
- [ +keyboard-state+ get value record-keyboard ]
- } cond
- ] IOHIDValueCallback ;
-
-: initialize-variables ( manager -- )
- +hid-manager+ set-global
- 4 <vector> +controller-states+ set-global
- 0 0 0 0 2 <vector> mouse-state boa
- +mouse-state+ set-global
- 256 <bit-array> +keyboard-state+ set-global ;
-
-M: iokit-game-input-backend (open-game-input)
- make-hid-manager {
- [ initialize-variables ]
- [ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
- [ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
- [ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
- [ 0 IOHIDManagerOpen mach-error ]
- [ game-devices-matching-seq set-hid-manager-matching ]
- [
- CFRunLoopGetMain CFRunLoopDefaultMode
- IOHIDManagerScheduleWithRunLoop
- ]
- } cleave ;
-
-M: iokit-game-input-backend (reset-game-input)
- { +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ }
- [ f swap set-global ] each ;
-
-M: iokit-game-input-backend (close-game-input)
- +hid-manager+ get-global [
- +hid-manager+ [
- [
- CFRunLoopGetMain CFRunLoopDefaultMode
- IOHIDManagerUnscheduleFromRunLoop
- ]
- [ 0 IOHIDManagerClose drop ]
- [ CFRelease ] tri
- f
- ] change-global
- f +keyboard-state+ set-global
- f +mouse-state+ set-global
- f +controller-states+ set-global
- ] when ;
-
-M: iokit-game-input-backend get-controllers ( -- sequence )
- +controller-states+ get keys [ controller boa ] map ;
-
-: ?join ( pre post sep -- string )
- 2over start [ swap 2nip ] [ [ 2array ] dip join ] if ;
-
-M: iokit-game-input-backend product-string ( controller -- string )
- handle>>
- [ kIOHIDManufacturerKey device-property ]
- [ kIOHIDProductKey device-property ] bi " " ?join ;
-M: iokit-game-input-backend product-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 )
- handle>> +controller-states+ get at clone ;
-
-M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
- +keyboard-state+ get clone keyboard-state boa ;
-
-M: iokit-game-input-backend calibrate-controller ( controller -- )
- drop ;
+++ /dev/null
-IOKit HID Manager backend for game-input
+++ /dev/null
-unportable
-games
+++ /dev/null
-IN: game-input.scancodes
-
-CONSTANT: key-undefined HEX: 0000
-CONSTANT: key-error-roll-over HEX: 0001
-CONSTANT: key-error-post-fail HEX: 0002
-CONSTANT: key-error-undefined HEX: 0003
-CONSTANT: key-a HEX: 0004
-CONSTANT: key-b HEX: 0005
-CONSTANT: key-c HEX: 0006
-CONSTANT: key-d HEX: 0007
-CONSTANT: key-e HEX: 0008
-CONSTANT: key-f HEX: 0009
-CONSTANT: key-g HEX: 000a
-CONSTANT: key-h HEX: 000b
-CONSTANT: key-i HEX: 000c
-CONSTANT: key-j HEX: 000d
-CONSTANT: key-k HEX: 000e
-CONSTANT: key-l HEX: 000f
-CONSTANT: key-m HEX: 0010
-CONSTANT: key-n HEX: 0011
-CONSTANT: key-o HEX: 0012
-CONSTANT: key-p HEX: 0013
-CONSTANT: key-q HEX: 0014
-CONSTANT: key-r HEX: 0015
-CONSTANT: key-s HEX: 0016
-CONSTANT: key-t HEX: 0017
-CONSTANT: key-u HEX: 0018
-CONSTANT: key-v HEX: 0019
-CONSTANT: key-w HEX: 001a
-CONSTANT: key-x HEX: 001b
-CONSTANT: key-y HEX: 001c
-CONSTANT: key-z HEX: 001d
-CONSTANT: key-1 HEX: 001e
-CONSTANT: key-2 HEX: 001f
-CONSTANT: key-3 HEX: 0020
-CONSTANT: key-4 HEX: 0021
-CONSTANT: key-5 HEX: 0022
-CONSTANT: key-6 HEX: 0023
-CONSTANT: key-7 HEX: 0024
-CONSTANT: key-8 HEX: 0025
-CONSTANT: key-9 HEX: 0026
-CONSTANT: key-0 HEX: 0027
-CONSTANT: key-return HEX: 0028
-CONSTANT: key-escape HEX: 0029
-CONSTANT: key-backspace HEX: 002a
-CONSTANT: key-tab HEX: 002b
-CONSTANT: key-space HEX: 002c
-CONSTANT: key-- HEX: 002d
-CONSTANT: key-= HEX: 002e
-CONSTANT: key-[ HEX: 002f
-CONSTANT: key-] HEX: 0030
-CONSTANT: key-\ HEX: 0031
-CONSTANT: key-#-non-us HEX: 0032
-CONSTANT: key-; HEX: 0033
-CONSTANT: key-' HEX: 0034
-CONSTANT: key-` HEX: 0035
-CONSTANT: key-, HEX: 0036
-CONSTANT: key-. HEX: 0037
-CONSTANT: key-/ HEX: 0038
-CONSTANT: key-caps-lock HEX: 0039
-CONSTANT: key-f1 HEX: 003a
-CONSTANT: key-f2 HEX: 003b
-CONSTANT: key-f3 HEX: 003c
-CONSTANT: key-f4 HEX: 003d
-CONSTANT: key-f5 HEX: 003e
-CONSTANT: key-f6 HEX: 003f
-CONSTANT: key-f7 HEX: 0040
-CONSTANT: key-f8 HEX: 0041
-CONSTANT: key-f9 HEX: 0042
-CONSTANT: key-f10 HEX: 0043
-CONSTANT: key-f11 HEX: 0044
-CONSTANT: key-f12 HEX: 0045
-CONSTANT: key-print-screen HEX: 0046
-CONSTANT: key-scroll-lock HEX: 0047
-CONSTANT: key-pause HEX: 0048
-CONSTANT: key-insert HEX: 0049
-CONSTANT: key-home HEX: 004a
-CONSTANT: key-page-up HEX: 004b
-CONSTANT: key-delete HEX: 004c
-CONSTANT: key-end HEX: 004d
-CONSTANT: key-page-down HEX: 004e
-CONSTANT: key-right-arrow HEX: 004f
-CONSTANT: key-left-arrow HEX: 0050
-CONSTANT: key-down-arrow HEX: 0051
-CONSTANT: key-up-arrow HEX: 0052
-CONSTANT: key-keypad-numlock HEX: 0053
-CONSTANT: key-keypad-/ HEX: 0054
-CONSTANT: key-keypad-* HEX: 0055
-CONSTANT: key-keypad-- HEX: 0056
-CONSTANT: key-keypad-+ HEX: 0057
-CONSTANT: key-keypad-enter HEX: 0058
-CONSTANT: key-keypad-1 HEX: 0059
-CONSTANT: key-keypad-2 HEX: 005a
-CONSTANT: key-keypad-3 HEX: 005b
-CONSTANT: key-keypad-4 HEX: 005c
-CONSTANT: key-keypad-5 HEX: 005d
-CONSTANT: key-keypad-6 HEX: 005e
-CONSTANT: key-keypad-7 HEX: 005f
-CONSTANT: key-keypad-8 HEX: 0060
-CONSTANT: key-keypad-9 HEX: 0061
-CONSTANT: key-keypad-0 HEX: 0062
-CONSTANT: key-keypad-. HEX: 0063
-CONSTANT: key-\-non-us HEX: 0064
-CONSTANT: key-application HEX: 0065
-CONSTANT: key-power HEX: 0066
-CONSTANT: key-keypad-= HEX: 0067
-CONSTANT: key-f13 HEX: 0068
-CONSTANT: key-f14 HEX: 0069
-CONSTANT: key-f15 HEX: 006a
-CONSTANT: key-f16 HEX: 006b
-CONSTANT: key-f17 HEX: 006c
-CONSTANT: key-f18 HEX: 006d
-CONSTANT: key-f19 HEX: 006e
-CONSTANT: key-f20 HEX: 006f
-CONSTANT: key-f21 HEX: 0070
-CONSTANT: key-f22 HEX: 0071
-CONSTANT: key-f23 HEX: 0072
-CONSTANT: key-f24 HEX: 0073
-CONSTANT: key-execute HEX: 0074
-CONSTANT: key-help HEX: 0075
-CONSTANT: key-menu HEX: 0076
-CONSTANT: key-select HEX: 0077
-CONSTANT: key-stop HEX: 0078
-CONSTANT: key-again HEX: 0079
-CONSTANT: key-undo HEX: 007a
-CONSTANT: key-cut HEX: 007b
-CONSTANT: key-copy HEX: 007c
-CONSTANT: key-paste HEX: 007d
-CONSTANT: key-find HEX: 007e
-CONSTANT: key-mute HEX: 007f
-CONSTANT: key-volume-up HEX: 0080
-CONSTANT: key-volume-down HEX: 0081
-CONSTANT: key-locking-caps-lock HEX: 0082
-CONSTANT: key-locking-num-lock HEX: 0083
-CONSTANT: key-locking-scroll-lock HEX: 0084
-CONSTANT: key-keypad-, HEX: 0085
-CONSTANT: key-keypad-=-as-400 HEX: 0086
-CONSTANT: key-international-1 HEX: 0087
-CONSTANT: key-international-2 HEX: 0088
-CONSTANT: key-international-3 HEX: 0089
-CONSTANT: key-international-4 HEX: 008a
-CONSTANT: key-international-5 HEX: 008b
-CONSTANT: key-international-6 HEX: 008c
-CONSTANT: key-international-7 HEX: 008d
-CONSTANT: key-international-8 HEX: 008e
-CONSTANT: key-international-9 HEX: 008f
-CONSTANT: key-lang-1 HEX: 0090
-CONSTANT: key-lang-2 HEX: 0091
-CONSTANT: key-lang-3 HEX: 0092
-CONSTANT: key-lang-4 HEX: 0093
-CONSTANT: key-lang-5 HEX: 0094
-CONSTANT: key-lang-6 HEX: 0095
-CONSTANT: key-lang-7 HEX: 0096
-CONSTANT: key-lang-8 HEX: 0097
-CONSTANT: key-lang-9 HEX: 0098
-CONSTANT: key-alternate-erase HEX: 0099
-CONSTANT: key-sysreq HEX: 009a
-CONSTANT: key-cancel HEX: 009b
-CONSTANT: key-clear HEX: 009c
-CONSTANT: key-prior HEX: 009d
-CONSTANT: key-enter HEX: 009e
-CONSTANT: key-separator HEX: 009f
-CONSTANT: key-out HEX: 00a0
-CONSTANT: key-oper HEX: 00a1
-CONSTANT: key-clear-again HEX: 00a2
-CONSTANT: key-crsel-props HEX: 00a3
-CONSTANT: key-exsel HEX: 00a4
-CONSTANT: key-left-control HEX: 00e0
-CONSTANT: key-left-shift HEX: 00e1
-CONSTANT: key-left-alt HEX: 00e2
-CONSTANT: key-left-gui HEX: 00e3
-CONSTANT: key-right-control HEX: 00e4
-CONSTANT: key-right-shift HEX: 00e5
-CONSTANT: key-right-alt HEX: 00e6
-CONSTANT: key-right-gui HEX: 00e7
+++ /dev/null
-Scan code constants for HID keyboards
+++ /dev/null
-Cross-platform joystick, gamepad, and raw keyboard input
--- /dev/null
+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.dinput windows.dinput.constants
+windows.errors windows.kernel32 windows.messages
+windows.ole32 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 <void*> [ 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 <void*>
+ [ 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 ;
+
+: <buffer-size-diprop> ( size -- DIPROPDWORD )
+ 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>
+ 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 <byte-array> 256 <keys-array> 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 <array> mouse-state boa +mouse-state+ set-global
+ MOUSE-BUFFER-SIZE <DIDEVICEOBJECTDATA-array> +mouse-buffer+ set-global ;
+
+: device-info ( device -- DIDEVICEIMAGEINFOW )
+ DIDEVICEINSTANCEW <struct>
+ DIDEVICEINSTANCEW heap-size >>dwSize
+ [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ; inline
+: device-caps ( device -- DIDEVCAPS )
+ DIDEVCAPS <struct>
+ 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 <array> >>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 <vector> +controller-devices+ set-global
+ 4 <vector> +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
+
+: <DEV_BROADCAST_HDR> ( wParam -- struct )
+ <alien> DEV_BROADCAST_HDR memory>struct ;
+
+: handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
+ [ 2drop ] 2dip swap {
+ { [ dup DBT_DEVICEARRIVAL = ] [ drop <DEV_BROADCAST_HDR> device-arrived ] }
+ { [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <DEV_BROADCAST_HDR> 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 <struct>
+ DEV_BROADCAST_DEVICEW heap-size >>dbcc_size
+ DBT_DEVTYP_DEVICEINTERFACE >>dbcc_devicetype ;
+
+: create-device-change-window ( -- )
+ <zero-window-rect> 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 <keys-array> >>buttons ]
+ } 2cleave ;
+
+: read-device-buffer ( device buffer count -- buffer count' )
+ [ DIDEVICEOBJECTDATA heap-size ] 2dip <uint>
+ [ 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 )
+ [ +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 <struct> [ 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 ;
--- /dev/null
+USING: sequences sequences.private math
+accessors alien.data ;
+IN: game.input.dinput.keys-array
+
+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 length>> ;
+M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
+
+INSTANCE: keys-array sequence
+
--- /dev/null
+DirectInput backend for game.input
--- /dev/null
+unportable
+games
--- /dev/null
+USING: help.markup help.syntax kernel ui.gestures quotations
+sequences strings math ;
+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 for polling raw keyboard and mouse input." $nl
+"The game input interface must be initialized before being used:"
+{ $subsections
+ open-game-input
+ close-game-input
+ with-game-input
+}
+"Once the game input interface is open, connected controller devices can be enumerated:"
+{ $subsections
+ get-controllers
+ find-controller-products
+ find-controller-instance
+}
+"These " { $link controller } " objects can be queried of their identity:"
+{ $subsections
+ product-string
+ product-id
+ instance-id
+}
+"A hook is provided for invoking the system calibration tool:"
+{ $subsections calibrate-controller }
+"The current state of a controller, the keyboard, and the mouse can be read:"
+{ $subsections
+ read-controller
+ read-keyboard
+ read-mouse
+ controller-state
+ keyboard-state
+ mouse-state
+} ;
+
+HELP: open-game-input
+{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. Calls to open-game-input are reference counted; each call to open-game-input needs a corresponding call to close-game-input to close the game input interface." } ;
+
+HELP: close-game-input
+{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid." } ;
+
+HELP: game-input-opened?
+{ $values { "?" "a boolean" } }
+{ $description "Returns true if the game input interface is open, false otherwise." } ;
+
+HELP: with-game-input
+{ $values { "quot" quotation } }
+{ $description "Initializes the game input interface for the dynamic extent of " { $snippet "quotation" } "." } ;
+
+{ open-game-input close-game-input with-game-input game-input-opened? } related-words
+
+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. 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: product-string
+{ $values { "controller" controller } { "string" string } }
+{ $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 } { "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: 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." } ;
+
+{ 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, 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. If the device is no longer available, " { $link f } " is returned." }
+{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "controller-state" } " object next time " { $snippet "read-controller" } " is called on the same controller. You should " { $link clone } " any values from the returned tuple you need to preserve." } ;
+
+{ 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 "For efficiency, the implementation may reuse the returned " { $snippet "keyboard-state" } " object next time " { $snippet "read-keyboard" } " is called. You should " { $link clone } " any values from the returned tuple you need to preserve."
+$nl "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: read-mouse
+{ $values { "mouse-state" mouse-state } }
+{ $description "Reads the current mouse state relative to either when the game input interface was opened with " { $link open-game-input } " or when the mouse state was reset with " { $link reset-mouse } "." }
+{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "mouse-state" } " object for future " { $snippet "read-mouse" } " or " { $snippet "reset-mouse" } " calls. You should " { $link clone } " the " { $snippet "mouse-state" } " object if you need to preserve it." } ;
+
+HELP: reset-mouse
+{ $description "Resets the mouse state. Future " { $link read-mouse } " values will be relative to the time this word is called." } ;
+
+HELP: controller-state
+{ $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:"
+{ $list
+ { { $snippet "x" } " contains the position of the device's X axis." }
+ { { $snippet "y" } " contains the position of the device's Y axis." }
+ { { $snippet "z" } " contains the position of the device's Z axis, if any." }
+ { { $snippet "rx" } " contains the rotational position of the device's X axis, if available." }
+ { { $snippet "ry" } " contains the rotational position of the device's Y axis, if available." }
+ { { $snippet "rz" } " contains the rotational position of the device's Z axis, if available." }
+ { { $snippet "slider" } " contains the position of the device's throttle slider, if any." }
+ { { $snippet "pov" } " contains the state of the device's POV hat, if any." }
+ { { $snippet "buttons" } " contains a sequence of values indicating the state of every button on the device." }
+}
+"The values are formatted as follows:"
+{ $list
+ { "For the axis slots (" { $snippet "x" } ", " { $snippet "y" } ", " { $snippet "z" } ", " { $snippet "rx" } ", " { $snippet "ry" } ", " { $snippet "rz" } "), a " { $link float } " value between -1.0 and 1.0 is returned." }
+ { "For the " { $snippet "slider" } " slot, a value between 0.0 and 1.0 is returned." }
+ { "For the " { $snippet "pov" } " slot, one of the following symbols is returned:" { $list
+ { { $link pov-neutral } }
+ { { $link pov-up } }
+ { { $link pov-up-right } }
+ { { $link pov-right } }
+ { { $link pov-down-right } }
+ { { $link pov-down } }
+ { { $link pov-down-left } }
+ { { $link pov-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)." }
+ { "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, 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" } "." } ;
+
+HELP: mouse-state
+{ $class-description "The " { $link read-mouse } " word returns objects of this class. " { $snippet "mouse-state" } " objects have the following slots:"
+{ $list
+ { { $snippet "dx" } " contains the mouse's X axis movement." }
+ { { $snippet "dy" } " contains the mouse's Y axis movement." }
+ { { $snippet "scroll-dx" } " contains the scroller's X axis movement." }
+ { { $snippet "scroll-dy" } " contains the scroller's Y axis movement." }
+ { { $snippet "buttons" } " contains a sequence of boolean values indicate the state of the mouse's buttons." }
+}
+"Mouse movement is recorded relative to when the game input interface was opened with " { $link open-game-input } " or the mouse state is reset with " { $link reset-mouse } "."
+} ;
+
+
+{ keyboard-state read-keyboard } related-words
+
+ABOUT: "game-input"
--- /dev/null
+USING: ui game.input tools.test kernel system threads calendar
+combinators.short-circuit ;
+IN: game.input.tests
+
+os { [ windows? ] [ macosx? ] } 1|| [
+ [ ] [ open-game-input ] unit-test
+ [ ] [ 1 seconds sleep ] unit-test
+ [ ] [ close-game-input ] unit-test
+] when
--- /dev/null
+USING: arrays accessors continuations kernel math system
+sequences namespaces init vocabs vocabs.loader combinators ;
+IN: game.input
+
+SYMBOLS: game-input-backend game-input-opened ;
+
+game-input-opened [ 0 ] initialize
+
+HOOK: (open-game-input) game-input-backend ( -- )
+HOOK: (close-game-input) game-input-backend ( -- )
+HOOK: (reset-game-input) game-input-backend ( -- )
+
+HOOK: get-controllers game-input-backend ( -- sequence )
+
+HOOK: product-string game-input-backend ( controller -- string )
+HOOK: product-id game-input-backend ( controller -- id )
+HOOK: instance-id game-input-backend ( controller -- id )
+
+HOOK: read-controller game-input-backend ( controller -- controller-state )
+HOOK: calibrate-controller game-input-backend ( controller -- )
+
+HOOK: read-keyboard game-input-backend ( -- keyboard-state )
+
+HOOK: read-mouse game-input-backend ( -- mouse-state )
+
+HOOK: reset-mouse game-input-backend ( -- )
+
+: game-input-opened? ( -- ? )
+ game-input-opened get zero? not ;
+
+<PRIVATE
+
+M: f (reset-game-input) ;
+
+: reset-game-input ( -- )
+ (reset-game-input) ;
+
+[ reset-game-input ] "game-input" add-init-hook
+
+PRIVATE>
+
+ERROR: game-input-not-open ;
+
+: open-game-input ( -- )
+ game-input-opened? [
+ (open-game-input)
+ ] unless
+ game-input-opened [ 1 + ] change-global
+ reset-mouse ;
+: close-game-input ( -- )
+ game-input-opened [
+ dup zero? [ game-input-not-open ] when
+ 1 -
+ ] change-global
+ game-input-opened? [
+ (close-game-input)
+ reset-game-input
+ ] unless ;
+
+: with-game-input ( quot -- )
+ open-game-input [ close-game-input ] [ ] cleanup ; inline
+
+TUPLE: controller handle ;
+TUPLE: controller-state x y z rx ry rz slider pov buttons ;
+
+M: controller-state clone
+ call-next-method dup buttons>> clone >>buttons ;
+
+SYMBOLS:
+ pov-neutral
+ pov-up pov-up-right pov-right pov-down-right
+ pov-down pov-down-left pov-left pov-up-left ;
+
+: find-controller-products ( product-id -- sequence )
+ get-controllers [ product-id = ] with filter ;
+: find-controller-instance ( product-id instance-id -- controller/f )
+ get-controllers [
+ tuck
+ [ product-id = ]
+ [ instance-id = ] 2bi* and
+ ] with with find nip ;
+
+TUPLE: keyboard-state keys ;
+
+M: keyboard-state clone
+ call-next-method dup keys>> clone >>keys ;
+
+TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ;
+
+M: mouse-state clone
+ call-next-method dup buttons>> clone >>buttons ;
+
+{
+ { [ os windows? ] [ "game.input.dinput" require ] }
+ { [ os macosx? ] [ "game.input.iokit" require ] }
+ { [ t ] [ ] }
+} cond
--- /dev/null
+USING: cocoa cocoa.plists core-foundation iokit iokit.hid
+kernel cocoa.enumeration destructors math.parser cocoa.application
+sequences locals combinators.short-circuit threads
+namespaces assocs arrays combinators hints alien
+core-foundation.run-loop accessors sequences.private
+alien.c-types alien.data math parser game.input vectors
+bit-arrays ;
+IN: game.input.iokit
+
+SINGLETON: iokit-game-input-backend
+
+SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
+
+iokit-game-input-backend game-input-backend set-global
+
+: make-hid-manager ( -- alien )
+ f 0 IOHIDManagerCreate ;
+
+: set-hid-manager-matching ( alien matching-seq -- )
+ >plist IOHIDManagerSetDeviceMatchingMultiple ;
+
+: devices-from-hid-manager ( manager -- vector )
+ [
+ IOHIDManagerCopyDevices
+ [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
+ ] with-destructors ;
+
+CONSTANT: game-devices-matching-seq
+ {
+ H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses
+ H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
+ H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
+ H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
+ H{ { "DeviceUsage" 7 } { "DeviceUsagePage" 1 } } ! keypads
+ H{ { "DeviceUsage" 8 } { "DeviceUsagePage" 1 } } ! multiaxis controllers
+ }
+
+CONSTANT: buttons-matching-hash
+ H{ { "UsagePage" 9 } { "Type" 2 } }
+CONSTANT: keys-matching-hash
+ H{ { "UsagePage" 7 } { "Type" 2 } }
+CONSTANT: x-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 30 } { "Type" 1 } }
+CONSTANT: y-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 31 } { "Type" 1 } }
+CONSTANT: z-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 32 } { "Type" 1 } }
+CONSTANT: rx-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 33 } { "Type" 1 } }
+CONSTANT: ry-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 34 } { "Type" 1 } }
+CONSTANT: rz-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } }
+CONSTANT: slider-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } }
+CONSTANT: wheel-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 38 } { "Type" 1 } }
+CONSTANT: hat-switch-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } }
+
+: device-elements-matching ( device matching-hash -- vector )
+ [
+ >plist 0 IOHIDDeviceCopyMatchingElements
+ [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
+ ] with-destructors ;
+
+: button-count ( device -- button-count )
+ buttons-matching-hash device-elements-matching length ;
+
+: ?axis ( device hash -- axis/f )
+ device-elements-matching [ f ] [ first ] if-empty ;
+
+: ?x-axis ( device -- ? )
+ x-axis-matching-hash ?axis ;
+: ?y-axis ( device -- ? )
+ y-axis-matching-hash ?axis ;
+: ?z-axis ( device -- ? )
+ z-axis-matching-hash ?axis ;
+: ?rx-axis ( device -- ? )
+ rx-axis-matching-hash ?axis ;
+: ?ry-axis ( device -- ? )
+ ry-axis-matching-hash ?axis ;
+: ?rz-axis ( device -- ? )
+ rz-axis-matching-hash ?axis ;
+: ?slider ( device -- ? )
+ slider-matching-hash ?axis ;
+: ?hat-switch ( device -- ? )
+ hat-switch-matching-hash ?axis ;
+
+: device-property ( device key -- value )
+ <NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
+: element-property ( element key -- value )
+ <NSString> IOHIDElementGetProperty [ plist> ] [ f ] if* ;
+: set-element-property ( element key value -- )
+ [ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
+: transfer-element-property ( element from-key to-key -- )
+ [ dupd element-property ] dip swap
+ [ set-element-property ] [ 2drop ] if* ;
+
+: mouse-device? ( device -- ? )
+ 1 2 IOHIDDeviceConformsTo ;
+
+: controller-device? ( device -- ? )
+ {
+ [ 1 4 IOHIDDeviceConformsTo ]
+ [ 1 5 IOHIDDeviceConformsTo ]
+ [ 1 8 IOHIDDeviceConformsTo ]
+ } 1|| ;
+
+: element-usage ( element -- {usage-page,usage} )
+ [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
+ 2array ;
+
+: button? ( element -- ? )
+ IOHIDElementGetUsagePage 9 = ; inline
+: keyboard-key? ( element -- ? )
+ IOHIDElementGetUsagePage 7 = ; inline
+: axis? ( element -- ? )
+ IOHIDElementGetUsagePage 1 = ; inline
+
+: x-axis? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 30 = ; inline
+: y-axis? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 31 = ; inline
+: z-axis? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 32 = ; inline
+: rx-axis? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 33 = ; inline
+: ry-axis? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 34 = ; inline
+: rz-axis? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 35 = ; inline
+: slider? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 36 = ; inline
+: wheel? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 38 = ; inline
+: hat-switch? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 39 = ; inline
+
+CONSTANT: pov-values
+ {
+ pov-up pov-up-right pov-right pov-down-right
+ pov-down pov-down-left pov-left pov-up-left
+ pov-neutral
+ }
+
+: button-value ( value -- f/(0,1] )
+ IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
+: axis-value ( value -- [-1,1] )
+ kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
+: mouse-axis-value ( value -- n )
+ IOHIDValueGetIntegerValue ;
+: pov-value ( value -- pov-direction )
+ IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
+
+: record-button ( state hid-value element -- )
+ [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1 - ] tri* rot set-nth ;
+
+: record-controller ( controller-state value -- )
+ dup IOHIDValueGetElement {
+ { [ dup button? ] [ record-button ] }
+ { [ dup axis? ] [ {
+ { [ dup x-axis? ] [ drop axis-value >>x drop ] }
+ { [ dup y-axis? ] [ drop axis-value >>y drop ] }
+ { [ dup z-axis? ] [ drop axis-value >>z drop ] }
+ { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
+ { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
+ { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
+ { [ dup slider? ] [ drop axis-value >>slider drop ] }
+ { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
+ [ 3drop ]
+ } cond ] }
+ [ 3drop ]
+ } cond ;
+
+HINTS: record-controller { controller-state alien } ;
+
+: ?set-nth ( value nth seq -- )
+ 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
+
+: record-keyboard ( keyboard-state value -- )
+ dup IOHIDValueGetElement dup keyboard-key? [
+ [ IOHIDValueGetIntegerValue c-bool> ]
+ [ IOHIDElementGetUsage ] bi*
+ rot ?set-nth
+ ] [ 3drop ] if ;
+
+HINTS: record-keyboard { bit-array alien } ;
+
+: record-mouse ( mouse-state value -- )
+ dup IOHIDValueGetElement {
+ { [ dup button? ] [ record-button ] }
+ { [ dup axis? ] [ {
+ { [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] }
+ { [ dup y-axis? ] [ drop mouse-axis-value [ + ] curry change-dy drop ] }
+ { [ dup wheel? ] [ drop mouse-axis-value [ + ] curry change-scroll-dx drop ] }
+ { [ dup z-axis? ] [ drop mouse-axis-value [ + ] curry change-scroll-dy drop ] }
+ [ 3drop ]
+ } cond ] }
+ [ 3drop ]
+ } cond ;
+
+HINTS: record-mouse { mouse-state alien } ;
+
+M: iokit-game-input-backend read-mouse
+ +mouse-state+ get ;
+
+M: iokit-game-input-backend reset-mouse
+ +mouse-state+ get
+ 0 >>dx
+ 0 >>dy
+ 0 >>scroll-dx
+ 0 >>scroll-dy
+ drop ;
+
+: default-calibrate-saturation ( element -- )
+ [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
+ [ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ]
+ bi ;
+
+: default-calibrate-axis ( element -- )
+ [ kIOHIDElementCalibrationMinKey -1.0 set-element-property ]
+ [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
+ [ default-calibrate-saturation ]
+ tri ;
+
+: default-calibrate-slider ( element -- )
+ [ kIOHIDElementCalibrationMinKey 0.0 set-element-property ]
+ [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
+ [ default-calibrate-saturation ]
+ tri ;
+
+: (default) ( ? quot -- )
+ [ f ] if* ; inline
+
+: <device-controller-state> ( device -- controller-state )
+ {
+ [ ?x-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?y-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?z-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?rx-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?ry-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?rz-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?slider [ default-calibrate-slider 0.0 ] (default) ]
+ [ ?hat-switch pov-neutral and ]
+ [ button-count f <array> ]
+ } cleave controller-state boa ;
+
+: ?add-mouse-buttons ( device -- )
+ button-count +mouse-state+ get buttons>>
+ 2dup length >
+ [ set-length ] [ 2drop ] if ;
+
+: device-matched-callback ( -- alien )
+ [| context result sender device |
+ {
+ { [ device controller-device? ] [
+ device <device-controller-state>
+ device +controller-states+ get set-at
+ ] }
+ { [ device mouse-device? ] [ device ?add-mouse-buttons ] }
+ [ ]
+ } cond
+ ] IOHIDDeviceCallback ;
+
+: device-removed-callback ( -- alien )
+ [| context result sender device |
+ device +controller-states+ get delete-at
+ ] IOHIDDeviceCallback ;
+
+: device-input-callback ( -- alien )
+ [| context result sender value |
+ {
+ { [ sender controller-device? ] [
+ sender +controller-states+ get at value record-controller
+ ] }
+ { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] }
+ [ +keyboard-state+ get value record-keyboard ]
+ } cond
+ ] IOHIDValueCallback ;
+
+: initialize-variables ( manager -- )
+ +hid-manager+ set-global
+ 4 <vector> +controller-states+ set-global
+ 0 0 0 0 2 <vector> mouse-state boa
+ +mouse-state+ set-global
+ 256 <bit-array> +keyboard-state+ set-global ;
+
+M: iokit-game-input-backend (open-game-input)
+ make-hid-manager {
+ [ initialize-variables ]
+ [ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
+ [ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
+ [ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
+ [ 0 IOHIDManagerOpen mach-error ]
+ [ game-devices-matching-seq set-hid-manager-matching ]
+ [
+ CFRunLoopGetMain CFRunLoopDefaultMode
+ IOHIDManagerScheduleWithRunLoop
+ ]
+ } cleave ;
+
+M: iokit-game-input-backend (reset-game-input)
+ { +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ }
+ [ f swap set-global ] each ;
+
+M: iokit-game-input-backend (close-game-input)
+ +hid-manager+ get-global [
+ +hid-manager+ [
+ [
+ CFRunLoopGetMain CFRunLoopDefaultMode
+ IOHIDManagerUnscheduleFromRunLoop
+ ]
+ [ 0 IOHIDManagerClose drop ]
+ [ CFRelease ] tri
+ f
+ ] change-global
+ f +keyboard-state+ set-global
+ f +mouse-state+ set-global
+ f +controller-states+ set-global
+ ] when ;
+
+M: iokit-game-input-backend get-controllers ( -- sequence )
+ +controller-states+ get keys [ controller boa ] map ;
+
+: ?join ( pre post sep -- string )
+ 2over start [ swap 2nip ] [ [ 2array ] dip join ] if ;
+
+M: iokit-game-input-backend product-string ( controller -- string )
+ handle>>
+ [ kIOHIDManufacturerKey device-property ]
+ [ kIOHIDProductKey device-property ] bi " " ?join ;
+M: iokit-game-input-backend product-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 )
+ handle>> +controller-states+ get at clone ;
+
+M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
+ +keyboard-state+ get clone keyboard-state boa ;
+
+M: iokit-game-input-backend calibrate-controller ( controller -- )
+ drop ;
--- /dev/null
+IOKit HID Manager backend for game.input
--- /dev/null
+unportable
+games
--- /dev/null
+IN: game.input.scancodes
+
+CONSTANT: key-undefined HEX: 0000
+CONSTANT: key-error-roll-over HEX: 0001
+CONSTANT: key-error-post-fail HEX: 0002
+CONSTANT: key-error-undefined HEX: 0003
+CONSTANT: key-a HEX: 0004
+CONSTANT: key-b HEX: 0005
+CONSTANT: key-c HEX: 0006
+CONSTANT: key-d HEX: 0007
+CONSTANT: key-e HEX: 0008
+CONSTANT: key-f HEX: 0009
+CONSTANT: key-g HEX: 000a
+CONSTANT: key-h HEX: 000b
+CONSTANT: key-i HEX: 000c
+CONSTANT: key-j HEX: 000d
+CONSTANT: key-k HEX: 000e
+CONSTANT: key-l HEX: 000f
+CONSTANT: key-m HEX: 0010
+CONSTANT: key-n HEX: 0011
+CONSTANT: key-o HEX: 0012
+CONSTANT: key-p HEX: 0013
+CONSTANT: key-q HEX: 0014
+CONSTANT: key-r HEX: 0015
+CONSTANT: key-s HEX: 0016
+CONSTANT: key-t HEX: 0017
+CONSTANT: key-u HEX: 0018
+CONSTANT: key-v HEX: 0019
+CONSTANT: key-w HEX: 001a
+CONSTANT: key-x HEX: 001b
+CONSTANT: key-y HEX: 001c
+CONSTANT: key-z HEX: 001d
+CONSTANT: key-1 HEX: 001e
+CONSTANT: key-2 HEX: 001f
+CONSTANT: key-3 HEX: 0020
+CONSTANT: key-4 HEX: 0021
+CONSTANT: key-5 HEX: 0022
+CONSTANT: key-6 HEX: 0023
+CONSTANT: key-7 HEX: 0024
+CONSTANT: key-8 HEX: 0025
+CONSTANT: key-9 HEX: 0026
+CONSTANT: key-0 HEX: 0027
+CONSTANT: key-return HEX: 0028
+CONSTANT: key-escape HEX: 0029
+CONSTANT: key-backspace HEX: 002a
+CONSTANT: key-tab HEX: 002b
+CONSTANT: key-space HEX: 002c
+CONSTANT: key-- HEX: 002d
+CONSTANT: key-= HEX: 002e
+CONSTANT: key-[ HEX: 002f
+CONSTANT: key-] HEX: 0030
+CONSTANT: key-\ HEX: 0031
+CONSTANT: key-#-non-us HEX: 0032
+CONSTANT: key-; HEX: 0033
+CONSTANT: key-' HEX: 0034
+CONSTANT: key-` HEX: 0035
+CONSTANT: key-, HEX: 0036
+CONSTANT: key-. HEX: 0037
+CONSTANT: key-/ HEX: 0038
+CONSTANT: key-caps-lock HEX: 0039
+CONSTANT: key-f1 HEX: 003a
+CONSTANT: key-f2 HEX: 003b
+CONSTANT: key-f3 HEX: 003c
+CONSTANT: key-f4 HEX: 003d
+CONSTANT: key-f5 HEX: 003e
+CONSTANT: key-f6 HEX: 003f
+CONSTANT: key-f7 HEX: 0040
+CONSTANT: key-f8 HEX: 0041
+CONSTANT: key-f9 HEX: 0042
+CONSTANT: key-f10 HEX: 0043
+CONSTANT: key-f11 HEX: 0044
+CONSTANT: key-f12 HEX: 0045
+CONSTANT: key-print-screen HEX: 0046
+CONSTANT: key-scroll-lock HEX: 0047
+CONSTANT: key-pause HEX: 0048
+CONSTANT: key-insert HEX: 0049
+CONSTANT: key-home HEX: 004a
+CONSTANT: key-page-up HEX: 004b
+CONSTANT: key-delete HEX: 004c
+CONSTANT: key-end HEX: 004d
+CONSTANT: key-page-down HEX: 004e
+CONSTANT: key-right-arrow HEX: 004f
+CONSTANT: key-left-arrow HEX: 0050
+CONSTANT: key-down-arrow HEX: 0051
+CONSTANT: key-up-arrow HEX: 0052
+CONSTANT: key-keypad-numlock HEX: 0053
+CONSTANT: key-keypad-/ HEX: 0054
+CONSTANT: key-keypad-* HEX: 0055
+CONSTANT: key-keypad-- HEX: 0056
+CONSTANT: key-keypad-+ HEX: 0057
+CONSTANT: key-keypad-enter HEX: 0058
+CONSTANT: key-keypad-1 HEX: 0059
+CONSTANT: key-keypad-2 HEX: 005a
+CONSTANT: key-keypad-3 HEX: 005b
+CONSTANT: key-keypad-4 HEX: 005c
+CONSTANT: key-keypad-5 HEX: 005d
+CONSTANT: key-keypad-6 HEX: 005e
+CONSTANT: key-keypad-7 HEX: 005f
+CONSTANT: key-keypad-8 HEX: 0060
+CONSTANT: key-keypad-9 HEX: 0061
+CONSTANT: key-keypad-0 HEX: 0062
+CONSTANT: key-keypad-. HEX: 0063
+CONSTANT: key-\-non-us HEX: 0064
+CONSTANT: key-application HEX: 0065
+CONSTANT: key-power HEX: 0066
+CONSTANT: key-keypad-= HEX: 0067
+CONSTANT: key-f13 HEX: 0068
+CONSTANT: key-f14 HEX: 0069
+CONSTANT: key-f15 HEX: 006a
+CONSTANT: key-f16 HEX: 006b
+CONSTANT: key-f17 HEX: 006c
+CONSTANT: key-f18 HEX: 006d
+CONSTANT: key-f19 HEX: 006e
+CONSTANT: key-f20 HEX: 006f
+CONSTANT: key-f21 HEX: 0070
+CONSTANT: key-f22 HEX: 0071
+CONSTANT: key-f23 HEX: 0072
+CONSTANT: key-f24 HEX: 0073
+CONSTANT: key-execute HEX: 0074
+CONSTANT: key-help HEX: 0075
+CONSTANT: key-menu HEX: 0076
+CONSTANT: key-select HEX: 0077
+CONSTANT: key-stop HEX: 0078
+CONSTANT: key-again HEX: 0079
+CONSTANT: key-undo HEX: 007a
+CONSTANT: key-cut HEX: 007b
+CONSTANT: key-copy HEX: 007c
+CONSTANT: key-paste HEX: 007d
+CONSTANT: key-find HEX: 007e
+CONSTANT: key-mute HEX: 007f
+CONSTANT: key-volume-up HEX: 0080
+CONSTANT: key-volume-down HEX: 0081
+CONSTANT: key-locking-caps-lock HEX: 0082
+CONSTANT: key-locking-num-lock HEX: 0083
+CONSTANT: key-locking-scroll-lock HEX: 0084
+CONSTANT: key-keypad-, HEX: 0085
+CONSTANT: key-keypad-=-as-400 HEX: 0086
+CONSTANT: key-international-1 HEX: 0087
+CONSTANT: key-international-2 HEX: 0088
+CONSTANT: key-international-3 HEX: 0089
+CONSTANT: key-international-4 HEX: 008a
+CONSTANT: key-international-5 HEX: 008b
+CONSTANT: key-international-6 HEX: 008c
+CONSTANT: key-international-7 HEX: 008d
+CONSTANT: key-international-8 HEX: 008e
+CONSTANT: key-international-9 HEX: 008f
+CONSTANT: key-lang-1 HEX: 0090
+CONSTANT: key-lang-2 HEX: 0091
+CONSTANT: key-lang-3 HEX: 0092
+CONSTANT: key-lang-4 HEX: 0093
+CONSTANT: key-lang-5 HEX: 0094
+CONSTANT: key-lang-6 HEX: 0095
+CONSTANT: key-lang-7 HEX: 0096
+CONSTANT: key-lang-8 HEX: 0097
+CONSTANT: key-lang-9 HEX: 0098
+CONSTANT: key-alternate-erase HEX: 0099
+CONSTANT: key-sysreq HEX: 009a
+CONSTANT: key-cancel HEX: 009b
+CONSTANT: key-clear HEX: 009c
+CONSTANT: key-prior HEX: 009d
+CONSTANT: key-enter HEX: 009e
+CONSTANT: key-separator HEX: 009f
+CONSTANT: key-out HEX: 00a0
+CONSTANT: key-oper HEX: 00a1
+CONSTANT: key-clear-again HEX: 00a2
+CONSTANT: key-crsel-props HEX: 00a3
+CONSTANT: key-exsel HEX: 00a4
+CONSTANT: key-left-control HEX: 00e0
+CONSTANT: key-left-shift HEX: 00e1
+CONSTANT: key-left-alt HEX: 00e2
+CONSTANT: key-left-gui HEX: 00e3
+CONSTANT: key-right-control HEX: 00e4
+CONSTANT: key-right-shift HEX: 00e5
+CONSTANT: key-right-alt HEX: 00e6
+CONSTANT: key-right-gui HEX: 00e7
--- /dev/null
+Scan code constants for HID keyboards
--- /dev/null
+Cross-platform joystick, gamepad, and raw keyboard input
+++ /dev/null
-USING: accessors calendar continuations destructors kernel math
-math.order namespaces system threads ui ui.gadgets.worlds
-sequences ;
-IN: game-loop
-
-TUPLE: game-loop
- { tick-length integer read-only }
- delegate
- { last-tick integer }
- thread
- { running? boolean }
- { tick-number integer }
- { frame-number integer }
- { benchmark-time integer }
- { benchmark-tick-number integer }
- { benchmark-frame-number integer } ;
-
-GENERIC: tick* ( delegate -- )
-GENERIC: draw* ( tick-slice delegate -- )
-
-SYMBOL: game-loop
-
-: since-last-tick ( loop -- milliseconds )
- last-tick>> millis swap - ;
-
-: tick-slice ( loop -- slice )
- [ since-last-tick ] [ tick-length>> ] bi /f 1.0 min ;
-
-CONSTANT: MAX-FRAMES-TO-SKIP 5
-
-DEFER: stop-loop
-
-TUPLE: game-loop-error game-loop error ;
-
-: ?ui-error ( error -- )
- ui-running? [ ui-error ] [ rethrow ] if ;
-
-: game-loop-error ( game-loop error -- )
- [ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ;
-
-<PRIVATE
-
-: redraw ( loop -- )
- [ 1 + ] change-frame-number
- [ tick-slice ] [ delegate>> ] bi draw* ;
-
-: tick ( loop -- )
- delegate>> tick* ;
-
-: increment-tick ( loop -- )
- [ 1 + ] change-tick-number
- dup tick-length>> [ + ] curry change-last-tick
- drop ;
-
-: ?tick ( loop count -- )
- [ millis >>last-tick drop ] [
- over [ since-last-tick ] [ tick-length>> ] bi >=
- [ [ drop increment-tick ] [ drop tick ] [ 1 - ?tick ] 2tri ]
- [ 2drop ] if
- ] if-zero ;
-
-: (run-loop) ( loop -- )
- dup running?>>
- [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ 1 milliseconds sleep (run-loop) ] tri ]
- [ drop ] if ;
-
-: run-loop ( loop -- )
- dup game-loop
- [ [ (run-loop) ] [ game-loop-error ] recover ]
- with-variable ;
-
-: benchmark-millis ( loop -- millis )
- millis swap benchmark-time>> - ;
-
-PRIVATE>
-
-: reset-loop-benchmark ( loop -- )
- millis >>benchmark-time
- dup tick-number>> >>benchmark-tick-number
- dup frame-number>> >>benchmark-frame-number
- drop ;
-
-: benchmark-ticks-per-second ( loop -- n )
- [ tick-number>> ] [ benchmark-tick-number>> - ] [ benchmark-millis ] tri /f ;
-: benchmark-frames-per-second ( loop -- n )
- [ frame-number>> ] [ benchmark-frame-number>> - ] [ benchmark-millis ] tri /f ;
-
-: start-loop ( loop -- )
- millis >>last-tick
- t >>running?
- [ reset-loop-benchmark ]
- [ [ run-loop ] curry "game loop" spawn ]
- [ (>>thread) ] tri ;
-
-: stop-loop ( loop -- )
- f >>running?
- f >>thread
- drop ;
-
-: <game-loop> ( tick-length delegate -- loop )
- millis f f 0 0 millis 0 0
- game-loop boa ;
-
-M: game-loop dispose
- stop-loop ;
-
-USING: vocabs vocabs.loader ;
-
-"prettyprint" vocab [ "game-loop.prettyprint" require ] when
+++ /dev/null
-! (c)2009 Joe Groff bsd license
-USING: accessors debugger game-loop io ;
-IN: game-loop.prettyprint
-
-M: game-loop-error error.
- "An error occurred inside a game loop." print
- "The game loop has been stopped to prevent runaway errors." print
- "The error was:" print nl
- error>> error. ;
+++ /dev/null
-USING: accessors game-input game-loop kernel math ui.gadgets
-ui.gadgets.worlds ui.gestures threads ;
-IN: game-worlds
-
-TUPLE: game-world < world
- game-loop
- { tick-slice float initial: 0.0 } ;
-
-GENERIC: tick-length ( world -- millis )
-
-M: game-world draw*
- swap >>tick-slice relayout-1 yield ;
-
-M: game-world begin-world
- open-game-input
- dup [ tick-length ] [ ] bi <game-loop> [ >>game-loop ] keep start-loop
- drop ;
-
-M: game-world end-world
- [ [ stop-loop ] when* f ] change-game-loop
- close-game-input
- drop ;
-
--- /dev/null
+USING: accessors calendar continuations destructors kernel math
+math.order namespaces system threads ui ui.gadgets.worlds
+sequences ;
+IN: game.loop
+
+TUPLE: game-loop
+ { tick-length integer read-only }
+ delegate
+ { last-tick integer }
+ thread
+ { running? boolean }
+ { tick-number integer }
+ { frame-number integer }
+ { benchmark-time integer }
+ { benchmark-tick-number integer }
+ { benchmark-frame-number integer } ;
+
+GENERIC: tick* ( delegate -- )
+GENERIC: draw* ( tick-slice delegate -- )
+
+SYMBOL: game-loop
+
+: since-last-tick ( loop -- milliseconds )
+ last-tick>> millis swap - ;
+
+: tick-slice ( loop -- slice )
+ [ since-last-tick ] [ tick-length>> ] bi /f 1.0 min ;
+
+CONSTANT: MAX-FRAMES-TO-SKIP 5
+
+DEFER: stop-loop
+
+TUPLE: game-loop-error game-loop error ;
+
+: ?ui-error ( error -- )
+ ui-running? [ ui-error ] [ rethrow ] if ;
+
+: game-loop-error ( game-loop error -- )
+ [ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ;
+
+<PRIVATE
+
+: redraw ( loop -- )
+ [ 1 + ] change-frame-number
+ [ tick-slice ] [ delegate>> ] bi draw* ;
+
+: tick ( loop -- )
+ delegate>> tick* ;
+
+: increment-tick ( loop -- )
+ [ 1 + ] change-tick-number
+ dup tick-length>> [ + ] curry change-last-tick
+ drop ;
+
+: ?tick ( loop count -- )
+ [ millis >>last-tick drop ] [
+ over [ since-last-tick ] [ tick-length>> ] bi >=
+ [ [ drop increment-tick ] [ drop tick ] [ 1 - ?tick ] 2tri ]
+ [ 2drop ] if
+ ] if-zero ;
+
+: (run-loop) ( loop -- )
+ dup running?>>
+ [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ 1 milliseconds sleep (run-loop) ] tri ]
+ [ drop ] if ;
+
+: run-loop ( loop -- )
+ dup game-loop
+ [ [ (run-loop) ] [ game-loop-error ] recover ]
+ with-variable ;
+
+: benchmark-millis ( loop -- millis )
+ millis swap benchmark-time>> - ;
+
+PRIVATE>
+
+: reset-loop-benchmark ( loop -- )
+ millis >>benchmark-time
+ dup tick-number>> >>benchmark-tick-number
+ dup frame-number>> >>benchmark-frame-number
+ drop ;
+
+: benchmark-ticks-per-second ( loop -- n )
+ [ tick-number>> ] [ benchmark-tick-number>> - ] [ benchmark-millis ] tri /f ;
+: benchmark-frames-per-second ( loop -- n )
+ [ frame-number>> ] [ benchmark-frame-number>> - ] [ benchmark-millis ] tri /f ;
+
+: start-loop ( loop -- )
+ millis >>last-tick
+ t >>running?
+ [ reset-loop-benchmark ]
+ [ [ run-loop ] curry "game loop" spawn ]
+ [ (>>thread) ] tri ;
+
+: stop-loop ( loop -- )
+ f >>running?
+ f >>thread
+ drop ;
+
+: <game-loop> ( tick-length delegate -- loop )
+ millis f f 0 0 millis 0 0
+ game-loop boa ;
+
+M: game-loop dispose
+ stop-loop ;
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "game.loop.prettyprint" require ] when
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors debugger game.loop io ;
+IN: game.loop.prettyprint
+
+M: game-loop-error error.
+ "An error occurred inside a game loop." print
+ "The game loop has been stopped to prevent runaway errors." print
+ "The error was:" print nl
+ error>> error. ;
--- /dev/null
+USING: accessors game.input game.loop kernel math ui.gadgets
+ui.gadgets.worlds ui.gestures threads ;
+IN: game.worlds
+
+TUPLE: game-world < world
+ game-loop
+ { tick-slice float initial: 0.0 } ;
+
+GENERIC: tick-length ( world -- millis )
+
+M: game-world draw*
+ swap >>tick-slice relayout-1 yield ;
+
+M: game-world begin-world
+ open-game-input
+ dup [ tick-length ] [ ] bi <game-loop> [ >>game-loop ] keep start-loop
+ drop ;
+
+M: game-world end-world
+ [ [ stop-loop ] when* f ] change-game-loop
+ close-game-input
+ drop ;
+
! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types arrays classes.struct combinators
-combinators.short-circuit game-worlds gpu gpu.buffers
+combinators.short-circuit game.worlds gpu gpu.buffers
gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state
gpu.textures gpu.util grouping http.client images images.loader
io io.encodings.ascii io.files io.files.temp kernel math
! (c)2009 Joe Groff bsd license
-USING: accessors arrays combinators.tuple game-loop game-worlds
+USING: accessors arrays combinators.tuple game.loop game.worlds
generalizations gpu gpu.render gpu.shaders gpu.util gpu.util.wasd
kernel literals math math.matrices math.order math.vectors
method-chains sequences ui ui.gadgets ui.gadgets.worlds
! (c)2009 Joe Groff bsd license
USING: accessors arrays combinators.smart game-input
-game-input.scancodes game-loop game-worlds
+game.input.scancodes game.loop game.worlds
gpu.render gpu.state kernel literals
locals math math.constants math.functions math.matrices
math.order math.vectors opengl.gl sequences
USING: ui ui.gadgets sequences kernel arrays math colors
colors.constants ui.render ui.pens.polygon ui.pens.solid math.vectors
-accessors fry ui.gadgets.packs game-input ui.gadgets.labels
+accessors fry ui.gadgets.packs game.input ui.gadgets.labels
ui.gadgets.borders alarms calendar locals strings ui.gadgets.buttons
combinators math.parser assocs threads ;
IN: joystick-demo
-USING: game-input game-input.scancodes
+USING: game.input game.input.scancodes
kernel ui.gadgets ui.gadgets.buttons sequences accessors
words arrays assocs math calendar fry alarms ui
ui.gadgets.borders ui.gestures ;
! (c)2009 Joe Groff, Doug Coleman. bsd license
-USING: accessors arrays combinators game-input game-loop
-game-input.scancodes grouping kernel literals locals
+USING: accessors arrays combinators game.input game.loop
+game.input.scancodes grouping kernel literals locals
math math.constants math.functions math.matrices math.order
math.vectors opengl opengl.capabilities opengl.gl
opengl.shaders opengl.textures opengl.textures.private
sequences sequences.product specialized-arrays
terrain.generation terrain.shaders ui ui.gadgets
-ui.gadgets.worlds ui.pixel-formats game-worlds method-chains
+ui.gadgets.worlds ui.pixel-formats game.worlds method-chains
math.affine-transforms noise ui.gestures combinators.short-circuit
destructors grid-meshes ;
FROM: alien.c-types => float ;
projects / factor.git / commitdiff