Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
ffbd19faba
|
|
@ -157,3 +157,8 @@ IN: math.functions.tests
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -262,3 +262,6 @@ M: real atan fatan ;
|
|||
[ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable
|
||||
|
||||
: ceiling ( x -- y ) neg floor neg ; foldable
|
||||
|
||||
: lerp ( a b t -- a_t ) [ over - ] dip * + ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -9,3 +9,8 @@ USING: math.vectors tools.test ;
|
|||
[ 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
|
||||
|
|
|
|||
|
|
@ -6,6 +6,11 @@ IN: math.vectors
|
|||
|
||||
: vneg ( u -- v ) [ neg ] map ;
|
||||
|
||||
: v+n ( u n -- v ) [ + ] curry map ;
|
||||
: n+v ( n u -- v ) [ + ] with map ;
|
||||
: v-n ( u n -- v ) [ - ] curry map ;
|
||||
: n-v ( n u -- v ) [ - ] with map ;
|
||||
|
||||
: v*n ( u n -- v ) [ * ] curry map ;
|
||||
: n*v ( n u -- v ) [ * ] with map ;
|
||||
: v/n ( u n -- v ) [ / ] curry map ;
|
||||
|
|
@ -19,6 +24,10 @@ IN: math.vectors
|
|||
: vmax ( u v -- w ) [ max ] 2map ;
|
||||
: vmin ( u v -- w ) [ min ] 2map ;
|
||||
|
||||
: vfloor ( v -- _v_ ) [ floor ] map ;
|
||||
: vceiling ( v -- ^v^ ) [ ceiling ] map ;
|
||||
: vtruncate ( v -- -v- ) [ truncate ] map ;
|
||||
|
||||
: vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ;
|
||||
: vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ;
|
||||
|
||||
|
|
@ -32,6 +41,12 @@ IN: math.vectors
|
|||
: 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 } ;
|
||||
|
|
@ -50,3 +65,6 @@ HINTS: v/ { array array } ;
|
|||
HINTS: vmax { array array } ;
|
||||
HINTS: vmin { array array } ;
|
||||
HINTS: v. { array array } ;
|
||||
|
||||
HINTS: vlerp { array array array } ;
|
||||
HINTS: vnlerp { array array object } ;
|
||||
|
|
|
|||
|
|
@ -444,6 +444,18 @@ CONSTANT: DISCL_FOREGROUND HEX: 00000004
|
|||
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
|
||||
|
|
|
|||
|
|
@ -5,16 +5,20 @@ windows.user32 windows.messages sequences combinators locals
|
|||
math.rectangles accessors math alien alien.strings
|
||||
io.encodings.utf16 io.encodings.utf16n continuations
|
||||
byte-arrays game-input.dinput.keys-array game-input
|
||||
ui.backend.windows windows.errors ;
|
||||
ui.backend.windows windows.errors struct-arrays
|
||||
math.bitwise ;
|
||||
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
|
||||
|
|
@ -35,8 +39,24 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
: 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 ;
|
||||
|
||||
|
|
@ -47,6 +67,15 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
|||
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 f <array> mouse-state boa
|
||||
+mouse-state+ 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
|
||||
|
|
@ -190,16 +219,22 @@ TUPLE: window-rect < rect window-loc ;
|
|||
+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 ;
|
||||
|
|
@ -263,6 +298,22 @@ CONSTANT: pov-values
|
|||
[ 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 -- state )
|
||||
[ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-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
|
||||
[ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ;
|
||||
|
||||
: get-device-state ( device byte-array -- )
|
||||
[ dup IDirectInputDevice8W::Poll ole32-error ] dip
|
||||
[ length ] keep
|
||||
|
|
@ -283,3 +334,17 @@ 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 ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ 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 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 }
|
||||
|
|
@ -18,11 +18,13 @@ ARTICLE: "game-input" "Game controller 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." } ;
|
||||
|
|
@ -86,6 +88,14 @@ HELP: read-keyboard
|
|||
{ $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
|
||||
|
|
@ -121,6 +131,19 @@ 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"
|
||||
|
|
|
|||
|
|
@ -73,6 +73,15 @@ M: keyboard-state clone
|
|||
|
||||
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 ] }
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ kernel cocoa.enumeration destructors math.parser cocoa.application
|
|||
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
|
||||
|
|
@ -23,9 +23,13 @@ iokit-game-input-backend game-input-backend set-global
|
|||
|
||||
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
|
||||
|
|
@ -46,6 +50,8 @@ 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 } }
|
||||
|
||||
|
|
@ -90,10 +96,17 @@ CONSTANT: hat-switch-matching-hash
|
|||
: 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} )
|
||||
|
|
@ -118,6 +131,8 @@ CONSTANT: hat-switch-matching-hash
|
|||
{ 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
|
||||
|
||||
|
|
@ -132,12 +147,17 @@ CONSTANT: pov-values
|
|||
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 ] }
|
||||
|
|
@ -149,7 +169,7 @@ CONSTANT: pov-values
|
|||
[ 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 ;
|
||||
|
|
@ -161,6 +181,27 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
|
|||
+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 ]
|
||||
|
|
@ -194,12 +235,21 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
|
|||
[ 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 )
|
||||
|
|
@ -209,15 +259,20 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
|
|||
|
||||
: 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)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,83 @@
|
|||
USING: byte-arrays combinators images kernel locals math
|
||||
math.functions math.polynomials math.vectors random sequences
|
||||
sequences.product ;
|
||||
IN: perlin-noise
|
||||
|
||||
: <noise-table> ( -- table )
|
||||
256 iota >byte-array randomize dup append ;
|
||||
|
||||
: fade ( point -- point' )
|
||||
{ 0.0 0.0 0.0 10.0 -15.0 6.0 } swap [ polyval ] with map ;
|
||||
|
||||
:: grad ( hash gradients -- gradient )
|
||||
hash 8 bitand zero? [ gradients first ] [ gradients second ] if
|
||||
:> u
|
||||
hash 12 bitand zero?
|
||||
[ gradients second ]
|
||||
[ hash 13 bitand 12 = [ gradients first ] [ gradients third ] if ] if
|
||||
:> v
|
||||
|
||||
hash 1 bitand zero? [ u ] [ u neg ] if
|
||||
hash 2 bitand zero? [ v ] [ v neg ] if + ;
|
||||
|
||||
: unit-cube ( point -- cube )
|
||||
[ floor >fixnum 256 mod ] map ;
|
||||
|
||||
:: hashes ( table cube -- aaa baa aba bba aab bab abb bbb )
|
||||
cube first :> x
|
||||
cube second :> y
|
||||
cube third :> z
|
||||
x table nth y + :> a
|
||||
x 1 + table nth y + :> b
|
||||
|
||||
a table nth z + :> aa
|
||||
b table nth z + :> ba
|
||||
a 1 + table nth z + :> ab
|
||||
b 1 + table nth z + :> bb
|
||||
|
||||
aa table nth
|
||||
ba table nth
|
||||
ab table nth
|
||||
bb table nth
|
||||
aa 1 + table nth
|
||||
ba 1 + table nth
|
||||
ab 1 + table nth
|
||||
bb 1 + table nth ;
|
||||
|
||||
:: 2tetra@ ( p q r s t u v w quot -- )
|
||||
p q quot call
|
||||
r s quot call
|
||||
t u quot call
|
||||
v w quot call
|
||||
; inline
|
||||
|
||||
:: noise ( table point -- value )
|
||||
point unit-cube :> cube
|
||||
point dup vfloor v- :> gradients
|
||||
gradients fade :> faded
|
||||
|
||||
table cube hashes {
|
||||
[ gradients grad ]
|
||||
[ gradients { -1.0 0.0 0.0 } v+ grad ]
|
||||
[ gradients { 0.0 -1.0 0.0 } v+ grad ]
|
||||
[ gradients { -1.0 -1.0 0.0 } v+ grad ]
|
||||
[ gradients { 0.0 0.0 -1.0 } v+ grad ]
|
||||
[ gradients { -1.0 0.0 -1.0 } v+ grad ]
|
||||
[ gradients { 0.0 -1.0 -1.0 } v+ grad ]
|
||||
[ gradients { -1.0 -1.0 -1.0 } v+ grad ]
|
||||
} spread
|
||||
[ faded first lerp ] 2tetra@
|
||||
[ faded second lerp ] 2bi@
|
||||
faded third lerp ;
|
||||
|
||||
: noise-map ( table scale dim -- map )
|
||||
[ iota ] map [ v* 0.0 suffix noise ] with with product-map ;
|
||||
|
||||
: normalize ( sequence -- sequence' )
|
||||
[ supremum ] [ infimum [ - ] keep ] [ ] tri
|
||||
[ swap - ] with map [ swap / ] with map ;
|
||||
|
||||
: noise-image ( table scale dim -- image )
|
||||
[ noise-map normalize [ 255.0 * >fixnum ] B{ } map-as ]
|
||||
[ swap [ L f ] dip image boa ] bi ;
|
||||
|
||||
Loading…
Reference in New Issue