2135623355842621559
[ >bignum ] tri@ ^mod
] unit-test
+
+[ 1.0 ] [ 1.0 2.5 0.0 lerp ] unit-test
+[ 2.5 ] [ 1.0 2.5 1.0 lerp ] unit-test
+[ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test
+
[ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable
: ceiling ( x -- y ) neg floor neg ; foldable
+
+: lerp ( a b t -- a_t ) [ over - ] dip * + ; inline
+
[ 5 ] [ { 1 2 } norm-sq ] unit-test
[ 13 ] [ { 2 3 } norm-sq ] unit-test
+[ { 1.0 2.5 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.0 vnlerp ] unit-test
+[ { 2.5 1.0 } ] [ { 1.0 2.5 } { 2.5 1.0 } 1.0 vnlerp ] unit-test
+[ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test
+
+[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test
: set-axis ( u v axis -- w )
[ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
+: vlerp ( a b t -- a_t )
+ [ lerp ] 3map ;
+
+: vnlerp ( a b t -- a_t )
+ [ lerp ] curry 2map ;
+
HINTS: vneg { array } ;
HINTS: norm-sq { array } ;
HINTS: norm { array } ;
HINTS: vmax { array array } ;
HINTS: vmin { array array } ;
HINTS: v. { array array } ;
+
+HINTS: vlerp { array array array } ;
+HINTS: vnlerp { array array object } ;
CONSTANT: DISCL_BACKGROUND HEX: 00000008
CONSTANT: DISCL_NOWINKEY HEX: 00000010
+CONSTANT: DIMOFS_X 0
+CONSTANT: DIMOFS_Y 4
+CONSTANT: DIMOFS_Z 8
+CONSTANT: DIMOFS_BUTTON0 12
+CONSTANT: DIMOFS_BUTTON1 13
+CONSTANT: DIMOFS_BUTTON2 14
+CONSTANT: DIMOFS_BUTTON3 15
+CONSTANT: DIMOFS_BUTTON4 16
+CONSTANT: DIMOFS_BUTTON5 17
+CONSTANT: DIMOFS_BUTTON6 18
+CONSTANT: DIMOFS_BUTTON7 19
+
CONSTANT: DIK_ESCAPE HEX: 01
CONSTANT: DIK_1 HEX: 02
CONSTANT: DIK_2 HEX: 03
ui.backend.windows windows.errors ;
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+ ;
+ +device-change-window+ +device-change-handle+
+ +mouse-device+ +mouse-state+ +mouse-buffer+ ;
: create-dinput ( -- )
f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
: set-data-format ( device format-symbol -- )
get IDirectInputDevice8W::SetDataFormat ole32-error ;
+: <buffer-size-diprop> ( size -- DIPROPDWORD )
+ "DIPROPDWORD" <c-object>
+ "DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize
+ "DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize
+ 0 over set-DIPROPHEADER-dwObj
+ DIPH_DEVICE over set-DIPROPHEADER-dwHow
+ swap over set-DIPROPDWORD-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 ;
256 <byte-array> <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 <vector> mouse-state boa
+ +mouse-device+ set-global ;
+ MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" <c-array>
+ +mouse-buffer+ set-global ;
+
: device-info ( device -- DIDEVICEIMAGEINFOW )
"DIDEVICEINSTANCEW" <c-object>
"DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
+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 ;
[ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>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 -- )
+ [ DIDEVICEOBJECTDATA-dwData ] [ DIDEVICEOBJECTDATA-dwOfs ] bi {
+ { DIMOFS_X [ [ + ] curry change-dx drop ] }
+ { DIMOFS_Y [ [ + ] curry change-dy drop ] }
+ { DIMOFS_Z [ [ + ] curry change-scroll-dy drop ] }
+ [ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot buttons>> set-nth ]
+ } case ;
+
+: fill-mouse-state ( buffer count -- )
+ [ +mouse-state+ get ] 2dip swap
+ [ DIDEVICEOBJECTDATA-nth (fill-mouse-state) ] curry each ;
+
: get-device-state ( device byte-array -- )
[ dup IDirectInputDevice8W::Poll ole32-error ] dip
[ length ] keep
+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 ;
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 input." $nl
+"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl
"The game input interface must be initialized before being used:"
{ $subsection open-game-input }
{ $subsection close-game-input }
{ $subsection instance-id }
"A hook is provided for invoking the system calibration tool:"
{ $subsection calibrate-controller }
-"The current state of a controller or the keyboard can be read:"
+"The current state of a controller, the keyboard, and the mouse can be read:"
{ $subsection read-controller }
{ $subsection read-keyboard }
+{ $subsection read-mouse }
{ $subsection controller-state }
-{ $subsection keyboard-state } ;
+{ $subsection keyboard-state }
+{ $subsection mouse-state } ;
HELP: open-game-input
{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ;
{ $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
{ $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"
HOOK: read-keyboard game-input-backend ( -- keyboard-state )
+TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ;
+
+M: mouse-state clone
+ call-next-method dup buttons>> clone >>buttons ;
+
+HOOK: read-mouse game-input-backend ( -- mouse-state )
+
+HOOK: reset-mouse game-input-backend ( -- )
+
{
{ [ os windows? ] [ "game-input.dinput" require ] }
{ [ os macosx? ] [ "game-input.iokit" require ] }
sequences locals combinators.short-circuit threads
namespaces assocs vectors arrays combinators
core-foundation.run-loop accessors sequences.private
-alien.c-types math parser game-input ;
+alien.c-types math parser game-input vectors ;
IN: game-input.iokit
SINGLETON: iokit-game-input-backend
CONSTANT: game-devices-matching-seq
{
+ H{ { "DeviceUsage" 1 } { "DeviceUsagePage" 1 } } ! pointers
+ 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" 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 } }
: transfer-element-property ( element from-key to-key -- )
[ dupd element-property ] dip swap set-element-property ;
+: mouse-device? ( device -- ? )
+ {
+ [ 1 1 IOHIDDeviceConformsTo ]
+ [ 1 2 IOHIDDeviceConformsTo ]
+ } 1|| ;
+
: controller-device? ( device -- ? )
{
[ 1 4 IOHIDDeviceConformsTo ]
[ 1 5 IOHIDDeviceConformsTo ]
+ [ 1 8 IOHIDDeviceConformsTo ]
} 1|| ;
: element-usage ( element -- {usage-page,usage} )
{ 1 HEX: 35 } = ; inline
: slider? ( {usage-page,usage} -- ? )
{ 1 HEX: 36 } = ; inline
+: wheel? ( {usage-page,usage} -- ? )
+ { 1 HEX: 38 } = ; inline
: hat-switch? ( {usage-page,usage} -- ? )
{ 1 HEX: 39 } = ; inline
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 ( hid-value usage state -- )
+ [ button-value ] [ second 1- ] [ buttons>> ] tri* set-nth ;
+
: record-controller ( controller-state value -- )
dup IOHIDValueGetElement element-usage {
- { [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] }
+ { [ dup button? ] [ rot record-button ] }
{ [ dup x-axis? ] [ drop axis-value >>x drop ] }
{ [ dup y-axis? ] [ drop axis-value >>y drop ] }
{ [ dup z-axis? ] [ drop axis-value >>z drop ] }
[ 3drop ]
} cond ;
-SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
+SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
: ?set-nth ( value nth seq -- )
2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
+keyboard-state+ get ?set-nth
] [ drop ] if ;
+: record-mouse ( value -- )
+ dup IOHIDValueGetElement element-usage {
+ { [ dup button? ] [ +mouse-state+ get record-button ] }
+ { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] }
+ { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] }
+ { [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] }
+ { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] }
+ [ 2drop ]
+ } cond ;
+
+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 ]
[ 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
- ] when
+ {
+ { [ 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 )
: device-input-callback ( -- alien )
[| context result sender value |
- sender controller-device?
- [ sender +controller-states+ get at value record-controller ]
- [ value record-keyboard ]
- if
+ {
+ { [ sender controller-device? ] [
+ sender +controller-states+ get at value record-controller
+ ] }
+ { [ sender mouse-device? ] [ value record-mouse ] }
+ [ 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 f <array> +keyboard-state+ set-global ;
M: iokit-game-input-backend (open-game-input)
projects / factor.git / commitdiff