Merge branch 'master' of git://factorcode.org/git/factor
Bruno Deferrari
commit
b003ec1807
|
|
@ -221,6 +221,7 @@ M: word declarations.
|
||||||
POSTPONE: parsing
|
POSTPONE: parsing
|
||||||
POSTPONE: delimiter
|
POSTPONE: delimiter
|
||||||
POSTPONE: inline
|
POSTPONE: inline
|
||||||
|
POSTPONE: recursive
|
||||||
POSTPONE: foldable
|
POSTPONE: foldable
|
||||||
POSTPONE: flushable
|
POSTPONE: flushable
|
||||||
} [ declaration. ] with each ;
|
} [ declaration. ] with each ;
|
||||||
|
|
|
||||||
|
|
@ -20,7 +20,7 @@ ABOUT: "sequences-sorting"
|
||||||
|
|
||||||
HELP: sort
|
HELP: sort
|
||||||
{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } }
|
{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } }
|
||||||
{ $description "Sorts the elements into a new sequence of the same class as " { $snippet "seq" } "." } ;
|
{ $description "Sorts the elements into a new array." } ;
|
||||||
|
|
||||||
HELP: sort-keys
|
HELP: sort-keys
|
||||||
{ $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } }
|
{ $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } }
|
||||||
|
|
|
||||||
|
|
@ -61,6 +61,7 @@ SYMBOL: super-sent-messages
|
||||||
"NSOpenGLView"
|
"NSOpenGLView"
|
||||||
"NSOpenPanel"
|
"NSOpenPanel"
|
||||||
"NSPasteboard"
|
"NSPasteboard"
|
||||||
|
"NSPropertyListSerialization"
|
||||||
"NSResponder"
|
"NSResponder"
|
||||||
"NSSavePanel"
|
"NSSavePanel"
|
||||||
"NSScreen"
|
"NSScreen"
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,7 @@
|
||||||
USING: strings arrays hashtables assocs sequences
|
USING: strings arrays hashtables assocs sequences
|
||||||
cocoa.messages cocoa.classes cocoa.application cocoa kernel
|
cocoa.messages cocoa.classes cocoa.application cocoa kernel
|
||||||
namespaces io.backend math cocoa.enumeration byte-arrays
|
namespaces io.backend math cocoa.enumeration byte-arrays
|
||||||
combinators alien.c-types ;
|
combinators alien.c-types core-foundation ;
|
||||||
IN: cocoa.plists
|
IN: cocoa.plists
|
||||||
|
|
||||||
GENERIC: >plist ( value -- plist )
|
GENERIC: >plist ( value -- plist )
|
||||||
|
|
@ -24,8 +24,8 @@ M: sequence >plist
|
||||||
[ >plist ] map <NSArray> ;
|
[ >plist ] map <NSArray> ;
|
||||||
|
|
||||||
: write-plist ( assoc path -- )
|
: write-plist ( assoc path -- )
|
||||||
>r >plist
|
[ >plist ] [ normalize-path <NSString> ] bi* 0
|
||||||
r> normalize-path <NSString> 0 -> writeToFile:atomically:
|
-> writeToFile:atomically:
|
||||||
[ "write-plist failed" throw ] unless ;
|
[ "write-plist failed" throw ] unless ;
|
||||||
|
|
||||||
DEFER: plist>
|
DEFER: plist>
|
||||||
|
|
@ -57,3 +57,13 @@ DEFER: plist>
|
||||||
{ [ dup NSDictionary -> isKindOfClass: c-bool> ] [ (plist-NSDictionary>) ] }
|
{ [ dup NSDictionary -> isKindOfClass: c-bool> ] [ (plist-NSDictionary>) ] }
|
||||||
[ ]
|
[ ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
|
: (read-plist) ( NSData -- id )
|
||||||
|
NSPropertyListSerialization swap kCFPropertyListImmutable f f <void*>
|
||||||
|
[ -> propertyListFromData:mutabilityOption:format:errorDescription: ] keep
|
||||||
|
*void* [ -> release "read-plist failed" throw ] when* ;
|
||||||
|
|
||||||
|
: read-plist ( path -- assoc )
|
||||||
|
normalize-path <NSString>
|
||||||
|
NSData swap -> dataWithContentsOfFile:
|
||||||
|
[ (read-plist) plist> ] [ "read-plist failed" throw ] if* ;
|
||||||
|
|
|
||||||
|
|
@ -2,6 +2,15 @@ USING: combinators.lib kernel math random sequences tools.test continuations
|
||||||
arrays vectors ;
|
arrays vectors ;
|
||||||
IN: combinators.lib.tests
|
IN: combinators.lib.tests
|
||||||
|
|
||||||
|
[ 6 -1 ] [ 5 0 1 [ + ] [ - ] bi, bi* ] unit-test
|
||||||
|
[ 6 -1 1 ] [ 5 0 1 1 [ + ] [ - ] [ * ] tri, tri* ] unit-test
|
||||||
|
|
||||||
|
[ 5 4 ] [ 5 0 1 [ + ] [ - ] bi*, bi ] unit-test
|
||||||
|
[ 5 4 5 ] [ 5 0 1 1 [ + ] [ - ] [ * ] tri*, tri ] unit-test
|
||||||
|
|
||||||
|
[ 5 6 ] [ 5 0 1 [ + ] bi@, bi ] unit-test
|
||||||
|
[ 5 6 7 ] [ 5 0 1 2 [ + ] tri@, tri ] unit-test
|
||||||
|
|
||||||
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
|
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
|
||||||
[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
|
[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -8,6 +8,25 @@ generalizations macros continuations locals ;
|
||||||
|
|
||||||
IN: combinators.lib
|
IN: combinators.lib
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
! Currying cleave combinators
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: bi, ( obj quot quot -- quot' quot' )
|
||||||
|
[ [ curry ] curry ] bi@ bi ; inline
|
||||||
|
: tri, ( obj quot quot quot -- quot' quot' quot' )
|
||||||
|
[ [ curry ] curry ] tri@ tri ; inline
|
||||||
|
|
||||||
|
: bi*, ( obj obj quot quot -- quot' quot' )
|
||||||
|
[ [ curry ] curry ] bi@ bi* ; inline
|
||||||
|
: tri*, ( obj obj obj quot quot quot -- quot' quot' quot' )
|
||||||
|
[ [ curry ] curry ] tri@ tri* ; inline
|
||||||
|
|
||||||
|
: bi@, ( obj obj quot -- quot' quot' )
|
||||||
|
[ curry ] curry bi@ ; inline
|
||||||
|
: tri@, ( obj obj obj quot -- quot' quot' quot' )
|
||||||
|
[ curry ] curry tri@ ; inline
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
! Generalized versions of core combinators
|
! Generalized versions of core combinators
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
|
||||||
|
|
@ -43,6 +43,11 @@ TYPEDEF: int CFNumberType
|
||||||
: kCFNumberCGFloatType 16 ; inline
|
: kCFNumberCGFloatType 16 ; inline
|
||||||
: kCFNumberMaxType 16 ; inline
|
: kCFNumberMaxType 16 ; inline
|
||||||
|
|
||||||
|
TYPEDEF: int CFPropertyListMutabilityOptions
|
||||||
|
: kCFPropertyListImmutable 0 ; inline
|
||||||
|
: kCFPropertyListMutableContainers 1 ; inline
|
||||||
|
: kCFPropertyListMutableContainersAndLeaves 2 ; inline
|
||||||
|
|
||||||
FUNCTION: CFArrayRef CFArrayCreateMutable ( CFAllocatorRef allocator, CFIndex capacity, void* callbacks ) ;
|
FUNCTION: CFArrayRef CFArrayCreateMutable ( CFAllocatorRef allocator, CFIndex capacity, void* callbacks ) ;
|
||||||
|
|
||||||
FUNCTION: void* CFArrayGetValueAtIndex ( CFArrayRef array, CFIndex idx ) ;
|
FUNCTION: void* CFArrayGetValueAtIndex ( CFArrayRef array, CFIndex idx ) ;
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Joe Groff
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Joe Groff
|
||||||
|
|
@ -0,0 +1,8 @@
|
||||||
|
USING: kernel system combinators parser ;
|
||||||
|
IN: game-input.backend
|
||||||
|
|
||||||
|
<< {
|
||||||
|
{ [ os macosx? ] [ "game-input.backend.iokit" use+ ] }
|
||||||
|
{ [ os windows? ] [ "game-input.backend.dinput" use+ ] }
|
||||||
|
{ [ t ] [ ] }
|
||||||
|
} cond >>
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Joe Groff
|
||||||
|
|
@ -0,0 +1,282 @@
|
||||||
|
USING: windows.dinput windows.dinput.constants game-input
|
||||||
|
symbols alien.c-types windows.ole32 namespaces assocs kernel
|
||||||
|
arrays vectors windows.kernel32 windows.com windows.dinput
|
||||||
|
shuffle windows.user32 windows.messages sequences combinators
|
||||||
|
math.geometry.rect ui.windows accessors math windows alien
|
||||||
|
alien.strings io.encodings.utf16 continuations byte-arrays
|
||||||
|
locals game-input.backend.dinput.keys-array ;
|
||||||
|
IN: game-input.backend.dinput
|
||||||
|
|
||||||
|
SINGLETON: dinput-game-input-backend
|
||||||
|
|
||||||
|
SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
|
||||||
|
+controller-devices+ +controller-guids+
|
||||||
|
+device-change-window+ +device-change-handle+ ;
|
||||||
|
|
||||||
|
: create-dinput ( -- )
|
||||||
|
f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
|
||||||
|
f <void*> [ f DirectInput8Create ole32-error ] keep *void*
|
||||||
|
+dinput+ set-global ;
|
||||||
|
|
||||||
|
: delete-dinput ( -- )
|
||||||
|
+dinput+ global [ com-release f ] change-at ;
|
||||||
|
|
||||||
|
: device-for-guid ( guid -- device )
|
||||||
|
+dinput+ get swap f <void*>
|
||||||
|
[ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
|
||||||
|
|
||||||
|
: 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 ;
|
||||||
|
|
||||||
|
: configure-keyboard ( keyboard -- )
|
||||||
|
[ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
|
||||||
|
: 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> <keys-array> keyboard-state boa
|
||||||
|
+keyboard-state+ set-global ;
|
||||||
|
|
||||||
|
: device-info ( device -- DIDEVICEIMAGEINFOW )
|
||||||
|
"DIDEVICEINSTANCEW" <c-object>
|
||||||
|
"DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
|
||||||
|
[ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ;
|
||||||
|
: device-caps ( device -- DIDEVCAPS )
|
||||||
|
"DIDEVCAPS" <c-object>
|
||||||
|
"DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize
|
||||||
|
[ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ;
|
||||||
|
|
||||||
|
: <guid> ( memory -- byte-array )
|
||||||
|
"GUID" heap-size memory>byte-array ;
|
||||||
|
|
||||||
|
: device-guid ( device -- guid )
|
||||||
|
device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
|
||||||
|
|
||||||
|
: device-attached? ( device -- ? )
|
||||||
|
+dinput+ get swap device-guid
|
||||||
|
IDirectInput8W::GetDeviceStatus S_OK = ;
|
||||||
|
|
||||||
|
: find-device-axes-callback ( -- alien )
|
||||||
|
[ ! ( lpddoi pvRef -- BOOL )
|
||||||
|
+controller-devices+ get at
|
||||||
|
swap DIDEVICEOBJECTINSTANCEW-guidType <guid> {
|
||||||
|
{ [ 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
|
||||||
|
[ DIDEVCAPS-dwButtons f <array> >>buttons ]
|
||||||
|
[ DIDEVCAPS-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 +controller-guids+ get set-at ]
|
||||||
|
[ +controller-devices+ get set-at ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
: add-controller ( guid -- )
|
||||||
|
dup <guid> 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-guidInstance add-controller
|
||||||
|
DIENUM_CONTINUE
|
||||||
|
] LPDIENUMDEVICESCALLBACKW ;
|
||||||
|
|
||||||
|
: 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 -- ? )
|
||||||
|
DEV_BROADCAST_HDR-dbch_devicetype DBT_DEVTYP_DEVICEINTERFACE = ;
|
||||||
|
|
||||||
|
: device-arrived ( dbt-broadcast-hdr -- )
|
||||||
|
device-interface? [ find-controllers ] when ;
|
||||||
|
|
||||||
|
: device-removed ( dbt-broadcast-hdr -- )
|
||||||
|
device-interface? [ find-and-remove-detached-devices ] when ;
|
||||||
|
|
||||||
|
: handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
|
||||||
|
[ 2drop ] 2dip swap {
|
||||||
|
{ [ dup DBT_DEVICEARRIVAL = ] [ drop <alien> device-arrived ] }
|
||||||
|
{ [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <alien> device-removed ] }
|
||||||
|
[ 2drop ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
TUPLE: window-rect < rect window-loc ;
|
||||||
|
: <zero-window-rect> ( -- window-rect )
|
||||||
|
window-rect new
|
||||||
|
{ 0 0 } >>window-loc
|
||||||
|
{ 0 0 } >>loc
|
||||||
|
{ 0 0 } >>dim ;
|
||||||
|
|
||||||
|
: (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
|
||||||
|
"DEV_BROADCAST_DEVICEW" <c-object>
|
||||||
|
"DEV_BROADCAST_DEVICEW" heap-size over set-DEV_BROADCAST_DEVICEW-dbcc_size
|
||||||
|
DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
|
||||||
|
|
||||||
|
: create-device-change-window ( -- )
|
||||||
|
<zero-window-rect> create-window
|
||||||
|
[
|
||||||
|
(device-notification-filter)
|
||||||
|
DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor
|
||||||
|
RegisterDeviceNotification
|
||||||
|
+device-change-handle+ set-global
|
||||||
|
]
|
||||||
|
[ +device-change-window+ set-global ] bi ;
|
||||||
|
|
||||||
|
: close-device-change-window ( -- )
|
||||||
|
+device-change-handle+ global
|
||||||
|
[ UnregisterDeviceNotification drop f ] change-at
|
||||||
|
+device-change-window+ global
|
||||||
|
[ DestroyWindow win32-error=0/f f ] change-at ;
|
||||||
|
|
||||||
|
: add-wm-devicechange ( -- )
|
||||||
|
[ 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+ global [
|
||||||
|
[ drop com-release ] assoc-each f
|
||||||
|
] change-at
|
||||||
|
f +controller-guids+ set-global ;
|
||||||
|
|
||||||
|
: release-keyboard ( -- )
|
||||||
|
+keyboard-device+ global
|
||||||
|
[ com-release f ] change-at
|
||||||
|
f +keyboard-state+ set-global ;
|
||||||
|
|
||||||
|
M: dinput-game-input-backend (open-game-input)
|
||||||
|
create-dinput
|
||||||
|
create-device-change-window
|
||||||
|
find-keyboard
|
||||||
|
set-up-controllers
|
||||||
|
add-wm-devicechange ;
|
||||||
|
|
||||||
|
M: dinput-game-input-backend (close-game-input)
|
||||||
|
remove-wm-devicechange
|
||||||
|
release-controllers
|
||||||
|
release-keyboard
|
||||||
|
close-device-change-window
|
||||||
|
delete-dinput ;
|
||||||
|
|
||||||
|
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 DIDEVICEINSTANCEW-tszProductName
|
||||||
|
utf16n alien>string ;
|
||||||
|
|
||||||
|
M: dinput-game-input-backend product-id
|
||||||
|
handle>> device-info DIDEVICEINSTANCEW-guidProduct <guid> ;
|
||||||
|
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? [
|
||||||
|
device acquired-quot call
|
||||||
|
succeeded-quot call
|
||||||
|
] failed-quot if ; inline
|
||||||
|
|
||||||
|
: pov-values
|
||||||
|
{
|
||||||
|
pov-up pov-up-right pov-right pov-down-right
|
||||||
|
pov-down pov-down-left pov-left pov-up-left
|
||||||
|
} ; inline
|
||||||
|
|
||||||
|
: >axis ( long -- float )
|
||||||
|
32767 - 32767.0 /f ;
|
||||||
|
: >slider ( long -- float )
|
||||||
|
65535.0 /f ;
|
||||||
|
: >pov ( long -- symbol )
|
||||||
|
dup HEX: FFFF bitand HEX: FFFF =
|
||||||
|
[ drop pov-neutral ]
|
||||||
|
[ 2750 + 4500 /i pov-values nth ] if ;
|
||||||
|
: >buttons ( alien length -- array )
|
||||||
|
memory>byte-array <keys-array> ;
|
||||||
|
|
||||||
|
: (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
|
||||||
|
[ drop ] compose [ 2drop ] if ; inline
|
||||||
|
|
||||||
|
: fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
|
||||||
|
{
|
||||||
|
[ over x>> [ DIJOYSTATE2-lX >axis >>x ] (fill-if) ]
|
||||||
|
[ over y>> [ DIJOYSTATE2-lY >axis >>y ] (fill-if) ]
|
||||||
|
[ over z>> [ DIJOYSTATE2-lZ >axis >>z ] (fill-if) ]
|
||||||
|
[ over rx>> [ DIJOYSTATE2-lRx >axis >>rx ] (fill-if) ]
|
||||||
|
[ over ry>> [ DIJOYSTATE2-lRy >axis >>ry ] (fill-if) ]
|
||||||
|
[ over rz>> [ DIJOYSTATE2-lRz >axis >>rz ] (fill-if) ]
|
||||||
|
[ over slider>> [ DIJOYSTATE2-rglSlider *long >slider >>slider ] (fill-if) ]
|
||||||
|
[ over pov>> [ DIJOYSTATE2-rgdwPOV *uint >pov >>pov ] (fill-if) ]
|
||||||
|
[ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
|
||||||
|
} 2cleave ;
|
||||||
|
|
||||||
|
: get-device-state ( device byte-array -- )
|
||||||
|
[ dup IDirectInputDevice8W::Poll ole32-error ] dip
|
||||||
|
[ length ] keep
|
||||||
|
IDirectInputDevice8W::GetDeviceState ole32-error ;
|
||||||
|
|
||||||
|
: (read-controller) ( handle template -- state )
|
||||||
|
swap [ "DIJOYSTATE2" heap-size <byte-array> [ 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 ;
|
||||||
|
|
||||||
|
dinput-game-input-backend game-input-backend set-global
|
||||||
|
|
@ -0,0 +1,15 @@
|
||||||
|
USING: sequences sequences.private math alien.c-types
|
||||||
|
accessors ;
|
||||||
|
IN: game-input.backend.dinput.keys-array
|
||||||
|
|
||||||
|
TUPLE: keys-array underlying ;
|
||||||
|
C: <keys-array> keys-array
|
||||||
|
|
||||||
|
: >key ( byte -- ? )
|
||||||
|
HEX: 80 bitand c-bool> ;
|
||||||
|
|
||||||
|
M: keys-array length underlying>> length ;
|
||||||
|
M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
|
||||||
|
|
||||||
|
INSTANCE: keys-array sequence
|
||||||
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
DirectInput backend for game-input
|
||||||
|
|
@ -0,0 +1,4 @@
|
||||||
|
input
|
||||||
|
gamepads
|
||||||
|
joysticks
|
||||||
|
windows
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Joe Groff
|
||||||
|
|
@ -0,0 +1,275 @@
|
||||||
|
USING: cocoa cocoa.plists core-foundation iokit iokit.hid
|
||||||
|
kernel cocoa.enumeration destructors math.parser cocoa.application
|
||||||
|
sequences locals combinators.short-circuit game-input threads
|
||||||
|
symbols namespaces assocs vectors arrays combinators
|
||||||
|
core-foundation.run-loop accessors sequences.private
|
||||||
|
alien.c-types math ;
|
||||||
|
IN: game-input.backend.iokit
|
||||||
|
|
||||||
|
SINGLETON: iokit-game-input-backend
|
||||||
|
|
||||||
|
: hid-manager-matching ( matching-seq -- alien )
|
||||||
|
f 0 IOHIDManagerCreate
|
||||||
|
[ swap >plist IOHIDManagerSetDeviceMatchingMultiple ]
|
||||||
|
keep ;
|
||||||
|
|
||||||
|
: devices-from-hid-manager ( manager -- vector )
|
||||||
|
[
|
||||||
|
IOHIDManagerCopyDevices
|
||||||
|
[ &CFRelease NSFastEnumeration>vector ] [ f ] if*
|
||||||
|
] with-destructors ;
|
||||||
|
|
||||||
|
: game-devices-matching-seq
|
||||||
|
{
|
||||||
|
H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
|
||||||
|
H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
|
||||||
|
H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
|
||||||
|
} ; inline
|
||||||
|
|
||||||
|
: buttons-matching-hash
|
||||||
|
H{ { "UsagePage" 9 } { "Type" 2 } } ; inline
|
||||||
|
: keys-matching-hash
|
||||||
|
H{ { "UsagePage" 7 } { "Type" 2 } } ; inline
|
||||||
|
: x-axis-matching-hash
|
||||||
|
H{ { "UsagePage" 1 } { "Usage" HEX: 30 } { "Type" 1 } } ; inline
|
||||||
|
: y-axis-matching-hash
|
||||||
|
H{ { "UsagePage" 1 } { "Usage" HEX: 31 } { "Type" 1 } } ; inline
|
||||||
|
: z-axis-matching-hash
|
||||||
|
H{ { "UsagePage" 1 } { "Usage" HEX: 32 } { "Type" 1 } } ; inline
|
||||||
|
: rx-axis-matching-hash
|
||||||
|
H{ { "UsagePage" 1 } { "Usage" HEX: 33 } { "Type" 1 } } ; inline
|
||||||
|
: ry-axis-matching-hash
|
||||||
|
H{ { "UsagePage" 1 } { "Usage" HEX: 34 } { "Type" 1 } } ; inline
|
||||||
|
: rz-axis-matching-hash
|
||||||
|
H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } } ; inline
|
||||||
|
: slider-matching-hash
|
||||||
|
H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } } ; inline
|
||||||
|
: hat-switch-matching-hash
|
||||||
|
H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } } ; inline
|
||||||
|
|
||||||
|
: 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 dup empty? [ drop f ] [ first ] if ;
|
||||||
|
|
||||||
|
: ?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 ;
|
||||||
|
|
||||||
|
: hid-manager-matching-game-devices ( -- alien )
|
||||||
|
game-devices-matching-seq hid-manager-matching ;
|
||||||
|
|
||||||
|
: device-property ( device key -- value )
|
||||||
|
<NSString> IOHIDDeviceGetProperty plist> ;
|
||||||
|
: element-property ( element key -- value )
|
||||||
|
<NSString> IOHIDElementGetProperty plist> ;
|
||||||
|
: 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 ;
|
||||||
|
|
||||||
|
: controller-device? ( device -- ? )
|
||||||
|
{
|
||||||
|
[ 1 4 IOHIDDeviceConformsTo ]
|
||||||
|
[ 1 5 IOHIDDeviceConformsTo ]
|
||||||
|
} 1|| ;
|
||||||
|
|
||||||
|
: element-usage ( element -- {usage-page,usage} )
|
||||||
|
[ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
|
||||||
|
2array ;
|
||||||
|
|
||||||
|
: button? ( {usage-page,usage} -- ? )
|
||||||
|
first 9 = ; inline
|
||||||
|
: keyboard-key? ( {usage-page,usage} -- ? )
|
||||||
|
first 7 = ; inline
|
||||||
|
: x-axis? ( {usage-page,usage} -- ? )
|
||||||
|
{ 1 HEX: 30 } = ; inline
|
||||||
|
: y-axis? ( {usage-page,usage} -- ? )
|
||||||
|
{ 1 HEX: 31 } = ; inline
|
||||||
|
: z-axis? ( {usage-page,usage} -- ? )
|
||||||
|
{ 1 HEX: 32 } = ; inline
|
||||||
|
: rx-axis? ( {usage-page,usage} -- ? )
|
||||||
|
{ 1 HEX: 33 } = ; inline
|
||||||
|
: ry-axis? ( {usage-page,usage} -- ? )
|
||||||
|
{ 1 HEX: 34 } = ; inline
|
||||||
|
: rz-axis? ( {usage-page,usage} -- ? )
|
||||||
|
{ 1 HEX: 35 } = ; inline
|
||||||
|
: slider? ( {usage-page,usage} -- ? )
|
||||||
|
{ 1 HEX: 36 } = ; inline
|
||||||
|
: hat-switch? ( {usage-page,usage} -- ? )
|
||||||
|
{ 1 HEX: 39 } = ; inline
|
||||||
|
|
||||||
|
: pov-values
|
||||||
|
{
|
||||||
|
pov-up pov-up-right pov-right pov-down-right
|
||||||
|
pov-down pov-down-left pov-left pov-up-left
|
||||||
|
pov-neutral
|
||||||
|
} ; inline
|
||||||
|
|
||||||
|
: button-value ( value -- f/(0,1] )
|
||||||
|
IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
|
||||||
|
: axis-value ( value -- [-1,1] )
|
||||||
|
kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
|
||||||
|
: pov-value ( value -- pov-direction )
|
||||||
|
IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
|
||||||
|
|
||||||
|
: record-controller ( controller-state value -- )
|
||||||
|
dup IOHIDValueGetElement element-usage {
|
||||||
|
{ [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] }
|
||||||
|
{ [ 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 ;
|
||||||
|
|
||||||
|
SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
|
||||||
|
|
||||||
|
: ?set-nth ( value nth seq -- )
|
||||||
|
2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
|
||||||
|
|
||||||
|
: record-keyboard ( value -- )
|
||||||
|
dup IOHIDValueGetElement element-usage keyboard-key? [
|
||||||
|
[ IOHIDValueGetIntegerValue c-bool> ]
|
||||||
|
[ IOHIDValueGetElement IOHIDElementGetUsage ] bi
|
||||||
|
+keyboard-state+ get ?set-nth
|
||||||
|
] [ drop ] if ;
|
||||||
|
|
||||||
|
: 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 ;
|
||||||
|
|
||||||
|
: device-matched-callback ( -- alien )
|
||||||
|
[| context result sender device |
|
||||||
|
device controller-device? [
|
||||||
|
device <device-controller-state>
|
||||||
|
device +controller-states+ get set-at
|
||||||
|
] when
|
||||||
|
] 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 ]
|
||||||
|
[ value record-keyboard ]
|
||||||
|
if
|
||||||
|
] IOHIDValueCallback ;
|
||||||
|
|
||||||
|
: initialize-variables ( manager -- )
|
||||||
|
+hid-manager+ set-global
|
||||||
|
4 <vector> +controller-states+ set-global
|
||||||
|
256 f <array> +keyboard-state+ set-global ;
|
||||||
|
|
||||||
|
M: iokit-game-input-backend (open-game-input)
|
||||||
|
hid-manager-matching-game-devices {
|
||||||
|
[ initialize-variables ]
|
||||||
|
[ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
|
||||||
|
[ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
|
||||||
|
[ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
|
||||||
|
[ 0 IOHIDManagerOpen mach-error ]
|
||||||
|
[
|
||||||
|
CFRunLoopGetMain CFRunLoopDefaultMode
|
||||||
|
IOHIDManagerScheduleWithRunLoop
|
||||||
|
]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
M: iokit-game-input-backend (close-game-input)
|
||||||
|
+hid-manager+ get-global [
|
||||||
|
+hid-manager+ global [
|
||||||
|
[
|
||||||
|
CFRunLoopGetMain CFRunLoopDefaultMode
|
||||||
|
IOHIDManagerUnscheduleFromRunLoop
|
||||||
|
]
|
||||||
|
[ 0 IOHIDManagerClose drop ]
|
||||||
|
[ CFRelease ] tri
|
||||||
|
f
|
||||||
|
] change-at
|
||||||
|
f +keyboard-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 ;
|
||||||
|
|
||||||
|
iokit-game-input-backend game-input-backend set-global
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
IOKit HID Manager backend for game-input
|
||||||
|
|
@ -0,0 +1,4 @@
|
||||||
|
gamepads
|
||||||
|
joysticks
|
||||||
|
mac
|
||||||
|
input
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Platform-specific backends for game-input
|
||||||
|
|
@ -0,0 +1,3 @@
|
||||||
|
gamepads
|
||||||
|
joysticks
|
||||||
|
input
|
||||||
|
|
@ -0,0 +1,126 @@
|
||||||
|
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 input." $nl
|
||||||
|
"The game input interface must be initialized before being used:"
|
||||||
|
{ $subsection open-game-input }
|
||||||
|
{ $subsection close-game-input }
|
||||||
|
{ $subsection with-game-input }
|
||||||
|
"Once the game input interface is open, connected controller devices can be enumerated:"
|
||||||
|
{ $subsection get-controllers }
|
||||||
|
{ $subsection find-controller-products }
|
||||||
|
{ $subsection find-controller-instance }
|
||||||
|
"These " { $link controller } " objects can be queried of their identity:"
|
||||||
|
{ $subsection product-string }
|
||||||
|
{ $subsection product-id }
|
||||||
|
{ $subsection instance-id }
|
||||||
|
"A hook is provided for invoking the system calibration tool:"
|
||||||
|
{ $subsection calibrate-controller }
|
||||||
|
"The current state of a controller or the keyboard can be read:"
|
||||||
|
{ $subsection read-controller }
|
||||||
|
{ $subsection read-keyboard }
|
||||||
|
{ $subsection controller-state }
|
||||||
|
{ $subsection keyboard-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." } ;
|
||||||
|
|
||||||
|
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. If the game input interface is not opened, nothing happens." } ;
|
||||||
|
|
||||||
|
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: 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" } "." } ;
|
||||||
|
|
||||||
|
{ keyboard-state read-keyboard } related-words
|
||||||
|
|
||||||
|
ABOUT: "game-input"
|
||||||
|
|
@ -0,0 +1,60 @@
|
||||||
|
USING: arrays accessors continuations kernel symbols
|
||||||
|
combinators.lib sequences namespaces ;
|
||||||
|
IN: game-input
|
||||||
|
|
||||||
|
SYMBOLS: game-input-backend game-input-opened ;
|
||||||
|
|
||||||
|
HOOK: (open-game-input) game-input-backend ( -- )
|
||||||
|
HOOK: (close-game-input) game-input-backend ( -- )
|
||||||
|
|
||||||
|
: game-input-opened? ( -- ? )
|
||||||
|
game-input-opened get ;
|
||||||
|
|
||||||
|
: open-game-input ( -- )
|
||||||
|
game-input-opened? [
|
||||||
|
(open-game-input)
|
||||||
|
game-input-opened on
|
||||||
|
] unless ;
|
||||||
|
: close-game-input ( -- )
|
||||||
|
game-input-opened? [
|
||||||
|
(close-game-input)
|
||||||
|
game-input-opened off
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: with-game-input ( quot -- )
|
||||||
|
open-game-input [ close-game-input ] [ ] cleanup ;
|
||||||
|
|
||||||
|
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 ;
|
||||||
|
|
||||||
|
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 )
|
||||||
|
|
||||||
|
: find-controller-products ( product-id -- sequence )
|
||||||
|
get-controllers [ product-id = ] with filter ;
|
||||||
|
: find-controller-instance ( product-id instance-id -- controller/f )
|
||||||
|
get-controllers [
|
||||||
|
[ product-id = ]
|
||||||
|
[ instance-id = ] bi, bi* and
|
||||||
|
] 2with find nip ;
|
||||||
|
|
||||||
|
HOOK: read-controller game-input-backend ( controller -- controller-state )
|
||||||
|
HOOK: calibrate-controller game-input-backend ( controller -- )
|
||||||
|
|
||||||
|
TUPLE: keyboard-state keys ;
|
||||||
|
|
||||||
|
M: keyboard-state clone
|
||||||
|
call-next-method dup keys>> clone >>keys ;
|
||||||
|
|
||||||
|
HOOK: read-keyboard game-input-backend ( -- keyboard-state )
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Joe Groff
|
||||||
|
|
@ -0,0 +1,175 @@
|
||||||
|
IN: game-input.scancodes
|
||||||
|
|
||||||
|
: key-undefined HEX: 0000 ; inline
|
||||||
|
: key-error-roll-over HEX: 0001 ; inline
|
||||||
|
: key-error-post-fail HEX: 0002 ; inline
|
||||||
|
: key-error-undefined HEX: 0003 ; inline
|
||||||
|
: key-a HEX: 0004 ; inline
|
||||||
|
: key-b HEX: 0005 ; inline
|
||||||
|
: key-c HEX: 0006 ; inline
|
||||||
|
: key-d HEX: 0007 ; inline
|
||||||
|
: key-e HEX: 0008 ; inline
|
||||||
|
: key-f HEX: 0009 ; inline
|
||||||
|
: key-g HEX: 000a ; inline
|
||||||
|
: key-h HEX: 000b ; inline
|
||||||
|
: key-i HEX: 000c ; inline
|
||||||
|
: key-j HEX: 000d ; inline
|
||||||
|
: key-k HEX: 000e ; inline
|
||||||
|
: key-l HEX: 000f ; inline
|
||||||
|
: key-m HEX: 0010 ; inline
|
||||||
|
: key-n HEX: 0011 ; inline
|
||||||
|
: key-o HEX: 0012 ; inline
|
||||||
|
: key-p HEX: 0013 ; inline
|
||||||
|
: key-q HEX: 0014 ; inline
|
||||||
|
: key-r HEX: 0015 ; inline
|
||||||
|
: key-s HEX: 0016 ; inline
|
||||||
|
: key-t HEX: 0017 ; inline
|
||||||
|
: key-u HEX: 0018 ; inline
|
||||||
|
: key-v HEX: 0019 ; inline
|
||||||
|
: key-w HEX: 001a ; inline
|
||||||
|
: key-x HEX: 001b ; inline
|
||||||
|
: key-y HEX: 001c ; inline
|
||||||
|
: key-z HEX: 001d ; inline
|
||||||
|
: key-1 HEX: 001e ; inline
|
||||||
|
: key-2 HEX: 001f ; inline
|
||||||
|
: key-3 HEX: 0020 ; inline
|
||||||
|
: key-4 HEX: 0021 ; inline
|
||||||
|
: key-5 HEX: 0022 ; inline
|
||||||
|
: key-6 HEX: 0023 ; inline
|
||||||
|
: key-7 HEX: 0024 ; inline
|
||||||
|
: key-8 HEX: 0025 ; inline
|
||||||
|
: key-9 HEX: 0026 ; inline
|
||||||
|
: key-0 HEX: 0027 ; inline
|
||||||
|
: key-return HEX: 0028 ; inline
|
||||||
|
: key-escape HEX: 0029 ; inline
|
||||||
|
: key-backspace HEX: 002a ; inline
|
||||||
|
: key-tab HEX: 002b ; inline
|
||||||
|
: key-space HEX: 002c ; inline
|
||||||
|
: key-- HEX: 002d ; inline
|
||||||
|
: key-= HEX: 002e ; inline
|
||||||
|
: key-[ HEX: 002f ; inline
|
||||||
|
: key-] HEX: 0030 ; inline
|
||||||
|
: key-\ HEX: 0031 ; inline
|
||||||
|
: key-#-non-us HEX: 0032 ; inline
|
||||||
|
: key-; HEX: 0033 ; inline
|
||||||
|
: key-' HEX: 0034 ; inline
|
||||||
|
: key-` HEX: 0035 ; inline
|
||||||
|
: key-, HEX: 0036 ; inline
|
||||||
|
: key-. HEX: 0037 ; inline
|
||||||
|
: key-/ HEX: 0038 ; inline
|
||||||
|
: key-caps-lock HEX: 0039 ; inline
|
||||||
|
: key-f1 HEX: 003a ; inline
|
||||||
|
: key-f2 HEX: 003b ; inline
|
||||||
|
: key-f3 HEX: 003c ; inline
|
||||||
|
: key-f4 HEX: 003d ; inline
|
||||||
|
: key-f5 HEX: 003e ; inline
|
||||||
|
: key-f6 HEX: 003f ; inline
|
||||||
|
: key-f7 HEX: 0040 ; inline
|
||||||
|
: key-f8 HEX: 0041 ; inline
|
||||||
|
: key-f9 HEX: 0042 ; inline
|
||||||
|
: key-f10 HEX: 0043 ; inline
|
||||||
|
: key-f11 HEX: 0044 ; inline
|
||||||
|
: key-f12 HEX: 0045 ; inline
|
||||||
|
: key-print-screen HEX: 0046 ; inline
|
||||||
|
: key-scroll-lock HEX: 0047 ; inline
|
||||||
|
: key-pause HEX: 0048 ; inline
|
||||||
|
: key-insert HEX: 0049 ; inline
|
||||||
|
: key-home HEX: 004a ; inline
|
||||||
|
: key-page-up HEX: 004b ; inline
|
||||||
|
: key-delete HEX: 004c ; inline
|
||||||
|
: key-end HEX: 004d ; inline
|
||||||
|
: key-page-down HEX: 004e ; inline
|
||||||
|
: key-right-arrow HEX: 004f ; inline
|
||||||
|
: key-left-arrow HEX: 0050 ; inline
|
||||||
|
: key-down-arrow HEX: 0051 ; inline
|
||||||
|
: key-up-arrow HEX: 0052 ; inline
|
||||||
|
: key-keypad-numlock HEX: 0053 ; inline
|
||||||
|
: key-keypad-/ HEX: 0054 ; inline
|
||||||
|
: key-keypad-* HEX: 0055 ; inline
|
||||||
|
: key-keypad-- HEX: 0056 ; inline
|
||||||
|
: key-keypad-+ HEX: 0057 ; inline
|
||||||
|
: key-keypad-enter HEX: 0058 ; inline
|
||||||
|
: key-keypad-1 HEX: 0059 ; inline
|
||||||
|
: key-keypad-2 HEX: 005a ; inline
|
||||||
|
: key-keypad-3 HEX: 005b ; inline
|
||||||
|
: key-keypad-4 HEX: 005c ; inline
|
||||||
|
: key-keypad-5 HEX: 005d ; inline
|
||||||
|
: key-keypad-6 HEX: 005e ; inline
|
||||||
|
: key-keypad-7 HEX: 005f ; inline
|
||||||
|
: key-keypad-8 HEX: 0060 ; inline
|
||||||
|
: key-keypad-9 HEX: 0061 ; inline
|
||||||
|
: key-keypad-0 HEX: 0062 ; inline
|
||||||
|
: key-keypad-. HEX: 0063 ; inline
|
||||||
|
: key-\-non-us HEX: 0064 ; inline
|
||||||
|
: key-application HEX: 0065 ; inline
|
||||||
|
: key-power HEX: 0066 ; inline
|
||||||
|
: key-keypad-= HEX: 0067 ; inline
|
||||||
|
: key-f13 HEX: 0068 ; inline
|
||||||
|
: key-f14 HEX: 0069 ; inline
|
||||||
|
: key-f15 HEX: 006a ; inline
|
||||||
|
: key-f16 HEX: 006b ; inline
|
||||||
|
: key-f17 HEX: 006c ; inline
|
||||||
|
: key-f18 HEX: 006d ; inline
|
||||||
|
: key-f19 HEX: 006e ; inline
|
||||||
|
: key-f20 HEX: 006f ; inline
|
||||||
|
: key-f21 HEX: 0070 ; inline
|
||||||
|
: key-f22 HEX: 0071 ; inline
|
||||||
|
: key-f23 HEX: 0072 ; inline
|
||||||
|
: key-f24 HEX: 0073 ; inline
|
||||||
|
: key-execute HEX: 0074 ; inline
|
||||||
|
: key-help HEX: 0075 ; inline
|
||||||
|
: key-menu HEX: 0076 ; inline
|
||||||
|
: key-select HEX: 0077 ; inline
|
||||||
|
: key-stop HEX: 0078 ; inline
|
||||||
|
: key-again HEX: 0079 ; inline
|
||||||
|
: key-undo HEX: 007a ; inline
|
||||||
|
: key-cut HEX: 007b ; inline
|
||||||
|
: key-copy HEX: 007c ; inline
|
||||||
|
: key-paste HEX: 007d ; inline
|
||||||
|
: key-find HEX: 007e ; inline
|
||||||
|
: key-mute HEX: 007f ; inline
|
||||||
|
: key-volume-up HEX: 0080 ; inline
|
||||||
|
: key-volume-down HEX: 0081 ; inline
|
||||||
|
: key-locking-caps-lock HEX: 0082 ; inline
|
||||||
|
: key-locking-num-lock HEX: 0083 ; inline
|
||||||
|
: key-locking-scroll-lock HEX: 0084 ; inline
|
||||||
|
: key-keypad-, HEX: 0085 ; inline
|
||||||
|
: key-keypad-=-as-400 HEX: 0086 ; inline
|
||||||
|
: key-international-1 HEX: 0087 ; inline
|
||||||
|
: key-international-2 HEX: 0088 ; inline
|
||||||
|
: key-international-3 HEX: 0089 ; inline
|
||||||
|
: key-international-4 HEX: 008a ; inline
|
||||||
|
: key-international-5 HEX: 008b ; inline
|
||||||
|
: key-international-6 HEX: 008c ; inline
|
||||||
|
: key-international-7 HEX: 008d ; inline
|
||||||
|
: key-international-8 HEX: 008e ; inline
|
||||||
|
: key-international-9 HEX: 008f ; inline
|
||||||
|
: key-lang-1 HEX: 0090 ; inline
|
||||||
|
: key-lang-2 HEX: 0091 ; inline
|
||||||
|
: key-lang-3 HEX: 0092 ; inline
|
||||||
|
: key-lang-4 HEX: 0093 ; inline
|
||||||
|
: key-lang-5 HEX: 0094 ; inline
|
||||||
|
: key-lang-6 HEX: 0095 ; inline
|
||||||
|
: key-lang-7 HEX: 0096 ; inline
|
||||||
|
: key-lang-8 HEX: 0097 ; inline
|
||||||
|
: key-lang-9 HEX: 0098 ; inline
|
||||||
|
: key-alternate-erase HEX: 0099 ; inline
|
||||||
|
: key-sysreq HEX: 009a ; inline
|
||||||
|
: key-cancel HEX: 009b ; inline
|
||||||
|
: key-clear HEX: 009c ; inline
|
||||||
|
: key-prior HEX: 009d ; inline
|
||||||
|
: key-enter HEX: 009e ; inline
|
||||||
|
: key-separator HEX: 009f ; inline
|
||||||
|
: key-out HEX: 00a0 ; inline
|
||||||
|
: key-oper HEX: 00a1 ; inline
|
||||||
|
: key-clear-again HEX: 00a2 ; inline
|
||||||
|
: key-crsel-props HEX: 00a3 ; inline
|
||||||
|
: key-exsel HEX: 00a4 ; inline
|
||||||
|
: key-left-control HEX: 00e0 ; inline
|
||||||
|
: key-left-shift HEX: 00e1 ; inline
|
||||||
|
: key-left-alt HEX: 00e2 ; inline
|
||||||
|
: key-left-gui HEX: 00e3 ; inline
|
||||||
|
: key-right-control HEX: 00e4 ; inline
|
||||||
|
: key-right-shift HEX: 00e5 ; inline
|
||||||
|
: key-right-alt HEX: 00e6 ; inline
|
||||||
|
: key-right-gui HEX: 00e7 ; inline
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Scan code constants for HID keyboards
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
keyboard
|
||||||
|
input
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Cross-platform joystick, gamepad, and raw keyboard input
|
||||||
|
|
@ -0,0 +1,3 @@
|
||||||
|
joysticks
|
||||||
|
gamepads
|
||||||
|
input
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Joe Groff
|
||||||
|
|
@ -269,3 +269,4 @@ FUNCTION: IOHIDValueRef IOHIDTransactionGetValue ( IOHIDTransactionRef transacti
|
||||||
FUNCTION: IOReturn IOHIDTransactionCommit ( IOHIDTransactionRef transaction ) ;
|
FUNCTION: IOReturn IOHIDTransactionCommit ( IOHIDTransactionRef transaction ) ;
|
||||||
FUNCTION: IOReturn IOHIDTransactionCommitWithCallback ( IOHIDTransactionRef transaction, CFTimeInterval timeout, IOHIDCallback callback, void* context ) ;
|
FUNCTION: IOReturn IOHIDTransactionCommitWithCallback ( IOHIDTransactionRef transaction, CFTimeInterval timeout, IOHIDCallback callback, void* context ) ;
|
||||||
FUNCTION: void IOHIDTransactionClear ( IOHIDTransactionRef transaction ) ;
|
FUNCTION: void IOHIDTransactionClear ( IOHIDTransactionRef transaction ) ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
HID Manager bindings
|
||||||
|
|
@ -0,0 +1,3 @@
|
||||||
|
mac
|
||||||
|
bindings
|
||||||
|
system
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Joe Groff
|
||||||
|
|
@ -0,0 +1,145 @@
|
||||||
|
USING: ui ui.gadgets sequences kernel arrays math colors
|
||||||
|
ui.render math.vectors accessors fry ui.gadgets.packs game-input
|
||||||
|
game-input.backend ui.gadgets.labels ui.gadgets.borders alarms
|
||||||
|
calendar locals combinators.lib strings ui.gadgets.buttons
|
||||||
|
combinators math.parser assocs threads ;
|
||||||
|
IN: joystick-demo
|
||||||
|
|
||||||
|
: SIZE { 151 151 } ;
|
||||||
|
: INDICATOR-SIZE { 4 4 } ;
|
||||||
|
: FREQUENCY ( -- f ) 30 recip seconds ;
|
||||||
|
|
||||||
|
TUPLE: axis-gadget < gadget indicator z-indicator pov ;
|
||||||
|
|
||||||
|
M: axis-gadget pref-dim* drop SIZE ;
|
||||||
|
|
||||||
|
: (rect-polygon) ( lo hi -- polygon )
|
||||||
|
2dup
|
||||||
|
[ [ second ] [ first ] bi* swap 2array ]
|
||||||
|
[ [ first ] [ second ] bi* 2array ] 2bi swapd 4array ;
|
||||||
|
|
||||||
|
: indicator-polygon ( -- polygon )
|
||||||
|
{ 0 0 } INDICATOR-SIZE (rect-polygon) ;
|
||||||
|
|
||||||
|
: pov-polygons
|
||||||
|
V{
|
||||||
|
{ pov-neutral { { 70 75 } { 75 70 } { 80 75 } { 75 80 } } }
|
||||||
|
{ pov-up { { 70 65 } { 75 60 } { 80 65 } } }
|
||||||
|
{ pov-up-right { { 83 60 } { 90 60 } { 90 67 } } }
|
||||||
|
{ pov-right { { 85 70 } { 90 75 } { 85 80 } } }
|
||||||
|
{ pov-down-right { { 90 83 } { 90 90 } { 83 90 } } }
|
||||||
|
{ pov-down { { 70 85 } { 75 90 } { 80 85 } } }
|
||||||
|
{ pov-down-left { { 67 90 } { 60 90 } { 60 83 } } }
|
||||||
|
{ pov-left { { 65 70 } { 60 75 } { 65 80 } } }
|
||||||
|
{ pov-up-left { { 67 60 } { 60 60 } { 60 67 } } }
|
||||||
|
} ;
|
||||||
|
|
||||||
|
: <indicator-gadget> ( color -- indicator )
|
||||||
|
indicator-polygon <polygon-gadget> ;
|
||||||
|
|
||||||
|
: (>loc) ( axisloc -- windowloc )
|
||||||
|
0.5 v*n { 0.5 0.5 } v+ SIZE v* [ >integer ] map
|
||||||
|
INDICATOR-SIZE 2 v/n v- ;
|
||||||
|
|
||||||
|
: (xy>loc) ( x y -- xyloc )
|
||||||
|
2array (>loc) ;
|
||||||
|
: (z>loc) ( z -- zloc )
|
||||||
|
0.0 swap 2array (>loc) ;
|
||||||
|
|
||||||
|
: (xyz>loc) ( x y z -- xyloc zloc )
|
||||||
|
[ [ 0.0 ] unless* ] tri@
|
||||||
|
[ (xy>loc) ] dip (z>loc) ;
|
||||||
|
|
||||||
|
: move-axis ( gadget x y z -- )
|
||||||
|
(xyz>loc) rot
|
||||||
|
[ indicator>> (>>loc) ]
|
||||||
|
[ z-indicator>> (>>loc) ] bi, bi* ;
|
||||||
|
|
||||||
|
: move-pov ( gadget pov -- )
|
||||||
|
swap pov>> [ interior>> -rot = [ gray ] [ white ] if >>color drop ]
|
||||||
|
with assoc-each ;
|
||||||
|
|
||||||
|
:: add-pov-gadget ( gadget direction polygon -- gadget direction gadget )
|
||||||
|
gadget white polygon <polygon-gadget> [ add-gadget ] keep
|
||||||
|
direction swap ;
|
||||||
|
|
||||||
|
: add-pov-gadgets ( gadget -- gadget )
|
||||||
|
pov-polygons [ add-pov-gadget ] assoc-map >>pov ;
|
||||||
|
|
||||||
|
: <axis-gadget> ( -- gadget )
|
||||||
|
axis-gadget new-gadget
|
||||||
|
add-pov-gadgets
|
||||||
|
black <indicator-gadget> [ >>z-indicator ] [ add-gadget ] bi
|
||||||
|
red <indicator-gadget> [ >>indicator ] [ add-gadget ] bi
|
||||||
|
dup [ 0.0 0.0 0.0 move-axis ] [ f move-pov ] bi ;
|
||||||
|
|
||||||
|
TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
|
||||||
|
|
||||||
|
: add-gadget-with-border ( parent child -- parent )
|
||||||
|
2 <border> gray <solid> >>boundary add-gadget ;
|
||||||
|
|
||||||
|
: add-controller-label ( gadget controller -- gadget )
|
||||||
|
[ >>controller ] [ product-string <label> add-gadget ] bi ;
|
||||||
|
|
||||||
|
: add-axis-gadget ( gadget shelf -- gadget shelf )
|
||||||
|
<axis-gadget> [ >>axis ] [ add-gadget-with-border ] bi, bi* ;
|
||||||
|
|
||||||
|
: add-raxis-gadget ( gadget shelf -- gadget shelf )
|
||||||
|
<axis-gadget> [ >>raxis ] [ add-gadget-with-border ] bi, bi* ;
|
||||||
|
|
||||||
|
:: (add-button-gadgets) ( gadget shelf -- )
|
||||||
|
gadget controller>> read-controller buttons>> length [
|
||||||
|
number>string [ ] <bevel-button>
|
||||||
|
shelf over add-gadget drop
|
||||||
|
] map gadget (>>buttons) ;
|
||||||
|
|
||||||
|
: add-button-gadgets ( gadget shelf -- gadget shelf )
|
||||||
|
[ (add-button-gadgets) ] 2keep ;
|
||||||
|
|
||||||
|
: <joystick-demo-gadget> ( controller -- gadget )
|
||||||
|
joystick-demo-gadget new-gadget
|
||||||
|
{ 0 1 } >>orientation
|
||||||
|
swap add-controller-label
|
||||||
|
<shelf> add-axis-gadget add-raxis-gadget add-gadget
|
||||||
|
<shelf> add-button-gadgets add-gadget ;
|
||||||
|
|
||||||
|
: update-buttons ( buttons button-states -- )
|
||||||
|
[ >>selected? drop ] 2each ;
|
||||||
|
|
||||||
|
: kill-update-axes ( gadget -- )
|
||||||
|
gray <solid> >>interior
|
||||||
|
[ [ cancel-alarm ] when* f ] change-alarm
|
||||||
|
relayout-1 ;
|
||||||
|
|
||||||
|
: (update-axes) ( gadget controller-state -- )
|
||||||
|
{
|
||||||
|
[ [ axis>> ] [ [ x>> ] [ y>> ] [ z>> ] tri ] bi* move-axis ]
|
||||||
|
[ [ raxis>> ] [ [ rx>> ] [ ry>> ] [ rz>> ] tri ] bi* move-axis ]
|
||||||
|
[ [ axis>> ] [ pov>> ] bi* move-pov ]
|
||||||
|
[ [ buttons>> ] [ buttons>> ] bi* update-buttons ]
|
||||||
|
[ drop relayout-1 ]
|
||||||
|
} 2cleave ;
|
||||||
|
|
||||||
|
: update-axes ( gadget -- )
|
||||||
|
dup controller>> read-controller
|
||||||
|
[ (update-axes) ] [ kill-update-axes ] if* ;
|
||||||
|
|
||||||
|
M: joystick-demo-gadget graft*
|
||||||
|
dup '[ , update-axes ] FREQUENCY every >>alarm
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
M: joystick-demo-gadget ungraft*
|
||||||
|
alarm>> [ cancel-alarm ] when* ;
|
||||||
|
|
||||||
|
: joystick-window ( controller -- )
|
||||||
|
[ <joystick-demo-gadget> ] [ product-string ] bi
|
||||||
|
open-window ;
|
||||||
|
|
||||||
|
: joystick-demo ( -- )
|
||||||
|
[
|
||||||
|
open-game-input
|
||||||
|
0.1 seconds sleep ! It might take a moment to find devices...
|
||||||
|
get-controllers [ joystick-window ] each
|
||||||
|
] with-ui ;
|
||||||
|
|
||||||
|
MAIN: joystick-demo
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Demonstrate gamepad and joystick input
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
gamepads
|
||||||
|
joysticks
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Joe Groff
|
||||||
|
|
@ -0,0 +1,180 @@
|
||||||
|
USING: game-input game-input.backend game-input.scancodes
|
||||||
|
kernel ui.gadgets ui.gadgets.buttons sequences accessors
|
||||||
|
words arrays assocs math calendar fry alarms ui
|
||||||
|
ui.gadgets.borders ui.gestures ;
|
||||||
|
IN: key-caps
|
||||||
|
|
||||||
|
: key-locations H{
|
||||||
|
{ key-escape { { 0 0 } { 10 10 } } }
|
||||||
|
|
||||||
|
{ key-f1 { { 20 0 } { 10 10 } } }
|
||||||
|
{ key-f2 { { 30 0 } { 10 10 } } }
|
||||||
|
{ key-f3 { { 40 0 } { 10 10 } } }
|
||||||
|
{ key-f4 { { 50 0 } { 10 10 } } }
|
||||||
|
|
||||||
|
{ key-f5 { { 65 0 } { 10 10 } } }
|
||||||
|
{ key-f6 { { 75 0 } { 10 10 } } }
|
||||||
|
{ key-f7 { { 85 0 } { 10 10 } } }
|
||||||
|
{ key-f8 { { 95 0 } { 10 10 } } }
|
||||||
|
|
||||||
|
{ key-f9 { { 110 0 } { 10 10 } } }
|
||||||
|
{ key-f10 { { 120 0 } { 10 10 } } }
|
||||||
|
{ key-f11 { { 130 0 } { 10 10 } } }
|
||||||
|
{ key-f12 { { 140 0 } { 10 10 } } }
|
||||||
|
|
||||||
|
|
||||||
|
{ key-` { { 0 15 } { 10 10 } } }
|
||||||
|
{ key-1 { { 10 15 } { 10 10 } } }
|
||||||
|
{ key-2 { { 20 15 } { 10 10 } } }
|
||||||
|
{ key-3 { { 30 15 } { 10 10 } } }
|
||||||
|
{ key-4 { { 40 15 } { 10 10 } } }
|
||||||
|
{ key-5 { { 50 15 } { 10 10 } } }
|
||||||
|
{ key-6 { { 60 15 } { 10 10 } } }
|
||||||
|
{ key-7 { { 70 15 } { 10 10 } } }
|
||||||
|
{ key-8 { { 80 15 } { 10 10 } } }
|
||||||
|
{ key-9 { { 90 15 } { 10 10 } } }
|
||||||
|
{ key-0 { { 100 15 } { 10 10 } } }
|
||||||
|
{ key-- { { 110 15 } { 10 10 } } }
|
||||||
|
{ key-= { { 120 15 } { 10 10 } } }
|
||||||
|
{ key-backspace { { 130 15 } { 20 10 } } }
|
||||||
|
|
||||||
|
{ key-tab { { 0 25 } { 15 10 } } }
|
||||||
|
{ key-q { { 15 25 } { 10 10 } } }
|
||||||
|
{ key-w { { 25 25 } { 10 10 } } }
|
||||||
|
{ key-e { { 35 25 } { 10 10 } } }
|
||||||
|
{ key-r { { 45 25 } { 10 10 } } }
|
||||||
|
{ key-t { { 55 25 } { 10 10 } } }
|
||||||
|
{ key-y { { 65 25 } { 10 10 } } }
|
||||||
|
{ key-u { { 75 25 } { 10 10 } } }
|
||||||
|
{ key-i { { 85 25 } { 10 10 } } }
|
||||||
|
{ key-o { { 95 25 } { 10 10 } } }
|
||||||
|
{ key-p { { 105 25 } { 10 10 } } }
|
||||||
|
{ key-[ { { 115 25 } { 10 10 } } }
|
||||||
|
{ key-] { { 125 25 } { 10 10 } } }
|
||||||
|
{ key-\ { { 135 25 } { 15 10 } } }
|
||||||
|
|
||||||
|
{ key-caps-lock { { 0 35 } { 20 10 } } }
|
||||||
|
{ key-a { { 20 35 } { 10 10 } } }
|
||||||
|
{ key-s { { 30 35 } { 10 10 } } }
|
||||||
|
{ key-d { { 40 35 } { 10 10 } } }
|
||||||
|
{ key-f { { 50 35 } { 10 10 } } }
|
||||||
|
{ key-g { { 60 35 } { 10 10 } } }
|
||||||
|
{ key-h { { 70 35 } { 10 10 } } }
|
||||||
|
{ key-j { { 80 35 } { 10 10 } } }
|
||||||
|
{ key-k { { 90 35 } { 10 10 } } }
|
||||||
|
{ key-l { { 100 35 } { 10 10 } } }
|
||||||
|
{ key-; { { 110 35 } { 10 10 } } }
|
||||||
|
{ key-' { { 120 35 } { 10 10 } } }
|
||||||
|
{ key-return { { 130 35 } { 20 10 } } }
|
||||||
|
|
||||||
|
{ key-left-shift { { 0 45 } { 25 10 } } }
|
||||||
|
{ key-z { { 25 45 } { 10 10 } } }
|
||||||
|
{ key-x { { 35 45 } { 10 10 } } }
|
||||||
|
{ key-c { { 45 45 } { 10 10 } } }
|
||||||
|
{ key-v { { 55 45 } { 10 10 } } }
|
||||||
|
{ key-b { { 65 45 } { 10 10 } } }
|
||||||
|
{ key-n { { 75 45 } { 10 10 } } }
|
||||||
|
{ key-m { { 85 45 } { 10 10 } } }
|
||||||
|
{ key-, { { 95 45 } { 10 10 } } }
|
||||||
|
{ key-. { { 105 45 } { 10 10 } } }
|
||||||
|
{ key-/ { { 115 45 } { 10 10 } } }
|
||||||
|
{ key-right-shift { { 125 45 } { 25 10 } } }
|
||||||
|
|
||||||
|
{ key-left-control { { 0 55 } { 15 10 } } }
|
||||||
|
{ key-left-gui { { 15 55 } { 15 10 } } }
|
||||||
|
{ key-left-alt { { 30 55 } { 15 10 } } }
|
||||||
|
{ key-space { { 45 55 } { 45 10 } } }
|
||||||
|
{ key-right-alt { { 90 55 } { 15 10 } } }
|
||||||
|
{ key-right-gui { { 105 55 } { 15 10 } } }
|
||||||
|
{ key-application { { 120 55 } { 15 10 } } }
|
||||||
|
{ key-right-control { { 135 55 } { 15 10 } } }
|
||||||
|
|
||||||
|
|
||||||
|
{ key-print-screen { { 155 0 } { 10 10 } } }
|
||||||
|
{ key-scroll-lock { { 165 0 } { 10 10 } } }
|
||||||
|
{ key-pause { { 175 0 } { 10 10 } } }
|
||||||
|
|
||||||
|
{ key-insert { { 155 15 } { 10 10 } } }
|
||||||
|
{ key-home { { 165 15 } { 10 10 } } }
|
||||||
|
{ key-page-up { { 175 15 } { 10 10 } } }
|
||||||
|
|
||||||
|
{ key-delete { { 155 25 } { 10 10 } } }
|
||||||
|
{ key-end { { 165 25 } { 10 10 } } }
|
||||||
|
{ key-page-down { { 175 25 } { 10 10 } } }
|
||||||
|
|
||||||
|
{ key-up-arrow { { 165 45 } { 10 10 } } }
|
||||||
|
{ key-left-arrow { { 155 55 } { 10 10 } } }
|
||||||
|
{ key-down-arrow { { 165 55 } { 10 10 } } }
|
||||||
|
{ key-right-arrow { { 175 55 } { 10 10 } } }
|
||||||
|
|
||||||
|
|
||||||
|
{ key-keypad-numlock { { 190 15 } { 10 10 } } }
|
||||||
|
{ key-keypad-/ { { 200 15 } { 10 10 } } }
|
||||||
|
{ key-keypad-* { { 210 15 } { 10 10 } } }
|
||||||
|
{ key-keypad-- { { 220 15 } { 10 10 } } }
|
||||||
|
|
||||||
|
{ key-keypad-7 { { 190 25 } { 10 10 } } }
|
||||||
|
{ key-keypad-8 { { 200 25 } { 10 10 } } }
|
||||||
|
{ key-keypad-9 { { 210 25 } { 10 10 } } }
|
||||||
|
{ key-keypad-+ { { 220 25 } { 10 20 } } }
|
||||||
|
|
||||||
|
{ key-keypad-4 { { 190 35 } { 10 10 } } }
|
||||||
|
{ key-keypad-5 { { 200 35 } { 10 10 } } }
|
||||||
|
{ key-keypad-6 { { 210 35 } { 10 10 } } }
|
||||||
|
|
||||||
|
{ key-keypad-1 { { 190 45 } { 10 10 } } }
|
||||||
|
{ key-keypad-2 { { 200 45 } { 10 10 } } }
|
||||||
|
{ key-keypad-3 { { 210 45 } { 10 10 } } }
|
||||||
|
{ key-keypad-enter { { 220 45 } { 10 20 } } }
|
||||||
|
|
||||||
|
{ key-keypad-0 { { 190 55 } { 20 10 } } }
|
||||||
|
{ key-keypad-. { { 210 55 } { 10 10 } } }
|
||||||
|
} ;
|
||||||
|
|
||||||
|
: KEYBOARD-SIZE { 230 65 } ;
|
||||||
|
: FREQUENCY ( -- f ) 30 recip seconds ;
|
||||||
|
|
||||||
|
TUPLE: key-caps-gadget < gadget keys alarm ;
|
||||||
|
|
||||||
|
: make-key-gadget ( scancode dim array -- )
|
||||||
|
[
|
||||||
|
swap [
|
||||||
|
" " [ ] <bevel-button>
|
||||||
|
swap [ first >>loc ] [ second >>dim ] bi
|
||||||
|
] [ execute ] bi*
|
||||||
|
] dip set-nth ;
|
||||||
|
|
||||||
|
: add-keys-gadgets ( gadget -- gadget )
|
||||||
|
key-locations 256 f <array>
|
||||||
|
[ [ make-key-gadget ] curry assoc-each ]
|
||||||
|
[ [ [ add-gadget ] when* ] each ]
|
||||||
|
[ >>keys ] tri ;
|
||||||
|
|
||||||
|
: <key-caps-gadget> ( -- gadget )
|
||||||
|
key-caps-gadget new-gadget
|
||||||
|
add-keys-gadgets ;
|
||||||
|
|
||||||
|
M: key-caps-gadget pref-dim* drop KEYBOARD-SIZE ;
|
||||||
|
|
||||||
|
: update-key-caps-state ( gadget -- )
|
||||||
|
read-keyboard keys>> over keys>>
|
||||||
|
[ [ (>>selected?) ] [ drop ] if* ] 2each
|
||||||
|
relayout-1 ;
|
||||||
|
|
||||||
|
M: key-caps-gadget graft*
|
||||||
|
dup '[ , update-key-caps-state ] FREQUENCY every >>alarm
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
M: key-caps-gadget ungraft*
|
||||||
|
alarm>> [ cancel-alarm ] when* ;
|
||||||
|
|
||||||
|
M: key-caps-gadget handle-gesture*
|
||||||
|
drop nip [ key-down? ] [ key-up? ] bi or not ;
|
||||||
|
|
||||||
|
: key-caps ( -- )
|
||||||
|
[
|
||||||
|
open-game-input
|
||||||
|
<key-caps-gadget> 5 <border> "Key Caps" open-window
|
||||||
|
] with-ui ;
|
||||||
|
|
||||||
|
MAIN: key-caps
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Graphical keyboard diagram
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
keyboard
|
||||||
|
|
@ -34,7 +34,16 @@ ARTICLE: "math.blas-types" "BLAS interface types"
|
||||||
{ $subsection <double-complex-blas-matrix> }
|
{ $subsection <double-complex-blas-matrix> }
|
||||||
"For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:"
|
"For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:"
|
||||||
{ $subsection <empty-vector> }
|
{ $subsection <empty-vector> }
|
||||||
{ $subsection <empty-matrix> } ;
|
{ $subsection <empty-matrix> }
|
||||||
|
"BLAS vectors and matrices can also be constructed from other Factor sequences:"
|
||||||
|
{ $subsection >float-blas-vector }
|
||||||
|
{ $subsection >double-blas-vector }
|
||||||
|
{ $subsection >float-complex-blas-vector }
|
||||||
|
{ $subsection >double-complex-blas-vector }
|
||||||
|
{ $subsection >float-blas-matrix }
|
||||||
|
{ $subsection >double-blas-matrix }
|
||||||
|
{ $subsection >float-complex-blas-matrix }
|
||||||
|
{ $subsection >double-complex-blas-matrix } ;
|
||||||
|
|
||||||
ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
|
ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
|
||||||
"Transposing and slicing matrices:"
|
"Transposing and slicing matrices:"
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,7 @@
|
||||||
|
|
||||||
USING: kernel arrays sequences math.vectors math.geometry accessors ;
|
USING: kernel arrays sequences
|
||||||
|
math math.points math.vectors math.geometry
|
||||||
|
accessors ;
|
||||||
|
|
||||||
IN: math.geometry.rect
|
IN: math.geometry.rect
|
||||||
|
|
||||||
|
|
@ -50,3 +52,10 @@ M: rect set-height! ( rect height -- rect ) over dim>> set-second ;
|
||||||
|
|
||||||
M: rect set-x! ( rect x -- rect ) over loc>> set-first ;
|
M: rect set-x! ( rect x -- rect ) over loc>> set-first ;
|
||||||
M: rect set-y! ( rect y -- rect ) over loc>> set-second ;
|
M: rect set-y! ( rect y -- rect ) over loc>> set-second ;
|
||||||
|
|
||||||
|
! Accessing corners
|
||||||
|
|
||||||
|
: top-left ( rect -- point ) loc>> ;
|
||||||
|
: top-right ( rect -- point ) [ loc>> ] [ width 1 - ] bi v+x ;
|
||||||
|
: bottom-left ( rect -- point ) [ loc>> ] [ height 1 - ] bi v+y ;
|
||||||
|
: bottom-right ( rect -- point ) [ loc>> ] [ dim>> ] bi v+ { 1 1 } v- ;
|
||||||
|
|
|
||||||
|
|
@ -195,6 +195,8 @@ TUPLE: sprite loc dim dim2 dlist texture ;
|
||||||
|
|
||||||
: gl-translate ( point -- ) first2 0.0 glTranslated ;
|
: gl-translate ( point -- ) first2 0.0 glTranslated ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
: top-left drop 0 0 glTexCoord2i 0.0 0.0 glVertex2d ; inline
|
: top-left drop 0 0 glTexCoord2i 0.0 0.0 glVertex2d ; inline
|
||||||
|
|
||||||
: top-right 1 0 glTexCoord2i first 0.0 glVertex2d ; inline
|
: top-right 1 0 glTexCoord2i first 0.0 glVertex2d ; inline
|
||||||
|
|
@ -203,6 +205,8 @@ TUPLE: sprite loc dim dim2 dlist texture ;
|
||||||
|
|
||||||
: bottom-right 1 1 glTexCoord2i gl-vertex ; inline
|
: bottom-right 1 1 glTexCoord2i gl-vertex ; inline
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: four-sides ( dim -- )
|
: four-sides ( dim -- )
|
||||||
dup top-left dup top-right dup bottom-right bottom-left ;
|
dup top-left dup top-right dup bottom-right bottom-left ;
|
||||||
|
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -31,10 +31,12 @@ TYPEDEF: void* LPDIENUMCREATEDEFFECTOBJECTSCALLBACK
|
||||||
[ "BOOL" { "LPDIRECTINPUTEFFECT" "LPVOID" } "stdcall" ]
|
[ "BOOL" { "LPDIRECTINPUTEFFECT" "LPVOID" } "stdcall" ]
|
||||||
dip alien-callback ; inline
|
dip alien-callback ; inline
|
||||||
TYPEDEF: void* LPDIENUMEFFECTSINFILECALLBACK
|
TYPEDEF: void* LPDIENUMEFFECTSINFILECALLBACK
|
||||||
|
: LPDIENUMEFFECTSINFILECALLBACK
|
||||||
[ "BOOL" { "LPCDIFILEEFFECT" "LPVOID" } "stdcall" ]
|
[ "BOOL" { "LPCDIFILEEFFECT" "LPVOID" } "stdcall" ]
|
||||||
dip alien-callback ; inline
|
dip alien-callback ; inline
|
||||||
TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW
|
TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW
|
||||||
[ "BOOL" { "LPCDIDEVICEOBJECTINSTANCE" "LPVOID" } "stdcall" ]
|
: LPDIENUMDEVICEOBJECTSCALLBACKW
|
||||||
|
[ "BOOL" { "LPCDIDEVICEOBJECTINSTANCEW" "LPVOID" } "stdcall" ]
|
||||||
dip alien-callback ; inline
|
dip alien-callback ; inline
|
||||||
|
|
||||||
TYPEDEF: DWORD D3DCOLOR
|
TYPEDEF: DWORD D3DCOLOR
|
||||||
|
|
@ -105,29 +107,35 @@ TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
|
||||||
TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
|
TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
|
||||||
|
|
||||||
C-STRUCT: DIDEVCAPS
|
C-STRUCT: DIDEVCAPS
|
||||||
{ "DWORD" "wSize" }
|
{ "DWORD" "dwSize" }
|
||||||
{ "DWORD" "wFlags" }
|
{ "DWORD" "dwFlags" }
|
||||||
{ "DWORD" "wDevType" }
|
{ "DWORD" "dwDevType" }
|
||||||
{ "DWORD" "wAxes" }
|
{ "DWORD" "dwAxes" }
|
||||||
{ "DWORD" "wButtons" }
|
{ "DWORD" "dwButtons" }
|
||||||
{ "DWORD" "wPOVs" }
|
{ "DWORD" "dwPOVs" }
|
||||||
{ "DWORD" "wFFSamplePeriod" }
|
{ "DWORD" "dwFFSamplePeriod" }
|
||||||
{ "DWORD" "wFFMinTimeResolution" }
|
{ "DWORD" "dwFFMinTimeResolution" }
|
||||||
{ "DWORD" "wFirmwareRevision" }
|
{ "DWORD" "dwFirmwareRevision" }
|
||||||
{ "DWORD" "wHardwareRevision" }
|
{ "DWORD" "dwHardwareRevision" }
|
||||||
{ "DWORD" "wFFDriverVersion" } ;
|
{ "DWORD" "dwFFDriverVersion" } ;
|
||||||
TYPEDEF: DIDEVCAPS* LPDIDEVCAPS
|
TYPEDEF: DIDEVCAPS* LPDIDEVCAPS
|
||||||
TYPEDEF: DIDEVCAPS* LPCDIDEVCAPS
|
TYPEDEF: DIDEVCAPS* LPCDIDEVCAPS
|
||||||
C-STRUCT: DIDEVICEOBJECTINSTANCEW
|
C-STRUCT: DIDEVICEOBJECTINSTANCEW
|
||||||
{ "DWORD" "dwSize" }
|
{ "DWORD" "dwSize" }
|
||||||
{ "GUID" "guidInstance" }
|
{ "GUID" "guidType" }
|
||||||
{ "GUID" "guidProduct" }
|
{ "DWORD" "dwOfs" }
|
||||||
{ "DWORD" "dwDevType" }
|
{ "DWORD" "dwType" }
|
||||||
{ "WCHAR[260]" "tszInstanceName" }
|
{ "DWORD" "dwFlags" }
|
||||||
{ "WCHAR[260]" "tszProductName" }
|
{ "WCHAR[260]" "tszName" }
|
||||||
{ "GUID" "guidFFDriver" }
|
{ "DWORD" "dwFFMaxForce" }
|
||||||
|
{ "DWORD" "dwFFForceResolution" }
|
||||||
|
{ "WORD" "wCollectionNumber" }
|
||||||
|
{ "WORD" "wDesignatorIndex" }
|
||||||
{ "WORD" "wUsagePage" }
|
{ "WORD" "wUsagePage" }
|
||||||
{ "WORD" "wUsage" } ;
|
{ "WORD" "wUsage" }
|
||||||
|
{ "DWORD" "dwDimension" }
|
||||||
|
{ "WORD" "wExponent" }
|
||||||
|
{ "WORD" "wReportId" } ;
|
||||||
TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPDIDEVICEOBJECTINSTANCEW
|
TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPDIDEVICEOBJECTINSTANCEW
|
||||||
TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPCDIDEVICEOBJECTINSTANCEW
|
TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPCDIDEVICEOBJECTINSTANCEW
|
||||||
C-STRUCT: DIDEVICEOBJECTDATA
|
C-STRUCT: DIDEVICEOBJECTDATA
|
||||||
|
|
@ -161,6 +169,49 @@ C-STRUCT: DIPROPHEADER
|
||||||
{ "DWORD" "dwHow" } ;
|
{ "DWORD" "dwHow" } ;
|
||||||
TYPEDEF: DIPROPHEADER* LPDIPROPHEADER
|
TYPEDEF: DIPROPHEADER* LPDIPROPHEADER
|
||||||
TYPEDEF: DIPROPHEADER* LPCDIPROPHEADER
|
TYPEDEF: DIPROPHEADER* LPCDIPROPHEADER
|
||||||
|
C-STRUCT: DIPROPDWORD
|
||||||
|
{ "DIPROPHEADER" "diph" }
|
||||||
|
{ "DWORD" "dwData" } ;
|
||||||
|
TYPEDEF: DIPROPDWORD* LPDIPROPDWORD
|
||||||
|
TYPEDEF: DIPROPDWORD* LPCDIPROPDWORD
|
||||||
|
C-STRUCT: DIPROPPOINTER
|
||||||
|
{ "DIPROPHEADER" "diph" }
|
||||||
|
{ "UINT_PTR" "uData" } ;
|
||||||
|
TYPEDEF: DIPROPPOINTER* LPDIPROPPOINTER
|
||||||
|
TYPEDEF: DIPROPPOINTER* LPCDIPROPPOINTER
|
||||||
|
C-STRUCT: DIPROPRANGE
|
||||||
|
{ "DIPROPHEADER" "diph" }
|
||||||
|
{ "LONG" "lMin" }
|
||||||
|
{ "LONG" "lMax" } ;
|
||||||
|
TYPEDEF: DIPROPRANGE* LPDIPROPRANGE
|
||||||
|
TYPEDEF: DIPROPRANGE* LPCDIPROPRANGE
|
||||||
|
C-STRUCT: DIPROPCAL
|
||||||
|
{ "DIPROPHEADER" "diph" }
|
||||||
|
{ "LONG" "lMin" }
|
||||||
|
{ "LONG" "lCenter" }
|
||||||
|
{ "LONG" "lMax" } ;
|
||||||
|
TYPEDEF: DIPROPCAL* LPDIPROPCAL
|
||||||
|
TYPEDEF: DIPROPCAL* LPCDIPROPCAL
|
||||||
|
C-STRUCT: DIPROPGUIDANDPATH
|
||||||
|
{ "DIPROPHEADER" "diph" }
|
||||||
|
{ "GUID" "guidClass" }
|
||||||
|
{ "WCHAR[260]" "wszPath" } ;
|
||||||
|
TYPEDEF: DIPROPGUIDANDPATH* LPDIPROPGUIDANDPATH
|
||||||
|
TYPEDEF: DIPROPGUIDANDPATH* LPCDIPROPGUIDANDPATH
|
||||||
|
C-STRUCT: DIPROPSTRING
|
||||||
|
{ "DIPROPHEADER" "diph" }
|
||||||
|
{ "WCHAR[260]" "wsz" } ;
|
||||||
|
TYPEDEF: DIPROPSTRING* LPDIPROPSTRING
|
||||||
|
TYPEDEF: DIPROPSTRING* LPCDIPROPSTRING
|
||||||
|
C-STRUCT: CPOINT
|
||||||
|
{ "LONG" "lP" }
|
||||||
|
{ "DWORD" "dwLog" } ;
|
||||||
|
C-STRUCT: DIPROPCPOINTS
|
||||||
|
{ "DIPROPHEADER" "diph" }
|
||||||
|
{ "DWORD" "dwCPointsNum" }
|
||||||
|
{ "CPOINT[8]" "cp" } ;
|
||||||
|
TYPEDEF: DIPROPCPOINTS* LPDIPROPCPOINTS
|
||||||
|
TYPEDEF: DIPROPCPOINTS* LPCDIPROPCPOINTS
|
||||||
C-STRUCT: DIENVELOPE
|
C-STRUCT: DIENVELOPE
|
||||||
{ "DWORD" "dwSize" }
|
{ "DWORD" "dwSize" }
|
||||||
{ "DWORD" "dwAttackLevel" }
|
{ "DWORD" "dwAttackLevel" }
|
||||||
|
|
@ -383,19 +434,264 @@ FUNCTION: HRESULT DirectInput8Create ( HINSTANCE hinst, DWORD dwVersion, REFIID
|
||||||
: DIDFT_ENUMCOLLECTION ( n -- instance ) 8 shift HEX: FFFF bitand ; inline
|
: DIDFT_ENUMCOLLECTION ( n -- instance ) 8 shift HEX: FFFF bitand ; inline
|
||||||
: DIDFT_NOCOLLECTION HEX: 00FFFF00 ; inline
|
: DIDFT_NOCOLLECTION HEX: 00FFFF00 ; inline
|
||||||
|
|
||||||
|
: DIDOI_FFACTUATOR HEX: 00000001 ; inline
|
||||||
|
: DIDOI_FFEFFECTTRIGGER HEX: 00000002 ; inline
|
||||||
|
: DIDOI_POLLED HEX: 00008000 ; inline
|
||||||
|
: DIDOI_ASPECTPOSITION HEX: 00000100 ; inline
|
||||||
|
: DIDOI_ASPECTVELOCITY HEX: 00000200 ; inline
|
||||||
|
: DIDOI_ASPECTACCEL HEX: 00000300 ; inline
|
||||||
|
: DIDOI_ASPECTFORCE HEX: 00000400 ; inline
|
||||||
|
: DIDOI_ASPECTMASK HEX: 00000F00 ; inline
|
||||||
|
: DIDOI_GUIDISUSAGE HEX: 00010000 ; inline
|
||||||
|
|
||||||
: DISCL_EXCLUSIVE HEX: 00000001 ; inline
|
: DISCL_EXCLUSIVE HEX: 00000001 ; inline
|
||||||
: DISCL_NONEXCLUSIVE HEX: 00000002 ; inline
|
: DISCL_NONEXCLUSIVE HEX: 00000002 ; inline
|
||||||
: DISCL_FOREGROUND HEX: 00000004 ; inline
|
: DISCL_FOREGROUND HEX: 00000004 ; inline
|
||||||
: DISCL_BACKGROUND HEX: 00000008 ; inline
|
: DISCL_BACKGROUND HEX: 00000008 ; inline
|
||||||
: DISCL_NOWINKEY HEX: 00000010 ; inline
|
: DISCL_NOWINKEY HEX: 00000010 ; inline
|
||||||
|
|
||||||
SYMBOL: +dinput+
|
: DIK_ESCAPE HEX: 01 ; inline
|
||||||
|
: DIK_1 HEX: 02 ; inline
|
||||||
|
: DIK_2 HEX: 03 ; inline
|
||||||
|
: DIK_3 HEX: 04 ; inline
|
||||||
|
: DIK_4 HEX: 05 ; inline
|
||||||
|
: DIK_5 HEX: 06 ; inline
|
||||||
|
: DIK_6 HEX: 07 ; inline
|
||||||
|
: DIK_7 HEX: 08 ; inline
|
||||||
|
: DIK_8 HEX: 09 ; inline
|
||||||
|
: DIK_9 HEX: 0A ; inline
|
||||||
|
: DIK_0 HEX: 0B ; inline
|
||||||
|
: DIK_MINUS HEX: 0C ; inline
|
||||||
|
: DIK_EQUALS HEX: 0D ; inline
|
||||||
|
: DIK_BACK HEX: 0E ; inline
|
||||||
|
: DIK_TAB HEX: 0F ; inline
|
||||||
|
: DIK_Q HEX: 10 ; inline
|
||||||
|
: DIK_W HEX: 11 ; inline
|
||||||
|
: DIK_E HEX: 12 ; inline
|
||||||
|
: DIK_R HEX: 13 ; inline
|
||||||
|
: DIK_T HEX: 14 ; inline
|
||||||
|
: DIK_Y HEX: 15 ; inline
|
||||||
|
: DIK_U HEX: 16 ; inline
|
||||||
|
: DIK_I HEX: 17 ; inline
|
||||||
|
: DIK_O HEX: 18 ; inline
|
||||||
|
: DIK_P HEX: 19 ; inline
|
||||||
|
: DIK_LBRACKET HEX: 1A ; inline
|
||||||
|
: DIK_RBRACKET HEX: 1B ; inline
|
||||||
|
: DIK_RETURN HEX: 1C ; inline
|
||||||
|
: DIK_LCONTROL HEX: 1D ; inline
|
||||||
|
: DIK_A HEX: 1E ; inline
|
||||||
|
: DIK_S HEX: 1F ; inline
|
||||||
|
: DIK_D HEX: 20 ; inline
|
||||||
|
: DIK_F HEX: 21 ; inline
|
||||||
|
: DIK_G HEX: 22 ; inline
|
||||||
|
: DIK_H HEX: 23 ; inline
|
||||||
|
: DIK_J HEX: 24 ; inline
|
||||||
|
: DIK_K HEX: 25 ; inline
|
||||||
|
: DIK_L HEX: 26 ; inline
|
||||||
|
: DIK_SEMICOLON HEX: 27 ; inline
|
||||||
|
: DIK_APOSTROPHE HEX: 28 ; inline
|
||||||
|
: DIK_GRAVE HEX: 29 ; inline
|
||||||
|
: DIK_LSHIFT HEX: 2A ; inline
|
||||||
|
: DIK_BACKSLASH HEX: 2B ; inline
|
||||||
|
: DIK_Z HEX: 2C ; inline
|
||||||
|
: DIK_X HEX: 2D ; inline
|
||||||
|
: DIK_C HEX: 2E ; inline
|
||||||
|
: DIK_V HEX: 2F ; inline
|
||||||
|
: DIK_B HEX: 30 ; inline
|
||||||
|
: DIK_N HEX: 31 ; inline
|
||||||
|
: DIK_M HEX: 32 ; inline
|
||||||
|
: DIK_COMMA HEX: 33 ; inline
|
||||||
|
: DIK_PERIOD HEX: 34 ; inline
|
||||||
|
: DIK_SLASH HEX: 35 ; inline
|
||||||
|
: DIK_RSHIFT HEX: 36 ; inline
|
||||||
|
: DIK_MULTIPLY HEX: 37 ; inline
|
||||||
|
: DIK_LMENU HEX: 38 ; inline
|
||||||
|
: DIK_SPACE HEX: 39 ; inline
|
||||||
|
: DIK_CAPITAL HEX: 3A ; inline
|
||||||
|
: DIK_F1 HEX: 3B ; inline
|
||||||
|
: DIK_F2 HEX: 3C ; inline
|
||||||
|
: DIK_F3 HEX: 3D ; inline
|
||||||
|
: DIK_F4 HEX: 3E ; inline
|
||||||
|
: DIK_F5 HEX: 3F ; inline
|
||||||
|
: DIK_F6 HEX: 40 ; inline
|
||||||
|
: DIK_F7 HEX: 41 ; inline
|
||||||
|
: DIK_F8 HEX: 42 ; inline
|
||||||
|
: DIK_F9 HEX: 43 ; inline
|
||||||
|
: DIK_F10 HEX: 44 ; inline
|
||||||
|
: DIK_NUMLOCK HEX: 45 ; inline
|
||||||
|
: DIK_SCROLL HEX: 46 ; inline
|
||||||
|
: DIK_NUMPAD7 HEX: 47 ; inline
|
||||||
|
: DIK_NUMPAD8 HEX: 48 ; inline
|
||||||
|
: DIK_NUMPAD9 HEX: 49 ; inline
|
||||||
|
: DIK_SUBTRACT HEX: 4A ; inline
|
||||||
|
: DIK_NUMPAD4 HEX: 4B ; inline
|
||||||
|
: DIK_NUMPAD5 HEX: 4C ; inline
|
||||||
|
: DIK_NUMPAD6 HEX: 4D ; inline
|
||||||
|
: DIK_ADD HEX: 4E ; inline
|
||||||
|
: DIK_NUMPAD1 HEX: 4F ; inline
|
||||||
|
: DIK_NUMPAD2 HEX: 50 ; inline
|
||||||
|
: DIK_NUMPAD3 HEX: 51 ; inline
|
||||||
|
: DIK_NUMPAD0 HEX: 52 ; inline
|
||||||
|
: DIK_DECIMAL HEX: 53 ; inline
|
||||||
|
: DIK_OEM_102 HEX: 56 ; inline
|
||||||
|
: DIK_F11 HEX: 57 ; inline
|
||||||
|
: DIK_F12 HEX: 58 ; inline
|
||||||
|
: DIK_F13 HEX: 64 ; inline
|
||||||
|
: DIK_F14 HEX: 65 ; inline
|
||||||
|
: DIK_F15 HEX: 66 ; inline
|
||||||
|
: DIK_KANA HEX: 70 ; inline
|
||||||
|
: DIK_ABNT_C1 HEX: 73 ; inline
|
||||||
|
: DIK_CONVERT HEX: 79 ; inline
|
||||||
|
: DIK_NOCONVERT HEX: 7B ; inline
|
||||||
|
: DIK_YEN HEX: 7D ; inline
|
||||||
|
: DIK_ABNT_C2 HEX: 7E ; inline
|
||||||
|
: DIK_NUMPADEQUALS HEX: 8D ; inline
|
||||||
|
: DIK_PREVTRACK HEX: 90 ; inline
|
||||||
|
: DIK_AT HEX: 91 ; inline
|
||||||
|
: DIK_COLON HEX: 92 ; inline
|
||||||
|
: DIK_UNDERLINE HEX: 93 ; inline
|
||||||
|
: DIK_KANJI HEX: 94 ; inline
|
||||||
|
: DIK_STOP HEX: 95 ; inline
|
||||||
|
: DIK_AX HEX: 96 ; inline
|
||||||
|
: DIK_UNLABELED HEX: 97 ; inline
|
||||||
|
: DIK_NEXTTRACK HEX: 99 ; inline
|
||||||
|
: DIK_NUMPADENTER HEX: 9C ; inline
|
||||||
|
: DIK_RCONTROL HEX: 9D ; inline
|
||||||
|
: DIK_MUTE HEX: A0 ; inline
|
||||||
|
: DIK_CALCULATOR HEX: A1 ; inline
|
||||||
|
: DIK_PLAYPAUSE HEX: A2 ; inline
|
||||||
|
: DIK_MEDIASTOP HEX: A4 ; inline
|
||||||
|
: DIK_VOLUMEDOWN HEX: AE ; inline
|
||||||
|
: DIK_VOLUMEUP HEX: B0 ; inline
|
||||||
|
: DIK_WEBHOME HEX: B2 ; inline
|
||||||
|
: DIK_NUMPADCOMMA HEX: B3 ; inline
|
||||||
|
: DIK_DIVIDE HEX: B5 ; inline
|
||||||
|
: DIK_SYSRQ HEX: B7 ; inline
|
||||||
|
: DIK_RMENU HEX: B8 ; inline
|
||||||
|
: DIK_PAUSE HEX: C5 ; inline
|
||||||
|
: DIK_HOME HEX: C7 ; inline
|
||||||
|
: DIK_UP HEX: C8 ; inline
|
||||||
|
: DIK_PRIOR HEX: C9 ; inline
|
||||||
|
: DIK_LEFT HEX: CB ; inline
|
||||||
|
: DIK_RIGHT HEX: CD ; inline
|
||||||
|
: DIK_END HEX: CF ; inline
|
||||||
|
: DIK_DOWN HEX: D0 ; inline
|
||||||
|
: DIK_NEXT HEX: D1 ; inline
|
||||||
|
: DIK_INSERT HEX: D2 ; inline
|
||||||
|
: DIK_DELETE HEX: D3 ; inline
|
||||||
|
: DIK_LWIN HEX: DB ; inline
|
||||||
|
: DIK_RWIN HEX: DC ; inline
|
||||||
|
: DIK_APPS HEX: DD ; inline
|
||||||
|
: DIK_POWER HEX: DE ; inline
|
||||||
|
: DIK_SLEEP HEX: DF ; inline
|
||||||
|
: DIK_WAKE HEX: E3 ; inline
|
||||||
|
: DIK_WEBSEARCH HEX: E5 ; inline
|
||||||
|
: DIK_WEBFAVORITES HEX: E6 ; inline
|
||||||
|
: DIK_WEBREFRESH HEX: E7 ; inline
|
||||||
|
: DIK_WEBSTOP HEX: E8 ; inline
|
||||||
|
: DIK_WEBFORWARD HEX: E9 ; inline
|
||||||
|
: DIK_WEBBACK HEX: EA ; inline
|
||||||
|
: DIK_MYCOMPUTER HEX: EB ; inline
|
||||||
|
: DIK_MAIL HEX: EC ; inline
|
||||||
|
: DIK_MEDIASELECT HEX: ED ; inline
|
||||||
|
|
||||||
: create-dinput ( -- )
|
: DIK_BACKSPACE DIK_BACK ; inline
|
||||||
f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
|
: DIK_NUMPADSTAR DIK_MULTIPLY ; inline
|
||||||
f <void*> [ f DirectInput8Create ole32-error ] keep *void*
|
: DIK_LALT DIK_LMENU ; inline
|
||||||
+dinput+ set ;
|
: DIK_CAPSLOCK DIK_CAPITAL ; inline
|
||||||
|
: DIK_NUMPADMINUS DIK_SUBTRACT ; inline
|
||||||
|
: DIK_NUMPADPLUS DIK_ADD ; inline
|
||||||
|
: DIK_NUMPADPERIOD DIK_DECIMAL ; inline
|
||||||
|
: DIK_NUMPADSLASH DIK_DIVIDE ; inline
|
||||||
|
: DIK_RALT DIK_RMENU ; inline
|
||||||
|
: DIK_UPARROW DIK_UP ; inline
|
||||||
|
: DIK_PGUP DIK_PRIOR ; inline
|
||||||
|
: DIK_LEFTARROW DIK_LEFT ; inline
|
||||||
|
: DIK_RIGHTARROW DIK_RIGHT ; inline
|
||||||
|
: DIK_DOWNARROW DIK_DOWN ; inline
|
||||||
|
: DIK_PGDN DIK_NEXT ; inline
|
||||||
|
|
||||||
: delete-dinput ( -- )
|
: DIK_CIRCUMFLEX DIK_PREVTRACK ; inline
|
||||||
+dinput+ [ com-release f ] change ;
|
|
||||||
|
|
||||||
|
: DI8DEVTYPE_DEVICE HEX: 11 ; inline
|
||||||
|
: DI8DEVTYPE_MOUSE HEX: 12 ; inline
|
||||||
|
: DI8DEVTYPE_KEYBOARD HEX: 13 ; inline
|
||||||
|
: DI8DEVTYPE_JOYSTICK HEX: 14 ; inline
|
||||||
|
: DI8DEVTYPE_GAMEPAD HEX: 15 ; inline
|
||||||
|
: DI8DEVTYPE_DRIVING HEX: 16 ; inline
|
||||||
|
: DI8DEVTYPE_FLIGHT HEX: 17 ; inline
|
||||||
|
: DI8DEVTYPE_1STPERSON HEX: 18 ; inline
|
||||||
|
: DI8DEVTYPE_DEVICECTRL HEX: 19 ; inline
|
||||||
|
: DI8DEVTYPE_SCREENPOINTER HEX: 1A ; inline
|
||||||
|
: DI8DEVTYPE_REMOTE HEX: 1B ; inline
|
||||||
|
: DI8DEVTYPE_SUPPLEMENTAL HEX: 1C ; inline
|
||||||
|
|
||||||
|
: GET_DIDEVICE_TYPE ( dwType -- type ) HEX: FF bitand ; inline
|
||||||
|
|
||||||
|
: DIPROPRANGE_NOMIN HEX: 80000000 ; inline
|
||||||
|
: DIPROPRANGE_NOMAX HEX: 7FFFFFFF ; inline
|
||||||
|
: MAXCPOINTSNUM 8 ; inline
|
||||||
|
|
||||||
|
: DIPH_DEVICE 0 ; inline
|
||||||
|
: DIPH_BYOFFSET 1 ; inline
|
||||||
|
: DIPH_BYID 2 ; inline
|
||||||
|
: DIPH_BYUSAGE 3 ; inline
|
||||||
|
|
||||||
|
: DIMAKEUSAGEDWORD ( UsagePage Usage -- DWORD ) 16 shift bitor ; inline
|
||||||
|
|
||||||
|
: DIPROP_BUFFERSIZE 1 <alien> ; inline
|
||||||
|
: DIPROP_AXISMODE 2 <alien> ; inline
|
||||||
|
|
||||||
|
: DIPROPAXISMODE_ABS 0 ; inline
|
||||||
|
: DIPROPAXISMODE_REL 1 ; inline
|
||||||
|
|
||||||
|
: DIPROP_GRANULARITY 3 <alien> ; inline
|
||||||
|
: DIPROP_RANGE 4 <alien> ; inline
|
||||||
|
: DIPROP_DEADZONE 5 <alien> ; inline
|
||||||
|
: DIPROP_SATURATION 6 <alien> ; inline
|
||||||
|
: DIPROP_FFGAIN 7 <alien> ; inline
|
||||||
|
: DIPROP_FFLOAD 8 <alien> ; inline
|
||||||
|
: DIPROP_AUTOCENTER 9 <alien> ; inline
|
||||||
|
|
||||||
|
: DIPROPAUTOCENTER_OFF 0 ; inline
|
||||||
|
: DIPROPAUTOCENTER_ON 1 ; inline
|
||||||
|
|
||||||
|
: DIPROP_CALIBRATIONMODE 10 <alien> ; inline
|
||||||
|
|
||||||
|
: DIPROPCALIBRATIONMODE_COOKED 0 ; inline
|
||||||
|
: DIPROPCALIBRATIONMODE_RAW 1 ; inline
|
||||||
|
|
||||||
|
: DIPROP_CALIBRATION 11 <alien> ; inline
|
||||||
|
: DIPROP_GUIDANDPATH 12 <alien> ; inline
|
||||||
|
: DIPROP_INSTANCENAME 13 <alien> ; inline
|
||||||
|
: DIPROP_PRODUCTNAME 14 <alien> ; inline
|
||||||
|
: DIPROP_JOYSTICKID 15 <alien> ; inline
|
||||||
|
: DIPROP_GETPORTDISPLAYNAME 16 <alien> ; inline
|
||||||
|
: DIPROP_PHYSICALRANGE 18 <alien> ; inline
|
||||||
|
: DIPROP_LOGICALRANGE 19 <alien> ; inline
|
||||||
|
: DIPROP_KEYNAME 20 <alien> ; inline
|
||||||
|
: DIPROP_CPOINTS 21 <alien> ; inline
|
||||||
|
: DIPROP_APPDATA 22 <alien> ; inline
|
||||||
|
: DIPROP_SCANCODE 23 <alien> ; inline
|
||||||
|
: DIPROP_VIDPID 24 <alien> ; inline
|
||||||
|
: DIPROP_USERNAME 25 <alien> ; inline
|
||||||
|
: DIPROP_TYPENAME 26 <alien> ; inline
|
||||||
|
|
||||||
|
: GUID_XAxis GUID: {A36D02E0-C9F3-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_YAxis GUID: {A36D02E1-C9F3-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_ZAxis GUID: {A36D02E2-C9F3-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_RxAxis GUID: {A36D02F4-C9F3-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_RyAxis GUID: {A36D02F5-C9F3-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_RzAxis GUID: {A36D02E3-C9F3-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_Slider GUID: {A36D02E4-C9F3-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_Button GUID: {A36D02F0-C9F3-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_Key GUID: {55728220-D33C-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_POV GUID: {A36D02F2-C9F3-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_Unknown GUID: {A36D02F3-C9F3-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_SysMouse GUID: {6F1D2B60-D5A0-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_SysKeyboard GUID: {6F1D2B61-D5A0-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_Joystick GUID: {6F1D2B70-D5A0-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_SysMouseEm GUID: {6F1D2B80-D5A0-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_SysMouseEm2 GUID: {6F1D2B81-D5A0-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_SysKeyboardEm GUID: {6F1D2B82-D5A0-11CF-BFC7-444553540000} ; inline
|
||||||
|
: GUID_SysKeyboardEm2 GUID: {6F1D2B83-D5A0-11CF-BFC7-444553540000} ; inline
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
USING: alien alien.syntax alien.c-types alien.strings math
|
USING: alien alien.syntax alien.c-types alien.strings math
|
||||||
kernel sequences windows windows.types
|
kernel sequences windows windows.types debugger io accessors
|
||||||
math.order ;
|
math.order ;
|
||||||
IN: windows.ole32
|
IN: windows.ole32
|
||||||
|
|
||||||
|
|
@ -115,10 +115,14 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
|
||||||
: succeeded? ( hresult -- ? )
|
: succeeded? ( hresult -- ? )
|
||||||
0 HEX: 7FFFFFFF between? ;
|
0 HEX: 7FFFFFFF between? ;
|
||||||
|
|
||||||
|
TUPLE: ole32-error error-code ;
|
||||||
|
C: <ole32-error> ole32-error
|
||||||
|
|
||||||
|
M: ole32-error error.
|
||||||
|
"COM method failed: " print error-code>> (win32-error-string) print ;
|
||||||
|
|
||||||
: ole32-error ( hresult -- )
|
: ole32-error ( hresult -- )
|
||||||
dup succeeded? [
|
dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
|
||||||
drop
|
|
||||||
] [ (win32-error-string) throw ] if ;
|
|
||||||
|
|
||||||
: ole-initialize ( -- )
|
: ole-initialize ( -- )
|
||||||
f OleInitialize ole32-error ;
|
f OleInitialize ole32-error ;
|
||||||
|
|
|
||||||
|
|
@ -528,6 +528,27 @@ C-STRUCT: TRACKMOUSEEVENT
|
||||||
{ "DWORD" "dwHoverTime" } ;
|
{ "DWORD" "dwHoverTime" } ;
|
||||||
TYPEDEF: TRACKMOUSEEVENT* LPTRACKMOUSEEVENT
|
TYPEDEF: TRACKMOUSEEVENT* LPTRACKMOUSEEVENT
|
||||||
|
|
||||||
|
: DBT_DEVICEARRIVAL HEX: 8000 ; inline
|
||||||
|
: DBT_DEVICEREMOVECOMPLETE HEX: 8004 ; inline
|
||||||
|
|
||||||
|
: DBT_DEVTYP_DEVICEINTERFACE 5 ; inline
|
||||||
|
|
||||||
|
: DEVICE_NOTIFY_WINDOW_HANDLE 0 ; inline
|
||||||
|
: DEVICE_NOTIFY_SERVICE_HANDLE 1 ; inline
|
||||||
|
|
||||||
|
: DEVICE_NOTIFY_ALL_INTERFACE_CLASSES 4 ; inline
|
||||||
|
|
||||||
|
C-STRUCT: DEV_BROADCAST_HDR
|
||||||
|
{ "DWORD" "dbch_size" }
|
||||||
|
{ "DWORD" "dbch_devicetype" }
|
||||||
|
{ "DWORD" "dbch_reserved" } ;
|
||||||
|
C-STRUCT: DEV_BROADCAST_DEVICEW
|
||||||
|
{ "DWORD" "dbcc_size" }
|
||||||
|
{ "DWORD" "dbcc_devicetype" }
|
||||||
|
{ "DWORD" "dbcc_reserved" }
|
||||||
|
{ "GUID" "dbcc_classguid" }
|
||||||
|
{ "WCHAR[1]" "dbcc_name" } ;
|
||||||
|
|
||||||
LIBRARY: user32
|
LIBRARY: user32
|
||||||
|
|
||||||
FUNCTION: HKL ActivateKeyboardLayout ( HKL hkl, UINT Flags ) ;
|
FUNCTION: HKL ActivateKeyboardLayout ( HKL hkl, UINT Flags ) ;
|
||||||
|
|
@ -1176,8 +1197,9 @@ ALIAS: RegisterClassEx RegisterClassExW
|
||||||
|
|
||||||
! FUNCTION: RegisterClipboardFormatA
|
! FUNCTION: RegisterClipboardFormatA
|
||||||
! FUNCTION: RegisterClipboardFormatW
|
! FUNCTION: RegisterClipboardFormatW
|
||||||
! FUNCTION: RegisterDeviceNotificationA
|
FUNCTION: HANDLE RegisterDeviceNotificationA ( HANDLE hRecipient, LPVOID NotificationFilter, DWORD Flags ) ;
|
||||||
! FUNCTION: RegisterDeviceNotificationW
|
FUNCTION: HANDLE RegisterDeviceNotificationW ( HANDLE hRecipient, LPVOID NotificationFilter, DWORD Flags ) ;
|
||||||
|
ALIAS: RegisterDeviceNotification RegisterDeviceNotificationW
|
||||||
! FUNCTION: RegisterHotKey
|
! FUNCTION: RegisterHotKey
|
||||||
! FUNCTION: RegisterLogonProcess
|
! FUNCTION: RegisterLogonProcess
|
||||||
! FUNCTION: RegisterMessagePumpHook
|
! FUNCTION: RegisterMessagePumpHook
|
||||||
|
|
@ -1344,7 +1366,7 @@ FUNCTION: BOOL TranslateMessage ( MSG* lpMsg ) ;
|
||||||
! FUNCTION: UnpackDDElParam
|
! FUNCTION: UnpackDDElParam
|
||||||
FUNCTION: BOOL UnregisterClassW ( LPCWSTR lpClassName, HINSTANCE hInstance ) ;
|
FUNCTION: BOOL UnregisterClassW ( LPCWSTR lpClassName, HINSTANCE hInstance ) ;
|
||||||
ALIAS: UnregisterClass UnregisterClassW
|
ALIAS: UnregisterClass UnregisterClassW
|
||||||
! FUNCTION: UnregisterDeviceNotification
|
FUNCTION: BOOL UnregisterDeviceNotification ( HANDLE hDevNotify ) ;
|
||||||
! FUNCTION: UnregisterHotKey
|
! FUNCTION: UnregisterHotKey
|
||||||
! FUNCTION: UnregisterMessagePumpHook
|
! FUNCTION: UnregisterMessagePumpHook
|
||||||
! FUNCTION: UnregisterUserApiHook
|
! FUNCTION: UnregisterUserApiHook
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: namespaces disjoint-sets sequences assocs
|
USING: namespaces disjoint-sets sequences assocs math
|
||||||
kernel accessors fry
|
kernel accessors fry
|
||||||
compiler.tree compiler.tree.def-use compiler.tree.combinators ;
|
compiler.tree compiler.tree.def-use compiler.tree.combinators ;
|
||||||
IN: compiler.tree.copy-equiv
|
IN: compiler.tree.copy-equiv
|
||||||
|
|
@ -31,6 +31,16 @@ M: #r> compute-copy-equiv*
|
||||||
M: #copy compute-copy-equiv*
|
M: #copy compute-copy-equiv*
|
||||||
[ in-d>> ] [ out-d>> ] bi are-copies-of ;
|
[ in-d>> ] [ out-d>> ] bi are-copies-of ;
|
||||||
|
|
||||||
|
M: #return-recursive compute-copy-equiv*
|
||||||
|
[ in-d>> ] [ out-d>> ] bi are-copies-of ;
|
||||||
|
|
||||||
|
: unchanged-underneath ( #call-recursive -- n )
|
||||||
|
[ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
|
||||||
|
|
||||||
|
M: #call-recursive compute-copy-equiv*
|
||||||
|
[ in-d>> ] [ out-d>> ] [ unchanged-underneath ] tri
|
||||||
|
'[ , head ] bi@ are-copies-of ;
|
||||||
|
|
||||||
M: node compute-copy-equiv* drop ;
|
M: node compute-copy-equiv* drop ;
|
||||||
|
|
||||||
: compute-copy-equiv ( node -- node )
|
: compute-copy-equiv ( node -- node )
|
||||||
|
|
|
||||||
|
|
@ -21,9 +21,7 @@ M: #call mark-live-values
|
||||||
[ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
|
[ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
|
||||||
|
|
||||||
M: #return mark-live-values
|
M: #return mark-live-values
|
||||||
#! Values returned by local #recursive functions can be
|
look-at-inputs ;
|
||||||
#! killed if they're unused.
|
|
||||||
dup label>> [ drop ] [ look-at-inputs ] if ;
|
|
||||||
|
|
||||||
M: node mark-live-values drop ;
|
M: node mark-live-values drop ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -52,12 +52,16 @@ M: node node-defs-values out-d>> ;
|
||||||
[ dup node-uses-values [ use-value ] with each ]
|
[ dup node-uses-values [ use-value ] with each ]
|
||||||
[ dup node-defs-values [ def-value ] with each ] bi ;
|
[ dup node-defs-values [ def-value ] with each ] bi ;
|
||||||
|
|
||||||
|
: check-def ( node -- )
|
||||||
|
[ "No def" throw ] unless ;
|
||||||
|
|
||||||
|
: check-use ( uses -- )
|
||||||
|
[ empty? [ "No use" throw ] when ]
|
||||||
|
[ all-unique? [ "Uses not all unique" throw ] unless ] bi ;
|
||||||
|
|
||||||
: check-def-use ( -- )
|
: check-def-use ( -- )
|
||||||
def-use get [
|
def-use get [
|
||||||
nip
|
nip [ node>> check-def ] [ uses>> check-use ] bi
|
||||||
[ node>> [ "No def" throw ] unless ]
|
|
||||||
[ uses>> all-unique? [ "Uses not all unique" throw ] unless ]
|
|
||||||
bi
|
|
||||||
] assoc-each ;
|
] assoc-each ;
|
||||||
|
|
||||||
: compute-def-use ( node -- node )
|
: compute-def-use ( node -- node )
|
||||||
|
|
|
||||||
|
|
@ -59,5 +59,7 @@ IN: compiler.tree.propagation.info.tests
|
||||||
|
|
||||||
[ 3 t ] [
|
[ 3 t ] [
|
||||||
3 <literal-info>
|
3 <literal-info>
|
||||||
null <class-info> value-info-union >literal<
|
null-info value-info-union >literal<
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [ { } value-infos-union drop ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -27,6 +27,8 @@ literal?
|
||||||
length
|
length
|
||||||
slots ;
|
slots ;
|
||||||
|
|
||||||
|
: null-info T{ value-info f null empty-interval } ; inline
|
||||||
|
|
||||||
: class-interval ( class -- interval )
|
: class-interval ( class -- interval )
|
||||||
dup real class<=
|
dup real class<=
|
||||||
[ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
|
[ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
|
||||||
|
|
@ -113,6 +115,8 @@ slots ;
|
||||||
|
|
||||||
DEFER: value-info-intersect
|
DEFER: value-info-intersect
|
||||||
|
|
||||||
|
DEFER: (value-info-intersect)
|
||||||
|
|
||||||
: intersect-lengths ( info1 info2 -- length )
|
: intersect-lengths ( info1 info2 -- length )
|
||||||
[ length>> ] bi@ {
|
[ length>> ] bi@ {
|
||||||
{ [ dup not ] [ drop ] }
|
{ [ dup not ] [ drop ] }
|
||||||
|
|
@ -120,10 +124,17 @@ DEFER: value-info-intersect
|
||||||
[ value-info-intersect ]
|
[ value-info-intersect ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
|
: intersect-slot ( info1 info2 -- info )
|
||||||
|
{
|
||||||
|
{ [ dup not ] [ nip ] }
|
||||||
|
{ [ over not ] [ drop ] }
|
||||||
|
[ (value-info-intersect) ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
: intersect-slots ( info1 info2 -- slots )
|
: intersect-slots ( info1 info2 -- slots )
|
||||||
[ slots>> ] bi@
|
[ slots>> ] bi@
|
||||||
2dup [ length ] bi@ =
|
2dup [ length ] bi@ =
|
||||||
[ [ value-info-intersect ] 2map ] [ 2drop f ] if ;
|
[ [ intersect-slot ] 2map ] [ 2drop f ] if ;
|
||||||
|
|
||||||
: (value-info-intersect) ( info1 info2 -- info )
|
: (value-info-intersect) ( info1 info2 -- info )
|
||||||
[ <value-info> ] 2dip
|
[ <value-info> ] 2dip
|
||||||
|
|
@ -150,6 +161,8 @@ DEFER: value-info-intersect
|
||||||
|
|
||||||
DEFER: value-info-union
|
DEFER: value-info-union
|
||||||
|
|
||||||
|
DEFER: (value-info-union)
|
||||||
|
|
||||||
: union-lengths ( info1 info2 -- length )
|
: union-lengths ( info1 info2 -- length )
|
||||||
[ length>> ] bi@ {
|
[ length>> ] bi@ {
|
||||||
{ [ dup not ] [ nip ] }
|
{ [ dup not ] [ nip ] }
|
||||||
|
|
@ -157,10 +170,17 @@ DEFER: value-info-union
|
||||||
[ value-info-union ]
|
[ value-info-union ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
|
: union-slot ( info1 info2 -- info )
|
||||||
|
{
|
||||||
|
{ [ dup not ] [ nip ] }
|
||||||
|
{ [ over not ] [ drop ] }
|
||||||
|
[ (value-info-union) ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
: union-slots ( info1 info2 -- slots )
|
: union-slots ( info1 info2 -- slots )
|
||||||
[ slots>> ] bi@
|
[ slots>> ] bi@
|
||||||
2dup [ length ] bi@ =
|
2dup [ length ] bi@ =
|
||||||
[ [ value-info-union ] 2map ] [ 2drop f ] if ;
|
[ [ union-slot ] 2map ] [ 2drop f ] if ;
|
||||||
|
|
||||||
: (value-info-union) ( info1 info2 -- info )
|
: (value-info-union) ( info1 info2 -- info )
|
||||||
[ <value-info> ] 2dip
|
[ <value-info> ] 2dip
|
||||||
|
|
@ -181,14 +201,15 @@ DEFER: value-info-union
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: value-infos-union ( infos -- info )
|
: value-infos-union ( infos -- info )
|
||||||
dup first [ value-info-union ] reduce ;
|
dup empty?
|
||||||
|
[ drop null-info ]
|
||||||
|
[ dup first [ value-info-union ] reduce ] if ;
|
||||||
|
|
||||||
! Current value --> info mapping
|
! Current value --> info mapping
|
||||||
SYMBOL: value-infos
|
SYMBOL: value-infos
|
||||||
|
|
||||||
: value-info ( value -- info )
|
: value-info ( value -- info )
|
||||||
resolve-copy value-infos get at
|
resolve-copy value-infos get at null-info or ;
|
||||||
T{ value-info f null empty-interval } or ;
|
|
||||||
|
|
||||||
: set-value-info ( info value -- )
|
: set-value-info ( info value -- )
|
||||||
resolve-copy value-infos get set-at ;
|
resolve-copy value-infos get set-at ;
|
||||||
|
|
@ -213,3 +234,12 @@ SYMBOL: value-infos
|
||||||
|
|
||||||
: value-is? ( value class -- ? )
|
: value-is? ( value class -- ? )
|
||||||
[ value-info class>> ] dip class<= ;
|
[ value-info class>> ] dip class<= ;
|
||||||
|
|
||||||
|
: node-value-info ( node value -- info )
|
||||||
|
swap info>> at* [ drop null-info ] unless ;
|
||||||
|
|
||||||
|
: node-input-infos ( node -- seq )
|
||||||
|
dup in-d>> [ node-value-info ] with map ;
|
||||||
|
|
||||||
|
: node-output-infos ( node -- seq )
|
||||||
|
dup out-d>> [ node-value-info ] with map ;
|
||||||
|
|
|
||||||
|
|
@ -4,9 +4,10 @@ USING: kernel effects accessors math math.private math.libm
|
||||||
math.partial-dispatch math.intervals math.parser math.order
|
math.partial-dispatch math.intervals math.parser math.order
|
||||||
layouts words sequences sequences.private arrays assocs classes
|
layouts words sequences sequences.private arrays assocs classes
|
||||||
classes.algebra combinators generic.math splitting fry locals
|
classes.algebra combinators generic.math splitting fry locals
|
||||||
classes.tuple alien.accessors classes.tuple.private
|
classes.tuple alien.accessors classes.tuple.private slots.private
|
||||||
compiler.tree.propagation.info compiler.tree.propagation.nodes
|
compiler.tree.propagation.info compiler.tree.propagation.nodes
|
||||||
compiler.tree.propagation.constraints
|
compiler.tree.propagation.constraints
|
||||||
|
compiler.tree.propagation.slots
|
||||||
compiler.tree.comparisons ;
|
compiler.tree.comparisons ;
|
||||||
IN: compiler.tree.propagation.known-words
|
IN: compiler.tree.propagation.known-words
|
||||||
|
|
||||||
|
|
@ -258,3 +259,8 @@ generic-comparison-ops [
|
||||||
|
|
||||||
! the output of clone has the same type as the input
|
! the output of clone has the same type as the input
|
||||||
{ clone (clone) } [ [ ] +outputs+ set-word-prop ] each
|
{ clone (clone) } [ [ ] +outputs+ set-word-prop ] each
|
||||||
|
|
||||||
|
\ slot [
|
||||||
|
dup literal?>>
|
||||||
|
[ literal>> swap value-info-slot ] [ 2drop object <class-info> ] if
|
||||||
|
] +outputs+ set-word-prop
|
||||||
|
|
|
||||||
|
|
@ -16,6 +16,7 @@ GENERIC: propagate-around ( node -- )
|
||||||
|
|
||||||
: (propagate) ( node -- )
|
: (propagate) ( node -- )
|
||||||
[
|
[
|
||||||
|
USING: classes prettyprint ; dup class .
|
||||||
[ propagate-around ] [ successor>> ] bi
|
[ propagate-around ] [ successor>> ] bi
|
||||||
(propagate)
|
(propagate)
|
||||||
] when* ;
|
] when* ;
|
||||||
|
|
|
||||||
|
|
@ -3,8 +3,9 @@ compiler.tree.propagation compiler.tree.copy-equiv
|
||||||
compiler.tree.def-use tools.test math math.order
|
compiler.tree.def-use tools.test math math.order
|
||||||
accessors sequences arrays kernel.private vectors
|
accessors sequences arrays kernel.private vectors
|
||||||
alien.accessors alien.c-types sequences.private
|
alien.accessors alien.c-types sequences.private
|
||||||
byte-arrays classes.algebra math.functions math.private
|
byte-arrays classes.algebra classes.tuple.private
|
||||||
strings ;
|
math.functions math.private strings layouts
|
||||||
|
compiler.tree.propagation.info ;
|
||||||
IN: compiler.tree.propagation.tests
|
IN: compiler.tree.propagation.tests
|
||||||
|
|
||||||
\ propagate must-infer
|
\ propagate must-infer
|
||||||
|
|
@ -235,12 +236,39 @@ IN: compiler.tree.propagation.tests
|
||||||
[ [ 1 ] [ 1 ] if 1 + ] final-literals
|
[ [ 1 ] [ 1 ] if 1 + ] final-literals
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ V{ object } ] [
|
||||||
|
[ 0 * 10 < ] final-classes
|
||||||
|
] unit-test
|
||||||
|
|
||||||
[ V{ string string } ] [
|
[ V{ string string } ] [
|
||||||
[
|
[
|
||||||
2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
|
2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
|
||||||
] final-classes
|
] final-classes
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ V{ float } ] [
|
||||||
|
[ { real float } declare + ] final-classes
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ V{ float } ] [
|
||||||
|
[ { float real } declare + ] final-classes
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ V{ fixnum } ] [
|
||||||
|
[ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ V{ fixnum } ] [
|
||||||
|
[ { fixnum } declare 1 swap 7 bitand shift ] final-classes
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
cell-bits 32 = [
|
||||||
|
[ V{ integer } ] [
|
||||||
|
[ { fixnum } declare 1 swap 31 bitand shift ]
|
||||||
|
final-classes
|
||||||
|
] unit-test
|
||||||
|
] when
|
||||||
|
|
||||||
! Array length propagation
|
! Array length propagation
|
||||||
[ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
|
[ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
|
||||||
|
|
||||||
|
|
@ -323,6 +351,10 @@ TUPLE: mutable-tuple-test { x sequence } ;
|
||||||
[ T{ mutable-tuple-test f "hey" } x>> ] final-classes
|
[ T{ mutable-tuple-test f "hey" } x>> ] final-classes
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ V{ tuple-layout } ] [
|
||||||
|
[ T{ mutable-tuple-test f "hey" } layout-of ] final-classes
|
||||||
|
] unit-test
|
||||||
|
|
||||||
! Mixed mutable and immutable slots
|
! Mixed mutable and immutable slots
|
||||||
TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
|
TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
|
||||||
|
|
||||||
|
|
@ -332,3 +364,45 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
|
||||||
[ x>> ] [ y>> ] bi
|
[ x>> ] [ y>> ] bi
|
||||||
] final-classes
|
] final-classes
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
! Recursive propagation
|
||||||
|
: recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
|
||||||
|
|
||||||
|
[ V{ null } ] [ [ recursive-test-1 ] final-classes ] unit-test
|
||||||
|
|
||||||
|
: recursive-test-2 ( a -- b ) dup 10 < [ recursive-test-2 ] when ; inline recursive
|
||||||
|
|
||||||
|
[ V{ real } ] [ [ recursive-test-2 ] final-classes ] unit-test
|
||||||
|
|
||||||
|
: recursive-test-3 ( a -- b ) dup 10 < drop ; inline recursive
|
||||||
|
|
||||||
|
[ V{ real } ] [ [ recursive-test-3 ] final-classes ] unit-test
|
||||||
|
|
||||||
|
[ V{ real } ] [ [ [ dup 10 < ] [ ] [ ] while ] final-classes ] unit-test
|
||||||
|
|
||||||
|
[ V{ float } ] [
|
||||||
|
[ { float } declare 10 [ 2.3 * ] times ] final-classes
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ V{ fixnum } ] [
|
||||||
|
[ 0 10 [ nip ] each-integer ] final-classes
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ V{ t } ] [
|
||||||
|
[ t 10 [ nip 0 >= ] each-integer ] final-literals
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
: recursive-test-4 ( i n -- )
|
||||||
|
2dup < [ >r 1+ r> recursive-test-4 ] [ 2drop ] if ; inline recursive
|
||||||
|
|
||||||
|
[ ] [ [ recursive-test-4 ] final-info drop ] unit-test
|
||||||
|
|
||||||
|
: recursive-test-5 ( a -- b )
|
||||||
|
dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-5 * ] if ; inline recursive
|
||||||
|
|
||||||
|
[ V{ integer } ] [ [ { integer } declare recursive-test-5 ] final-classes ] unit-test
|
||||||
|
|
||||||
|
: recursive-test-6 ( a -- b )
|
||||||
|
dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-6 swap 2 - recursive-test-6 + ] if ; inline recursive
|
||||||
|
|
||||||
|
[ V{ integer } ] [ [ { fixnum } declare recursive-test-6 ] final-classes ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,8 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel sequences accessors
|
USING: kernel sequences accessors arrays fry math.intervals
|
||||||
|
combinators
|
||||||
|
stack-checker.inlining
|
||||||
compiler.tree
|
compiler.tree
|
||||||
compiler.tree.propagation.info
|
compiler.tree.propagation.info
|
||||||
compiler.tree.propagation.nodes
|
compiler.tree.propagation.nodes
|
||||||
|
|
@ -8,29 +10,75 @@ compiler.tree.propagation.simple
|
||||||
compiler.tree.propagation.branches ;
|
compiler.tree.propagation.branches ;
|
||||||
IN: compiler.tree.propagation.recursive
|
IN: compiler.tree.propagation.recursive
|
||||||
|
|
||||||
! What if we reach a fixed point for the phi but not for the
|
! row polymorphism is causing problems
|
||||||
! #call-label output?
|
|
||||||
|
|
||||||
! We need to compute scalar evolution so that sccp doesn't
|
: longest-suffix ( seq1 seq2 -- seq1' seq2' )
|
||||||
! evaluate loops
|
2dup min-length [ tail-slice* ] curry bi@ ;
|
||||||
|
|
||||||
: (merge-value-infos) ( inputs -- infos )
|
: suffixes= ( seq1 seq2 -- ? )
|
||||||
[ [ value-info ] map value-infos-union ] map ;
|
longest-suffix sequence= ;
|
||||||
|
|
||||||
: merge-value-infos ( inputs outputs -- fixed-point? )
|
: check-fixed-point ( node infos1 infos2 -- node )
|
||||||
[ (merge-value-infos) ] dip
|
suffixes= [ dup label>> f >>fixed-point drop ] unless ; inline
|
||||||
[ 2dup value-info = [ 2drop t ] [ set-value-info f ] if ] 2all? ;
|
|
||||||
|
|
||||||
: propagate-recursive-phi ( #phi -- fixed-point? )
|
: recursive-stacks ( #enter-recursive -- stacks initial )
|
||||||
[ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
|
[ label>> calls>> [ node-input-infos ] map ]
|
||||||
[ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
|
[ in-d>> [ value-info ] map ] bi
|
||||||
bi and ;
|
[ length '[ , tail* ] map flip ] keep ;
|
||||||
|
|
||||||
|
: generalize-counter-interval ( i1 i2 -- i3 )
|
||||||
|
{
|
||||||
|
{ [ 2dup interval<= ] [ 1./0. [a,a] ] }
|
||||||
|
{ [ 2dup interval>= ] [ -1./0. [a,a] ] }
|
||||||
|
[ [-inf,inf] ]
|
||||||
|
} cond nip interval-union ;
|
||||||
|
|
||||||
|
: generalize-counter ( info' initial -- info )
|
||||||
|
[ drop clone ] [ [ interval>> ] bi@ ] 2bi
|
||||||
|
generalize-counter-interval >>interval
|
||||||
|
f >>literal? f >>literal ;
|
||||||
|
|
||||||
|
: unify-recursive-stacks ( stacks initial -- infos )
|
||||||
|
over empty? [ nip ] [
|
||||||
|
[
|
||||||
|
[ sift value-infos-union ] dip
|
||||||
|
[ generalize-counter ] keep
|
||||||
|
value-info-union
|
||||||
|
] 2map
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: propagate-recursive-phi ( #enter-recursive -- )
|
||||||
|
[ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri
|
||||||
|
[ node-output-infos check-fixed-point drop ] 2keep
|
||||||
|
out-d>> set-value-infos ;
|
||||||
|
|
||||||
|
USING: namespaces math ;
|
||||||
|
SYMBOL: iter-counter
|
||||||
|
0 iter-counter set-global
|
||||||
M: #recursive propagate-around ( #recursive -- )
|
M: #recursive propagate-around ( #recursive -- )
|
||||||
dup
|
iter-counter inc
|
||||||
node-child
|
iter-counter get 10 > [ "Oops" throw ] when
|
||||||
[ first>> (propagate) ] [ propagate-recursive-phi ] bi
|
dup label>> t >>fixed-point drop
|
||||||
[ drop ] [ propagate-around ] if ;
|
[ node-child first>> [ propagate-recursive-phi ] [ (propagate) ] bi ]
|
||||||
|
[ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ]
|
||||||
|
bi ;
|
||||||
|
|
||||||
|
: generalize-return-interval ( info -- info' )
|
||||||
|
dup literal?>> [
|
||||||
|
clone [-inf,inf] >>interval
|
||||||
|
] unless ;
|
||||||
|
|
||||||
|
: generalize-return ( infos -- infos' )
|
||||||
|
[ generalize-return-interval ] map ;
|
||||||
|
|
||||||
M: #call-recursive propagate-before ( #call-label -- )
|
M: #call-recursive propagate-before ( #call-label -- )
|
||||||
[ label>> returns>> flip ] [ out-d>> ] bi merge-value-infos drop ;
|
dup
|
||||||
|
[ node-output-infos ]
|
||||||
|
[ label>> return>> node-input-infos ]
|
||||||
|
bi check-fixed-point
|
||||||
|
[ label>> return>> node-input-infos generalize-return ] [ out-d>> ] bi
|
||||||
|
longest-suffix set-value-infos ;
|
||||||
|
|
||||||
|
M: #return-recursive propagate-before ( #return-recursive -- )
|
||||||
|
dup [ node-input-infos ] [ in-d>> [ value-info ] map ] bi
|
||||||
|
check-fixed-point drop ;
|
||||||
|
|
|
||||||
|
|
@ -39,15 +39,25 @@ UNION: fixed-length-sequence array byte-array string ;
|
||||||
: tuple-constructor? ( node -- ? )
|
: tuple-constructor? ( node -- ? )
|
||||||
word>> { <tuple-boa> <complex> } memq? ;
|
word>> { <tuple-boa> <complex> } memq? ;
|
||||||
|
|
||||||
|
: read-only-slots ( values class -- slots )
|
||||||
|
#! Delegation.
|
||||||
|
all-slots rest-slice
|
||||||
|
[ read-only>> [ drop f ] unless ] 2map
|
||||||
|
{ f f } prepend ;
|
||||||
|
|
||||||
|
: fold-<tuple-boa> ( values class -- info )
|
||||||
|
[ , f , [ literal>> ] map % ] { } make >tuple
|
||||||
|
<literal-info> ;
|
||||||
|
|
||||||
: propagate-<tuple-boa> ( node -- info )
|
: propagate-<tuple-boa> ( node -- info )
|
||||||
#! Delegation
|
#! Delegation
|
||||||
in-d>> [ value-info ] map unclip-last
|
in-d>> [ value-info ] map unclip-last
|
||||||
literal>> class>> dup immutable-tuple-class? [
|
literal>> class>> [ read-only-slots ] keep
|
||||||
over [ literal?>> ] all?
|
over 2 tail-slice [ dup [ literal?>> ] when ] all? [
|
||||||
[ [ , f , [ literal>> ] map % ] { } make >tuple <literal-info> ]
|
[ 2 tail-slice ] dip fold-<tuple-boa>
|
||||||
[ <tuple-info> ]
|
] [
|
||||||
if
|
<tuple-info>
|
||||||
] [ nip <class-info> ] if ;
|
] if ;
|
||||||
|
|
||||||
: propagate-<complex> ( node -- info )
|
: propagate-<complex> ( node -- info )
|
||||||
in-d>> [ value-info ] map complex <tuple-info> ;
|
in-d>> [ value-info ] map complex <tuple-info> ;
|
||||||
|
|
@ -67,7 +77,7 @@ UNION: fixed-length-sequence array byte-array string ;
|
||||||
relevant-methods [ nip "reading" word-prop ] { } assoc>map ;
|
relevant-methods [ nip "reading" word-prop ] { } assoc>map ;
|
||||||
|
|
||||||
: no-reader-methods ( input slots -- info )
|
: no-reader-methods ( input slots -- info )
|
||||||
2drop null <class-info> ;
|
2drop null-info ;
|
||||||
|
|
||||||
: same-offset ( slots -- slot/f )
|
: same-offset ( slots -- slot/f )
|
||||||
dup [ dup [ read-only>> ] when ] all? [
|
dup [ dup [ read-only>> ] when ] all? [
|
||||||
|
|
@ -79,20 +89,29 @@ UNION: fixed-length-sequence array byte-array string ;
|
||||||
[ [ class>> ] [ object ] if* class-or ] reduce
|
[ [ class>> ] [ object ] if* class-or ] reduce
|
||||||
<class-info> ;
|
<class-info> ;
|
||||||
|
|
||||||
: value-info-slot ( slot info -- info' )
|
: tuple>array* ( tuple -- array )
|
||||||
#! Delegation.
|
prepare-tuple>array
|
||||||
[ class>> complex class<= 1 3 ? - ] keep
|
>r copy-tuple-slots r>
|
||||||
dup literal?>> [
|
prefix ;
|
||||||
literal>> {
|
|
||||||
|
: literal-info-slot ( slot info -- info' )
|
||||||
|
{
|
||||||
{ [ dup tuple? ] [
|
{ [ dup tuple? ] [
|
||||||
tuple-slots 1 tail-slice nth <literal-info>
|
tuple>array* nth <literal-info>
|
||||||
] }
|
] }
|
||||||
{ [ dup complex? ] [
|
{ [ dup complex? ] [
|
||||||
[ real-part ] [ imaginary-part ] bi
|
[ real-part ] [ imaginary-part ] bi
|
||||||
2array nth <literal-info>
|
2array nth <literal-info>
|
||||||
] }
|
] }
|
||||||
} cond
|
} cond ;
|
||||||
] [ slots>> ?nth ] if ;
|
|
||||||
|
: value-info-slot ( slot info -- info' )
|
||||||
|
#! Delegation.
|
||||||
|
{
|
||||||
|
{ [ over 0 = ] [ 2drop fixnum <class-info> ] }
|
||||||
|
{ [ dup literal?>> ] [ [ 1- ] [ literal>> ] bi* literal-info-slot ] }
|
||||||
|
[ [ 1- ] [ slots>> ] bi* ?nth ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
: reader-word-outputs ( node -- infos )
|
: reader-word-outputs ( node -- infos )
|
||||||
[ relevant-slots ] [ in-d>> first ] bi
|
[ relevant-slots ] [ in-d>> first ] bi
|
||||||
|
|
|
||||||
|
|
@ -35,15 +35,6 @@ M: node hashcode* drop node hashcode* ;
|
||||||
2drop f
|
2drop f
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: node-value-info ( node value -- info )
|
|
||||||
swap info>> at ;
|
|
||||||
|
|
||||||
: node-input-infos ( node -- seq )
|
|
||||||
dup in-d>> [ node-value-info ] with map ;
|
|
||||||
|
|
||||||
: node-output-infos ( node -- seq )
|
|
||||||
dup out-d>> [ node-value-info ] with map ;
|
|
||||||
|
|
||||||
TUPLE: #introduce < node values ;
|
TUPLE: #introduce < node values ;
|
||||||
|
|
||||||
: #introduce ( values -- node )
|
: #introduce ( values -- node )
|
||||||
|
|
@ -99,7 +90,9 @@ TUPLE: #r> < node ;
|
||||||
|
|
||||||
TUPLE: #terminate < node ;
|
TUPLE: #terminate < node ;
|
||||||
|
|
||||||
: #terminate ( -- node ) \ #terminate new ;
|
: #terminate ( stack -- node )
|
||||||
|
\ #terminate new
|
||||||
|
swap >>in-d ;
|
||||||
|
|
||||||
TUPLE: #branch < node ;
|
TUPLE: #branch < node ;
|
||||||
|
|
||||||
|
|
@ -133,23 +126,37 @@ TUPLE: #declare < node declaration ;
|
||||||
\ #declare new
|
\ #declare new
|
||||||
swap >>declaration ;
|
swap >>declaration ;
|
||||||
|
|
||||||
TUPLE: #return < node label ;
|
TUPLE: #return < node ;
|
||||||
|
|
||||||
: #return ( label stack -- node )
|
: #return ( stack -- node )
|
||||||
\ #return new
|
\ #return new
|
||||||
swap >>in-d
|
swap >>in-d ;
|
||||||
swap >>label ;
|
|
||||||
|
|
||||||
TUPLE: #recursive < node word label loop? returns calls ;
|
TUPLE: #recursive < node word label loop? returns calls ;
|
||||||
|
|
||||||
: #recursive ( word label inputs outputs child -- node )
|
: #recursive ( word label inputs child -- node )
|
||||||
\ #recursive new
|
\ #recursive new
|
||||||
swap 1array >>children
|
swap 1array >>children
|
||||||
swap >>out-d
|
|
||||||
swap >>in-d
|
swap >>in-d
|
||||||
swap >>label
|
swap >>label
|
||||||
swap >>word ;
|
swap >>word ;
|
||||||
|
|
||||||
|
TUPLE: #enter-recursive < node label ;
|
||||||
|
|
||||||
|
: #enter-recursive ( label inputs outputs -- node )
|
||||||
|
\ #enter-recursive new
|
||||||
|
swap >>out-d
|
||||||
|
swap >>in-d
|
||||||
|
swap >>label ;
|
||||||
|
|
||||||
|
TUPLE: #return-recursive < node label ;
|
||||||
|
|
||||||
|
: #return-recursive ( label inputs outputs -- node )
|
||||||
|
\ #return-recursive new
|
||||||
|
swap >>out-d
|
||||||
|
swap >>in-d
|
||||||
|
swap >>label ;
|
||||||
|
|
||||||
TUPLE: #copy < node ;
|
TUPLE: #copy < node ;
|
||||||
|
|
||||||
: #copy ( inputs outputs -- node )
|
: #copy ( inputs outputs -- node )
|
||||||
|
|
@ -175,13 +182,15 @@ TUPLE: node-list first last ;
|
||||||
M: node-list child-visitor node-list new ;
|
M: node-list child-visitor node-list new ;
|
||||||
M: node-list #introduce, #introduce node, ;
|
M: node-list #introduce, #introduce node, ;
|
||||||
M: node-list #call, #call node, ;
|
M: node-list #call, #call node, ;
|
||||||
M: node-list #call-recursive, #call-recursive node, ;
|
|
||||||
M: node-list #push, #push node, ;
|
M: node-list #push, #push node, ;
|
||||||
M: node-list #shuffle, #shuffle node, ;
|
M: node-list #shuffle, #shuffle node, ;
|
||||||
M: node-list #drop, #drop node, ;
|
M: node-list #drop, #drop node, ;
|
||||||
M: node-list #>r, #>r node, ;
|
M: node-list #>r, #>r node, ;
|
||||||
M: node-list #r>, #r> node, ;
|
M: node-list #r>, #r> node, ;
|
||||||
M: node-list #return, #return node, ;
|
M: node-list #return, #return node, ;
|
||||||
|
M: node-list #enter-recursive, #enter-recursive node, ;
|
||||||
|
M: node-list #return-recursive, #return-recursive [ node, ] [ dup label>> (>>return) ] bi ;
|
||||||
|
M: node-list #call-recursive, #call-recursive [ node, ] [ dup label>> calls>> push ] bi ;
|
||||||
M: node-list #terminate, #terminate node, ;
|
M: node-list #terminate, #terminate node, ;
|
||||||
M: node-list #if, #if node, ;
|
M: node-list #if, #if node, ;
|
||||||
M: node-list #dispatch, #dispatch node, ;
|
M: node-list #dispatch, #dispatch node, ;
|
||||||
|
|
|
||||||
|
|
@ -29,8 +29,7 @@ M: #call compute-untupling*
|
||||||
[ drop mark-escaping-values ]
|
[ drop mark-escaping-values ]
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
M: #return compute-untupling*
|
M: #return compute-untupling* mark-escaping-values ;
|
||||||
dup label>> [ drop ] [ mark-escaping-values ] if ;
|
|
||||||
|
|
||||||
M: node compute-untupling* drop ;
|
M: node compute-untupling* drop ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -82,7 +82,7 @@ M: wrapper apply-object
|
||||||
M: object apply-object push-literal ;
|
M: object apply-object push-literal ;
|
||||||
|
|
||||||
: terminate ( -- )
|
: terminate ( -- )
|
||||||
terminated? on #terminate, ;
|
terminated? on meta-d get clone #terminate, ;
|
||||||
|
|
||||||
: infer-quot ( quot rstate -- )
|
: infer-quot ( quot rstate -- )
|
||||||
recursive-state get [
|
recursive-state get [
|
||||||
|
|
@ -113,10 +113,10 @@ M: object apply-object push-literal ;
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: infer->r ( n -- )
|
: infer->r ( n -- )
|
||||||
consume-d [ dup copy-values #>r, ] [ output-r ] bi ;
|
consume-d dup copy-values [ #>r, ] [ nip output-r ] 2bi ;
|
||||||
|
|
||||||
: infer-r> ( n -- )
|
: infer-r> ( n -- )
|
||||||
consume-r [ dup copy-values #r>, ] [ output-d ] bi ;
|
consume-r dup copy-values [ #r>, ] [ nip output-d ] 2bi ;
|
||||||
|
|
||||||
: undo-infer ( -- )
|
: undo-infer ( -- )
|
||||||
recorded get [ f +inferred-effect+ set-word-prop ] each ;
|
recorded get [ f +inferred-effect+ set-word-prop ] each ;
|
||||||
|
|
@ -140,7 +140,7 @@ M: object apply-object push-literal ;
|
||||||
|
|
||||||
: end-infer ( -- )
|
: end-infer ( -- )
|
||||||
check->r
|
check->r
|
||||||
f meta-d get clone #return, ;
|
meta-d get clone #return, ;
|
||||||
|
|
||||||
: effect-required? ( word -- ? )
|
: effect-required? ( word -- ? )
|
||||||
{
|
{
|
||||||
|
|
|
||||||
|
|
@ -2,6 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: fry namespaces assocs kernel sequences words accessors
|
USING: fry namespaces assocs kernel sequences words accessors
|
||||||
definitions math effects classes arrays combinators vectors
|
definitions math effects classes arrays combinators vectors
|
||||||
|
arrays
|
||||||
stack-checker.state
|
stack-checker.state
|
||||||
stack-checker.visitor
|
stack-checker.visitor
|
||||||
stack-checker.backend
|
stack-checker.backend
|
||||||
|
|
@ -16,12 +17,12 @@ IN: stack-checker.inlining
|
||||||
: (inline-word) ( word label -- )
|
: (inline-word) ( word label -- )
|
||||||
[ [ def>> ] keep ] dip infer-quot-recursive ;
|
[ [ def>> ] keep ] dip infer-quot-recursive ;
|
||||||
|
|
||||||
TUPLE: inline-recursive word phi-in phi-out returns ;
|
TUPLE: inline-recursive word enter-out return calls fixed-point ;
|
||||||
|
|
||||||
: <inline-recursive> ( word -- label )
|
: <inline-recursive> ( word -- label )
|
||||||
inline-recursive new
|
inline-recursive new
|
||||||
swap >>word
|
swap >>word
|
||||||
V{ } clone >>returns ;
|
V{ } clone >>calls ;
|
||||||
|
|
||||||
: quotation-param? ( obj -- ? )
|
: quotation-param? ( obj -- ? )
|
||||||
dup pair? [ second effect? ] [ drop f ] if ;
|
dup pair? [ second effect? ] [ drop f ] if ;
|
||||||
|
|
@ -29,23 +30,20 @@ TUPLE: inline-recursive word phi-in phi-out returns ;
|
||||||
: make-copies ( values effect-in -- values' )
|
: make-copies ( values effect-in -- values' )
|
||||||
[ quotation-param? [ copy-value ] [ drop <value> ] if ] 2map ;
|
[ quotation-param? [ copy-value ] [ drop <value> ] if ] 2map ;
|
||||||
|
|
||||||
SYMBOL: phi-in
|
SYMBOL: enter-in
|
||||||
SYMBOL: phi-out
|
SYMBOL: enter-out
|
||||||
|
|
||||||
: prepare-stack ( word -- )
|
: prepare-stack ( word -- )
|
||||||
required-stack-effect in>> [ length ensure-d ] keep
|
required-stack-effect in>> [ length ensure-d ] keep
|
||||||
[ drop 1vector phi-in set ]
|
[ drop enter-in set ] [ make-copies enter-out set ] 2bi ;
|
||||||
[ make-copies phi-out set ]
|
|
||||||
2bi ;
|
|
||||||
|
|
||||||
: emit-phi-function ( label -- )
|
: emit-enter-recursive ( label -- )
|
||||||
phi-in get >>phi-in
|
enter-out get >>enter-out
|
||||||
phi-out get >>phi-out drop
|
enter-in get enter-out get #enter-recursive,
|
||||||
phi-in get phi-out get { { } } { } #phi,
|
enter-out get >vector meta-d set ;
|
||||||
phi-out get >vector meta-d set ;
|
|
||||||
|
|
||||||
: entry-stack-height ( label -- stack )
|
: entry-stack-height ( label -- stack )
|
||||||
phi-out>> length ;
|
enter-out>> length ;
|
||||||
|
|
||||||
: check-return ( word label -- )
|
: check-return ( word label -- )
|
||||||
2dup
|
2dup
|
||||||
|
|
@ -59,7 +57,7 @@ SYMBOL: phi-out
|
||||||
|
|
||||||
: end-recursive-word ( word label -- )
|
: end-recursive-word ( word label -- )
|
||||||
[ check-return ]
|
[ check-return ]
|
||||||
[ meta-d get [ #return, ] [ swap returns>> push ] 2bi ]
|
[ meta-d get dup copy-values dup meta-d set #return-recursive, ]
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
: recursive-word-inputs ( label -- n )
|
: recursive-word-inputs ( label -- n )
|
||||||
|
|
@ -72,7 +70,7 @@ SYMBOL: phi-out
|
||||||
nest-visitor
|
nest-visitor
|
||||||
|
|
||||||
dup <inline-recursive>
|
dup <inline-recursive>
|
||||||
[ dup emit-phi-function (inline-word) ]
|
[ dup emit-enter-recursive (inline-word) ]
|
||||||
[ end-recursive-word ]
|
[ end-recursive-word ]
|
||||||
[ ]
|
[ ]
|
||||||
2tri
|
2tri
|
||||||
|
|
@ -86,7 +84,7 @@ SYMBOL: phi-out
|
||||||
|
|
||||||
: inline-recursive-word ( word -- )
|
: inline-recursive-word ( word -- )
|
||||||
(inline-recursive-word)
|
(inline-recursive-word)
|
||||||
[ consume-d ] [ dup output-d ] [ ] tri* #recursive, ;
|
[ consume-d ] [ output-d ] [ ] tri* #recursive, ;
|
||||||
|
|
||||||
: check-call-height ( word label -- )
|
: check-call-height ( word label -- )
|
||||||
entry-stack-height current-stack-height >
|
entry-stack-height current-stack-height >
|
||||||
|
|
@ -96,18 +94,13 @@ SYMBOL: phi-out
|
||||||
required-stack-effect in>> length meta-d get swap tail* ;
|
required-stack-effect in>> length meta-d get swap tail* ;
|
||||||
|
|
||||||
: check-call-site-stack ( stack label -- )
|
: check-call-site-stack ( stack label -- )
|
||||||
tuck phi-out>>
|
tuck enter-out>>
|
||||||
[ dup known [ [ known ] bi@ = ] [ 2drop t ] if ] 2all?
|
[ dup known [ [ known ] bi@ = ] [ 2drop t ] if ] 2all?
|
||||||
[ drop ] [ word>> inconsistent-recursive-call-error inference-error ] if ;
|
[ drop ] [ word>> inconsistent-recursive-call-error inference-error ] if ;
|
||||||
|
|
||||||
: add-call ( word label -- )
|
: add-call ( word label -- )
|
||||||
[ check-call-height ]
|
[ check-call-height ]
|
||||||
[
|
[ [ call-site-stack ] dip check-call-site-stack ] 2bi ;
|
||||||
[ call-site-stack ] dip
|
|
||||||
[ check-call-site-stack ]
|
|
||||||
[ phi-in>> swap [ suffix ] 2change-each ]
|
|
||||||
2bi
|
|
||||||
] 2bi ;
|
|
||||||
|
|
||||||
: adjust-stack-effect ( effect -- effect' )
|
: adjust-stack-effect ( effect -- effect' )
|
||||||
[ in>> ] [ out>> ] bi
|
[ in>> ] [ out>> ] bi
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,8 @@ USING: fry accessors arrays kernel words sequences generic math
|
||||||
namespaces quotations assocs combinators classes.tuple
|
namespaces quotations assocs combinators classes.tuple
|
||||||
classes.tuple.private effects summary hashtables classes generic
|
classes.tuple.private effects summary hashtables classes generic
|
||||||
sets definitions generic.standard slots.private continuations
|
sets definitions generic.standard slots.private continuations
|
||||||
stack-checker.backend stack-checker.state stack-checker.errors ;
|
stack-checker.backend stack-checker.state stack-checker.visitor
|
||||||
|
stack-checker.errors ;
|
||||||
IN: stack-checker.transforms
|
IN: stack-checker.transforms
|
||||||
|
|
||||||
SYMBOL: +transform-quot+
|
SYMBOL: +transform-quot+
|
||||||
|
|
@ -15,8 +16,9 @@ SYMBOL: +transform-n+
|
||||||
drop recursive-state get 1array
|
drop recursive-state get 1array
|
||||||
] [
|
] [
|
||||||
consume-d
|
consume-d
|
||||||
|
[ #drop, ]
|
||||||
[ [ literal value>> ] map ]
|
[ [ literal value>> ] map ]
|
||||||
[ first literal recursion>> ] bi prefix
|
[ first literal recursion>> ] tri prefix
|
||||||
] if
|
] if
|
||||||
swap with-datastack ;
|
swap with-datastack ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -11,12 +11,14 @@ M: f #push, 2drop ;
|
||||||
M: f #shuffle, 3drop ;
|
M: f #shuffle, 3drop ;
|
||||||
M: f #>r, 2drop ;
|
M: f #>r, 2drop ;
|
||||||
M: f #r>, 2drop ;
|
M: f #r>, 2drop ;
|
||||||
M: f #return, 2drop ;
|
M: f #return, drop ;
|
||||||
M: f #terminate, ;
|
M: f #enter-recursive, 3drop ;
|
||||||
|
M: f #return-recursive, 3drop ;
|
||||||
|
M: f #terminate, drop ;
|
||||||
M: f #if, 3drop ;
|
M: f #if, 3drop ;
|
||||||
M: f #dispatch, 2drop ;
|
M: f #dispatch, 2drop ;
|
||||||
M: f #phi, 2drop 2drop ;
|
M: f #phi, 2drop 2drop ;
|
||||||
M: f #declare, drop ;
|
M: f #declare, drop ;
|
||||||
M: f #recursive, drop drop drop drop drop ;
|
M: f #recursive, 2drop 2drop ;
|
||||||
M: f #copy, 2drop ;
|
M: f #copy, 2drop ;
|
||||||
M: f #drop, drop ;
|
M: f #drop, drop ;
|
||||||
|
|
|
||||||
|
|
@ -17,11 +17,13 @@ HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- )
|
||||||
HOOK: #drop, stack-visitor ( values -- )
|
HOOK: #drop, stack-visitor ( values -- )
|
||||||
HOOK: #>r, stack-visitor ( inputs outputs -- )
|
HOOK: #>r, stack-visitor ( inputs outputs -- )
|
||||||
HOOK: #r>, stack-visitor ( inputs outputs -- )
|
HOOK: #r>, stack-visitor ( inputs outputs -- )
|
||||||
HOOK: #terminate, stack-visitor ( -- )
|
HOOK: #terminate, stack-visitor ( stack -- )
|
||||||
HOOK: #if, stack-visitor ( ? true false -- )
|
HOOK: #if, stack-visitor ( ? true false -- )
|
||||||
HOOK: #dispatch, stack-visitor ( n branches -- )
|
HOOK: #dispatch, stack-visitor ( n branches -- )
|
||||||
HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
|
HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
|
||||||
HOOK: #declare, stack-visitor ( declaration -- )
|
HOOK: #declare, stack-visitor ( declaration -- )
|
||||||
HOOK: #return, stack-visitor ( label stack -- )
|
HOOK: #return, stack-visitor ( stack -- )
|
||||||
HOOK: #recursive, stack-visitor ( word label inputs outputs visitor -- )
|
HOOK: #enter-recursive, stack-visitor ( label inputs outputs -- )
|
||||||
|
HOOK: #return-recursive, stack-visitor ( label inputs outputs -- )
|
||||||
|
HOOK: #recursive, stack-visitor ( word label inputs visitor -- )
|
||||||
HOOK: #copy, stack-visitor ( inputs outputs -- )
|
HOOK: #copy, stack-visitor ( inputs outputs -- )
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue