Merge branch 'master' of git://tiodante.com/git/factor

db4
William Schlieper 2008-07-31 20:51:07 -04:00
commit a757af9da5
70 changed files with 2761 additions and 510 deletions

View File

@ -221,6 +221,7 @@ M: word declarations.
POSTPONE: parsing
POSTPONE: delimiter
POSTPONE: inline
POSTPONE: recursive
POSTPONE: foldable
POSTPONE: flushable
} [ declaration. ] with each ;

View File

@ -20,7 +20,7 @@ ABOUT: "sequences-sorting"
HELP: sort
{ $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
{ $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } }

View File

@ -61,6 +61,7 @@ SYMBOL: super-sent-messages
"NSOpenGLView"
"NSOpenPanel"
"NSPasteboard"
"NSPropertyListSerialization"
"NSResponder"
"NSSavePanel"
"NSScreen"

View File

@ -3,7 +3,7 @@
USING: strings arrays hashtables assocs sequences
cocoa.messages cocoa.classes cocoa.application cocoa kernel
namespaces io.backend math cocoa.enumeration byte-arrays
combinators alien.c-types ;
combinators alien.c-types core-foundation ;
IN: cocoa.plists
GENERIC: >plist ( value -- plist )
@ -24,8 +24,8 @@ M: sequence >plist
[ >plist ] map <NSArray> ;
: write-plist ( assoc path -- )
>r >plist
r> normalize-path <NSString> 0 -> writeToFile:atomically:
[ >plist ] [ normalize-path <NSString> ] bi* 0
-> writeToFile:atomically:
[ "write-plist failed" throw ] unless ;
DEFER: plist>
@ -57,3 +57,13 @@ DEFER: plist>
{ [ dup NSDictionary -> isKindOfClass: c-bool> ] [ (plist-NSDictionary>) ] }
[ ]
} 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* ;

View File

@ -2,6 +2,15 @@ USING: combinators.lib kernel math random sequences tools.test continuations
arrays vectors ;
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
[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test

View File

@ -8,6 +8,25 @@ generalizations macros continuations locals ;
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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -43,6 +43,11 @@ TYPEDEF: int CFNumberType
: kCFNumberCGFloatType 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: void* CFArrayGetValueAtIndex ( CFArrayRef array, CFIndex idx ) ;

View File

@ -0,0 +1 @@
Joe Groff

View File

@ -0,0 +1 @@
Joe Groff

View File

@ -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 >>

View File

@ -0,0 +1 @@
Joe Groff

View File

@ -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

View File

@ -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

View File

@ -0,0 +1 @@
DirectInput backend for game-input

View File

@ -0,0 +1,4 @@
input
gamepads
joysticks
windows

View File

@ -0,0 +1 @@
Joe Groff

View File

@ -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

View File

@ -0,0 +1 @@
IOKit HID Manager backend for game-input

View File

@ -0,0 +1,4 @@
gamepads
joysticks
mac
input

View File

@ -0,0 +1 @@
Platform-specific backends for game-input

View File

@ -0,0 +1,3 @@
gamepads
joysticks
input

View File

@ -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"

View File

@ -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 )

View File

@ -0,0 +1 @@
Joe Groff

View File

@ -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

View File

@ -0,0 +1 @@
Scan code constants for HID keyboards

View File

@ -0,0 +1,2 @@
keyboard
input

View File

@ -0,0 +1 @@
Cross-platform joystick, gamepad, and raw keyboard input

View File

@ -0,0 +1,3 @@
joysticks
gamepads
input

View File

@ -0,0 +1 @@
Joe Groff

View File

@ -20,8 +20,8 @@ IN: iokit.hid
: kIOHIDPrimaryUsageKey "PrimaryUsage" ; inline
: kIOHIDPrimaryUsagePageKey "PrimaryUsagePage" ; inline
: kIOHIDMaxInputReportSizeKey "MaxInputReportSize" ; inline
: kIOHIDMaxOutputReportSizeKey "MaxOutputReportSize" ; inline
: kIOHIDMaxFeatureReportSizeKey "MaxFeatureReportSize" ; inline
: kIOHIDMaxOutputReportSizeKey "MaxOutputReportSize" ; inline
: kIOHIDMaxFeatureReportSizeKey "MaxFeatureReportSize" ; inline
: kIOHIDReportIntervalKey "ReportInterval" ; inline
: kIOHIDElementKey "Elements" ; inline
@ -77,7 +77,7 @@ IN: iokit.hid
: kIOHIDElementTypeFeature 257 ; inline
: kIOHIDElementTypeCollection 513 ; inline
: kIOHIDElementCollectionTypePhysical HEX: 00 ; inline
: kIOHIDElementCollectionTypePhysical HEX: 00 ; inline
: kIOHIDElementCollectionTypeApplication HEX: 01 ; inline
: kIOHIDElementCollectionTypeLogical HEX: 02 ; inline
: kIOHIDElementCollectionTypeReport HEX: 03 ; inline
@ -90,10 +90,10 @@ IN: iokit.hid
: kIOHIDReportTypeFeature 2 ; inline
: kIOHIDReportTypeCount 3 ; inline
: kIOHIDOptionsTypeNone HEX: 00 ; inline
: kIOHIDOptionsTypeNone HEX: 00 ; inline
: kIOHIDOptionsTypeSeizeDevice HEX: 01 ; inline
: kIOHIDQueueOptionsTypeNone HEX: 00 ; inline
: kIOHIDQueueOptionsTypeNone HEX: 00 ; inline
: kIOHIDQueueOptionsTypeEnqueueAll HEX: 01 ; inline
: kIOHIDElementFlagsConstantMask HEX: 0001 ; inline
@ -269,3 +269,4 @@ FUNCTION: IOHIDValueRef IOHIDTransactionGetValue ( IOHIDTransactionRef transacti
FUNCTION: IOReturn IOHIDTransactionCommit ( IOHIDTransactionRef transaction ) ;
FUNCTION: IOReturn IOHIDTransactionCommitWithCallback ( IOHIDTransactionRef transaction, CFTimeInterval timeout, IOHIDCallback callback, void* context ) ;
FUNCTION: void IOHIDTransactionClear ( IOHIDTransactionRef transaction ) ;

View File

@ -0,0 +1 @@
HID Manager bindings

3
extra/iokit/hid/tags.txt Normal file
View File

@ -0,0 +1,3 @@
mac
bindings
system

0
extra/iokit/iokit.factor Normal file → Executable file
View File

View File

@ -43,7 +43,7 @@ IN: irc.client.tests
":some.where 001 factorbot :Welcome factorbot"
} make-client
{ [ connect-irc ]
[ drop 1 seconds sleep ]
[ drop 0.1 seconds sleep ]
[ profile>> nickname>> ]
[ terminate-irc ]
} cleave ] unit-test
@ -57,8 +57,8 @@ IN: irc.client.tests
} make-client
{ [ "factorbot" set-nick ]
[ connect-irc ]
[ drop 1 seconds sleep ]
[ join-messages>> 1 seconds mailbox-get-timeout ]
[ drop 0.1 seconds sleep ]
[ join-messages>> 0.1 seconds mailbox-get-timeout ]
[ terminate-irc ]
} cleave
[ class ] [ trailing>> ] bi ] unit-test
@ -101,3 +101,75 @@ IN: irc.client.tests
} cleave
[ class ] [ name>> ] [ trailing>> ] tri
] unit-test
! Participants lists tests
{ H{ { "somedude" +normal+ } } } [
{ ":somedude!n=user@isp.net JOIN :#factortest" } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test
{ H{ { "somedude2" +normal+ } } } [
{ ":somedude!n=user@isp.net PART #factortest" } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener>
H{ { "somedude2" +normal+ }
{ "somedude" +normal+ } } clone >>participants ] keep
] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test
{ H{ { "somedude2" +normal+ } } } [
{ ":somedude!n=user@isp.net QUIT" } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener>
H{ { "somedude2" +normal+ }
{ "somedude" +normal+ } } clone >>participants ] keep
] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test
{ H{ { "somedude2" +normal+ } } } [
{ ":somedude2!n=user2@isp.net KICK #factortest somedude" } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener>
H{ { "somedude2" +normal+ }
{ "somedude" +normal+ } } clone >>participants ] keep
] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at participants>> ]
[ terminate-irc ]
} cleave
] unit-test
! Namelist notification
{ T{ participant-changed f f f } } [
{ ":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ]
[ terminate-irc ]
} cleave
] unit-test

View File

@ -218,9 +218,9 @@ M: privmsg handle-incoming-irc ( privmsg -- )
dup irc-message-origin to-listener ;
M: join handle-incoming-irc ( join -- )
{ [ maybe-forward-join ] ! keep
{ [ maybe-forward-join ]
[ dup trailing>> to-listener ]
[ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
[ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
[ handle-participant-change ]
} cleave ;
@ -231,19 +231,18 @@ M: part handle-incoming-irc ( part -- )
tri ;
M: kick handle-incoming-irc ( kick -- )
{ [ dup channel>> to-listener ]
{ [ dup channel>> to-listener ]
[ [ who>> ] [ channel>> ] bi remove-participant ]
[ handle-participant-change ]
[ dup who>> me? [ unregister-listener ] [ drop ] if ]
} cleave ;
M: quit handle-incoming-irc ( quit -- )
{ [ dup prefix>> parse-name listeners-with-participant
[ to-listener ] with each ]
[ handle-participant-change ]
[ prefix>> parse-name remove-participant-from-all ]
[ call-next-method ]
} cleave ;
[ dup prefix>> parse-name listeners-with-participant
[ to-listener ] with each ]
[ prefix>> parse-name remove-participant-from-all ]
[ handle-participant-change ]
tri ;
: >nick/mode ( string -- nick mode )
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
@ -253,8 +252,10 @@ M: quit handle-incoming-irc ( quit -- )
[ >nick/mode 2array ] map >hashtable ;
M: names-reply handle-incoming-irc ( names-reply -- )
[ names-reply>participants ] [ channel>> listener> ] bi
[ (>>participants) ] [ drop ] if* ;
[ names-reply>participants ] [ channel>> listener> ] bi [
[ (>>participants) ]
[ [ f f <participant-changed> ] dip name>> to-listener ] bi
] [ drop ] if* ;
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
broadcast-message-to-listeners ;

View File

@ -40,8 +40,18 @@ mode new
"ircserver.net" >>prefix
"MODE" >>command
{ "#factortest" "+ns" } >>parameters
"#factortest" >>channel
"#factortest" >>channel
"+ns" >>mode
1array
[ ":ircserver.net MODE #factortest +ns"
parse-irc-line f >>timestamp ] unit-test
nick new
":someuser!n=user@some.where NICK :someuser2" >>line
"someuser!n=user@some.where" >>prefix
"NICK" >>command
{ } >>parameters
"someuser2" >>trailing
1array
[ ":someuser!n=user@some.where NICK :someuser2"
parse-irc-line f >>timestamp ] unit-test

View File

@ -12,6 +12,7 @@ TUPLE: ping < irc-message ;
TUPLE: join < irc-message ;
TUPLE: part < irc-message channel ;
TUPLE: quit < irc-message ;
TUPLE: nick < irc-message ;
TUPLE: privmsg < irc-message name ;
TUPLE: kick < irc-message channel who ;
TUPLE: roomlist < irc-message channel names ;
@ -34,6 +35,7 @@ M: ping irc-command-string ( ping -- string ) drop "PING" ;
M: join irc-command-string ( join -- string ) drop "JOIN" ;
M: part irc-command-string ( part -- string ) drop "PART" ;
M: quit irc-command-string ( quit -- string ) drop "QUIT" ;
M: nick irc-command-string ( nick -- string ) drop "NICK" ;
M: privmsg irc-command-string ( privmsg -- string ) drop "PRIVMSG" ;
M: notice irc-command-string ( notice -- string ) drop "NOTICE" ;
M: mode irc-command-string ( mode -- string ) drop "MODE" ;
@ -46,6 +48,7 @@ M: ping irc-command-parameters ( ping -- seq ) drop { } ;
M: join irc-command-parameters ( join -- seq ) drop { } ;
M: part irc-command-parameters ( part -- seq ) name>> 1array ;
M: quit irc-command-parameters ( quit -- seq ) drop { } ;
M: nick irc-command-parameters ( nick -- seq ) drop { } ;
M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ;
M: notice irc-command-parameters ( norice -- seq ) type>> 1array ;
M: kick irc-command-parameters ( kick -- seq )
@ -110,6 +113,7 @@ PRIVATE>
{ "353" [ names-reply ] }
{ "JOIN" [ join ] }
{ "PART" [ part ] }
{ "NICK" [ nick ] }
{ "PRIVMSG" [ privmsg ] }
{ "QUIT" [ quit ] }
{ "MODE" [ mode ] }

View File

@ -0,0 +1 @@
Joe Groff

View File

@ -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

View File

@ -0,0 +1 @@
Demonstrate gamepad and joystick input

View File

@ -0,0 +1,2 @@
gamepads
joysticks

View File

@ -0,0 +1 @@
Joe Groff

180
extra/key-caps/key-caps.factor Executable file
View File

@ -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

View File

@ -0,0 +1 @@
Graphical keyboard diagram

1
extra/key-caps/tags.txt Normal file
View File

@ -0,0 +1 @@
keyboard

View File

@ -34,7 +34,16 @@ ARTICLE: "math.blas-types" "BLAS interface types"
{ $subsection <double-complex-blas-matrix> }
"For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:"
{ $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"
"Transposing and slicing matrices:"

View File

@ -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
@ -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-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- ;

View File

@ -195,6 +195,8 @@ TUPLE: sprite loc dim dim2 dlist texture ;
: gl-translate ( point -- ) first2 0.0 glTranslated ;
<PRIVATE
: top-left drop 0 0 glTexCoord2i 0.0 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
PRIVATE>
: four-sides ( dim -- )
dup top-left dup top-right dup bottom-right bottom-left ;

File diff suppressed because it is too large Load Diff

View File

@ -31,10 +31,12 @@ TYPEDEF: void* LPDIENUMCREATEDEFFECTOBJECTSCALLBACK
[ "BOOL" { "LPDIRECTINPUTEFFECT" "LPVOID" } "stdcall" ]
dip alien-callback ; inline
TYPEDEF: void* LPDIENUMEFFECTSINFILECALLBACK
: LPDIENUMEFFECTSINFILECALLBACK
[ "BOOL" { "LPCDIFILEEFFECT" "LPVOID" } "stdcall" ]
dip alien-callback ; inline
TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW
[ "BOOL" { "LPCDIDEVICEOBJECTINSTANCE" "LPVOID" } "stdcall" ]
: LPDIENUMDEVICEOBJECTSCALLBACKW
[ "BOOL" { "LPCDIDEVICEOBJECTINSTANCEW" "LPVOID" } "stdcall" ]
dip alien-callback ; inline
TYPEDEF: DWORD D3DCOLOR
@ -105,29 +107,35 @@ TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
C-STRUCT: DIDEVCAPS
{ "DWORD" "wSize" }
{ "DWORD" "wFlags" }
{ "DWORD" "wDevType" }
{ "DWORD" "wAxes" }
{ "DWORD" "wButtons" }
{ "DWORD" "wPOVs" }
{ "DWORD" "wFFSamplePeriod" }
{ "DWORD" "wFFMinTimeResolution" }
{ "DWORD" "wFirmwareRevision" }
{ "DWORD" "wHardwareRevision" }
{ "DWORD" "wFFDriverVersion" } ;
{ "DWORD" "dwSize" }
{ "DWORD" "dwFlags" }
{ "DWORD" "dwDevType" }
{ "DWORD" "dwAxes" }
{ "DWORD" "dwButtons" }
{ "DWORD" "dwPOVs" }
{ "DWORD" "dwFFSamplePeriod" }
{ "DWORD" "dwFFMinTimeResolution" }
{ "DWORD" "dwFirmwareRevision" }
{ "DWORD" "dwHardwareRevision" }
{ "DWORD" "dwFFDriverVersion" } ;
TYPEDEF: DIDEVCAPS* LPDIDEVCAPS
TYPEDEF: DIDEVCAPS* LPCDIDEVCAPS
C-STRUCT: DIDEVICEOBJECTINSTANCEW
{ "DWORD" "dwSize" }
{ "GUID" "guidInstance" }
{ "GUID" "guidProduct" }
{ "DWORD" "dwDevType" }
{ "WCHAR[260]" "tszInstanceName" }
{ "WCHAR[260]" "tszProductName" }
{ "GUID" "guidFFDriver" }
{ "WORD" "wUsagePage" }
{ "WORD" "wUsage" } ;
{ "DWORD" "dwSize" }
{ "GUID" "guidType" }
{ "DWORD" "dwOfs" }
{ "DWORD" "dwType" }
{ "DWORD" "dwFlags" }
{ "WCHAR[260]" "tszName" }
{ "DWORD" "dwFFMaxForce" }
{ "DWORD" "dwFFForceResolution" }
{ "WORD" "wCollectionNumber" }
{ "WORD" "wDesignatorIndex" }
{ "WORD" "wUsagePage" }
{ "WORD" "wUsage" }
{ "DWORD" "dwDimension" }
{ "WORD" "wExponent" }
{ "WORD" "wReportId" } ;
TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPDIDEVICEOBJECTINSTANCEW
TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPCDIDEVICEOBJECTINSTANCEW
C-STRUCT: DIDEVICEOBJECTDATA
@ -161,6 +169,49 @@ C-STRUCT: DIPROPHEADER
{ "DWORD" "dwHow" } ;
TYPEDEF: DIPROPHEADER* LPDIPROPHEADER
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
{ "DWORD" "dwSize" }
{ "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_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_NONEXCLUSIVE HEX: 00000002 ; inline
: DISCL_FOREGROUND HEX: 00000004 ; inline
: DISCL_BACKGROUND HEX: 00000008 ; 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 ( -- )
f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
f <void*> [ f DirectInput8Create ole32-error ] keep *void*
+dinput+ set ;
: DIK_BACKSPACE DIK_BACK ; inline
: DIK_NUMPADSTAR DIK_MULTIPLY ; inline
: DIK_LALT DIK_LMENU ; inline
: 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 ( -- )
+dinput+ [ com-release f ] change ;
: DIK_CIRCUMFLEX DIK_PREVTRACK ; inline
: 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

View File

@ -1,5 +1,5 @@
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 ;
IN: windows.ole32
@ -115,10 +115,14 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
: succeeded? ( hresult -- ? )
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 -- )
dup succeeded? [
drop
] [ (win32-error-string) throw ] if ;
dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
: ole-initialize ( -- )
f OleInitialize ole32-error ;

View File

@ -528,6 +528,27 @@ C-STRUCT: TRACKMOUSEEVENT
{ "DWORD" "dwHoverTime" } ;
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
FUNCTION: HKL ActivateKeyboardLayout ( HKL hkl, UINT Flags ) ;
@ -1176,8 +1197,9 @@ ALIAS: RegisterClassEx RegisterClassExW
! FUNCTION: RegisterClipboardFormatA
! FUNCTION: RegisterClipboardFormatW
! FUNCTION: RegisterDeviceNotificationA
! FUNCTION: RegisterDeviceNotificationW
FUNCTION: HANDLE RegisterDeviceNotificationA ( HANDLE hRecipient, LPVOID NotificationFilter, DWORD Flags ) ;
FUNCTION: HANDLE RegisterDeviceNotificationW ( HANDLE hRecipient, LPVOID NotificationFilter, DWORD Flags ) ;
ALIAS: RegisterDeviceNotification RegisterDeviceNotificationW
! FUNCTION: RegisterHotKey
! FUNCTION: RegisterLogonProcess
! FUNCTION: RegisterMessagePumpHook
@ -1344,7 +1366,7 @@ FUNCTION: BOOL TranslateMessage ( MSG* lpMsg ) ;
! FUNCTION: UnpackDDElParam
FUNCTION: BOOL UnregisterClassW ( LPCWSTR lpClassName, HINSTANCE hInstance ) ;
ALIAS: UnregisterClass UnregisterClassW
! FUNCTION: UnregisterDeviceNotification
FUNCTION: BOOL UnregisterDeviceNotification ( HANDLE hDevNotify ) ;
! FUNCTION: UnregisterHotKey
! FUNCTION: UnregisterMessagePumpHook
! FUNCTION: UnregisterUserApiHook

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! 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
compiler.tree compiler.tree.def-use compiler.tree.combinators ;
IN: compiler.tree.copy-equiv
@ -31,6 +31,16 @@ M: #r> compute-copy-equiv*
M: #copy compute-copy-equiv*
[ 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 ;
: compute-copy-equiv ( node -- node )

View File

@ -21,9 +21,7 @@ M: #call mark-live-values
[ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
M: #return mark-live-values
#! Values returned by local #recursive functions can be
#! killed if they're unused.
dup label>> [ drop ] [ look-at-inputs ] if ;
look-at-inputs ;
M: node mark-live-values drop ;

View File

@ -52,12 +52,16 @@ M: node node-defs-values out-d>> ;
[ dup node-uses-values [ use-value ] with each ]
[ 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 ( -- )
def-use get [
nip
[ node>> [ "No def" throw ] unless ]
[ uses>> all-unique? [ "Uses not all unique" throw ] unless ]
bi
nip [ node>> check-def ] [ uses>> check-use ] bi
] assoc-each ;
: compute-def-use ( node -- node )

View File

@ -59,5 +59,7 @@ IN: compiler.tree.propagation.info.tests
[ 3 t ] [
3 <literal-info>
null <class-info> value-info-union >literal<
null-info value-info-union >literal<
] unit-test
[ ] [ { } value-infos-union drop ] unit-test

View File

@ -27,6 +27,8 @@ literal?
length
slots ;
: null-info T{ value-info f null empty-interval } ; inline
: class-interval ( class -- interval )
dup real class<=
[ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
@ -113,6 +115,8 @@ slots ;
DEFER: value-info-intersect
DEFER: (value-info-intersect)
: intersect-lengths ( info1 info2 -- length )
[ length>> ] bi@ {
{ [ dup not ] [ drop ] }
@ -120,10 +124,17 @@ DEFER: value-info-intersect
[ value-info-intersect ]
} cond ;
: intersect-slot ( info1 info2 -- info )
{
{ [ dup not ] [ nip ] }
{ [ over not ] [ drop ] }
[ (value-info-intersect) ]
} cond ;
: intersect-slots ( info1 info2 -- slots )
[ slots>> ] 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> ] 2dip
@ -150,6 +161,8 @@ DEFER: value-info-intersect
DEFER: value-info-union
DEFER: (value-info-union)
: union-lengths ( info1 info2 -- length )
[ length>> ] bi@ {
{ [ dup not ] [ nip ] }
@ -157,10 +170,17 @@ DEFER: value-info-union
[ value-info-union ]
} cond ;
: union-slot ( info1 info2 -- info )
{
{ [ dup not ] [ nip ] }
{ [ over not ] [ drop ] }
[ (value-info-union) ]
} cond ;
: union-slots ( info1 info2 -- slots )
[ slots>> ] 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> ] 2dip
@ -181,14 +201,15 @@ DEFER: value-info-union
} cond ;
: 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
SYMBOL: value-infos
: value-info ( value -- info )
resolve-copy value-infos get at
T{ value-info f null empty-interval } or ;
resolve-copy value-infos get at null-info or ;
: set-value-info ( info value -- )
resolve-copy value-infos get set-at ;
@ -213,3 +234,12 @@ SYMBOL: value-infos
: value-is? ( value 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 ;

View File

@ -4,9 +4,10 @@ USING: kernel effects accessors math math.private math.libm
math.partial-dispatch math.intervals math.parser math.order
layouts words sequences sequences.private arrays assocs classes
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.constraints
compiler.tree.propagation.slots
compiler.tree.comparisons ;
IN: compiler.tree.propagation.known-words
@ -258,3 +259,8 @@ generic-comparison-ops [
! the output of clone has the same type as the input
{ clone (clone) } [ [ ] +outputs+ set-word-prop ] each
\ slot [
dup literal?>>
[ literal>> swap value-info-slot ] [ 2drop object <class-info> ] if
] +outputs+ set-word-prop

View File

@ -16,6 +16,7 @@ GENERIC: propagate-around ( node -- )
: (propagate) ( node -- )
[
USING: classes prettyprint ; dup class .
[ propagate-around ] [ successor>> ] bi
(propagate)
] when* ;

View File

@ -3,8 +3,9 @@ compiler.tree.propagation compiler.tree.copy-equiv
compiler.tree.def-use tools.test math math.order
accessors sequences arrays kernel.private vectors
alien.accessors alien.c-types sequences.private
byte-arrays classes.algebra math.functions math.private
strings ;
byte-arrays classes.algebra classes.tuple.private
math.functions math.private strings layouts
compiler.tree.propagation.info ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
@ -235,12 +236,39 @@ IN: compiler.tree.propagation.tests
[ [ 1 ] [ 1 ] if 1 + ] final-literals
] unit-test
[ V{ object } ] [
[ 0 * 10 < ] final-classes
] unit-test
[ V{ string string } ] [
[
2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
] final-classes
] 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
[ 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
] unit-test
[ V{ tuple-layout } ] [
[ T{ mutable-tuple-test f "hey" } layout-of ] final-classes
] unit-test
! Mixed mutable and immutable slots
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
] final-classes
] 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

View File

@ -1,6 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! 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.propagation.info
compiler.tree.propagation.nodes
@ -8,29 +10,75 @@ compiler.tree.propagation.simple
compiler.tree.propagation.branches ;
IN: compiler.tree.propagation.recursive
! What if we reach a fixed point for the phi but not for the
! #call-label output?
! row polymorphism is causing problems
! We need to compute scalar evolution so that sccp doesn't
! evaluate loops
: longest-suffix ( seq1 seq2 -- seq1' seq2' )
2dup min-length [ tail-slice* ] curry bi@ ;
: (merge-value-infos) ( inputs -- infos )
[ [ value-info ] map value-infos-union ] map ;
: suffixes= ( seq1 seq2 -- ? )
longest-suffix sequence= ;
: merge-value-infos ( inputs outputs -- fixed-point? )
[ (merge-value-infos) ] dip
[ 2dup value-info = [ 2drop t ] [ set-value-info f ] if ] 2all? ;
: check-fixed-point ( node infos1 infos2 -- node )
suffixes= [ dup label>> f >>fixed-point drop ] unless ; inline
: propagate-recursive-phi ( #phi -- fixed-point? )
[ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
[ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
bi and ;
: recursive-stacks ( #enter-recursive -- stacks initial )
[ label>> calls>> [ node-input-infos ] map ]
[ in-d>> [ value-info ] map ] bi
[ 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 -- )
dup
node-child
[ first>> (propagate) ] [ propagate-recursive-phi ] bi
[ drop ] [ propagate-around ] if ;
iter-counter inc
iter-counter get 10 > [ "Oops" throw ] when
dup label>> t >>fixed-point drop
[ 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 -- )
[ 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 ;

View File

@ -39,15 +39,25 @@ UNION: fixed-length-sequence array byte-array string ;
: tuple-constructor? ( node -- ? )
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 )
#! Delegation
in-d>> [ value-info ] map unclip-last
literal>> class>> dup immutable-tuple-class? [
over [ literal?>> ] all?
[ [ , f , [ literal>> ] map % ] { } make >tuple <literal-info> ]
[ <tuple-info> ]
if
] [ nip <class-info> ] if ;
literal>> class>> [ read-only-slots ] keep
over 2 tail-slice [ dup [ literal?>> ] when ] all? [
[ 2 tail-slice ] dip fold-<tuple-boa>
] [
<tuple-info>
] if ;
: propagate-<complex> ( node -- 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 ;
: no-reader-methods ( input slots -- info )
2drop null <class-info> ;
2drop null-info ;
: same-offset ( slots -- slot/f )
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-info> ;
: tuple>array* ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>
prefix ;
: literal-info-slot ( slot info -- info' )
{
{ [ dup tuple? ] [
tuple>array* nth <literal-info>
] }
{ [ dup complex? ] [
[ real-part ] [ imaginary-part ] bi
2array nth <literal-info>
] }
} cond ;
: value-info-slot ( slot info -- info' )
#! Delegation.
[ class>> complex class<= 1 3 ? - ] keep
dup literal?>> [
literal>> {
{ [ dup tuple? ] [
tuple-slots 1 tail-slice nth <literal-info>
] }
{ [ dup complex? ] [
[ real-part ] [ imaginary-part ] bi
2array nth <literal-info>
] }
} cond
] [ slots>> ?nth ] if ;
{
{ [ over 0 = ] [ 2drop fixnum <class-info> ] }
{ [ dup literal?>> ] [ [ 1- ] [ literal>> ] bi* literal-info-slot ] }
[ [ 1- ] [ slots>> ] bi* ?nth ]
} cond ;
: reader-word-outputs ( node -- infos )
[ relevant-slots ] [ in-d>> first ] bi

View File

@ -35,15 +35,6 @@ M: node hashcode* drop node hashcode* ;
2drop f
] 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 ;
: #introduce ( values -- node )
@ -99,7 +90,9 @@ TUPLE: #r> < node ;
TUPLE: #terminate < node ;
: #terminate ( -- node ) \ #terminate new ;
: #terminate ( stack -- node )
\ #terminate new
swap >>in-d ;
TUPLE: #branch < node ;
@ -133,23 +126,37 @@ TUPLE: #declare < node declaration ;
\ #declare new
swap >>declaration ;
TUPLE: #return < node label ;
TUPLE: #return < node ;
: #return ( label stack -- node )
: #return ( stack -- node )
\ #return new
swap >>in-d
swap >>label ;
swap >>in-d ;
TUPLE: #recursive < node word label loop? returns calls ;
: #recursive ( word label inputs outputs child -- node )
: #recursive ( word label inputs child -- node )
\ #recursive new
swap 1array >>children
swap >>out-d
swap >>in-d
swap >>label
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 ;
: #copy ( inputs outputs -- node )
@ -175,13 +182,15 @@ TUPLE: node-list first last ;
M: node-list child-visitor node-list new ;
M: node-list #introduce, #introduce node, ;
M: node-list #call, #call node, ;
M: node-list #call-recursive, #call-recursive node, ;
M: node-list #push, #push node, ;
M: node-list #shuffle, #shuffle node, ;
M: node-list #drop, #drop node, ;
M: node-list #>r, #>r node, ;
M: node-list #r>, #r> 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 #if, #if node, ;
M: node-list #dispatch, #dispatch node, ;

View File

@ -29,8 +29,7 @@ M: #call compute-untupling*
[ drop mark-escaping-values ]
} case ;
M: #return compute-untupling*
dup label>> [ drop ] [ mark-escaping-values ] if ;
M: #return compute-untupling* mark-escaping-values ;
M: node compute-untupling* drop ;

View File

@ -82,7 +82,7 @@ M: wrapper apply-object
M: object apply-object push-literal ;
: terminate ( -- )
terminated? on #terminate, ;
terminated? on meta-d get clone #terminate, ;
: infer-quot ( quot rstate -- )
recursive-state get [
@ -113,10 +113,10 @@ M: object apply-object push-literal ;
] if ;
: 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 -- )
consume-r [ dup copy-values #r>, ] [ output-d ] bi ;
consume-r dup copy-values [ #r>, ] [ nip output-d ] 2bi ;
: undo-infer ( -- )
recorded get [ f +inferred-effect+ set-word-prop ] each ;
@ -140,7 +140,7 @@ M: object apply-object push-literal ;
: end-infer ( -- )
check->r
f meta-d get clone #return, ;
meta-d get clone #return, ;
: effect-required? ( word -- ? )
{

View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces assocs kernel sequences words accessors
definitions math effects classes arrays combinators vectors
arrays
stack-checker.state
stack-checker.visitor
stack-checker.backend
@ -16,12 +17,12 @@ IN: stack-checker.inlining
: (inline-word) ( word label -- )
[ [ 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 new
swap >>word
V{ } clone >>returns ;
V{ } clone >>calls ;
: quotation-param? ( obj -- ? )
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' )
[ quotation-param? [ copy-value ] [ drop <value> ] if ] 2map ;
SYMBOL: phi-in
SYMBOL: phi-out
SYMBOL: enter-in
SYMBOL: enter-out
: prepare-stack ( word -- )
required-stack-effect in>> [ length ensure-d ] keep
[ drop 1vector phi-in set ]
[ make-copies phi-out set ]
2bi ;
[ drop enter-in set ] [ make-copies enter-out set ] 2bi ;
: emit-phi-function ( label -- )
phi-in get >>phi-in
phi-out get >>phi-out drop
phi-in get phi-out get { { } } { } #phi,
phi-out get >vector meta-d set ;
: emit-enter-recursive ( label -- )
enter-out get >>enter-out
enter-in get enter-out get #enter-recursive,
enter-out get >vector meta-d set ;
: entry-stack-height ( label -- stack )
phi-out>> length ;
enter-out>> length ;
: check-return ( word label -- )
2dup
@ -59,7 +57,7 @@ SYMBOL: phi-out
: end-recursive-word ( word label -- )
[ check-return ]
[ meta-d get [ #return, ] [ swap returns>> push ] 2bi ]
[ meta-d get dup copy-values dup meta-d set #return-recursive, ]
bi ;
: recursive-word-inputs ( label -- n )
@ -72,7 +70,7 @@ SYMBOL: phi-out
nest-visitor
dup <inline-recursive>
[ dup emit-phi-function (inline-word) ]
[ dup emit-enter-recursive (inline-word) ]
[ end-recursive-word ]
[ ]
2tri
@ -86,7 +84,7 @@ SYMBOL: phi-out
: inline-recursive-word ( word -- )
(inline-recursive-word)
[ consume-d ] [ dup output-d ] [ ] tri* #recursive, ;
[ consume-d ] [ output-d ] [ ] tri* #recursive, ;
: check-call-height ( word label -- )
entry-stack-height current-stack-height >
@ -96,18 +94,13 @@ SYMBOL: phi-out
required-stack-effect in>> length meta-d get swap tail* ;
: check-call-site-stack ( stack label -- )
tuck phi-out>>
tuck enter-out>>
[ dup known [ [ known ] bi@ = ] [ 2drop t ] if ] 2all?
[ drop ] [ word>> inconsistent-recursive-call-error inference-error ] if ;
: add-call ( word label -- )
[ check-call-height ]
[
[ call-site-stack ] dip
[ check-call-site-stack ]
[ phi-in>> swap [ suffix ] 2change-each ]
2bi
] 2bi ;
[ [ call-site-stack ] dip check-call-site-stack ] 2bi ;
: adjust-stack-effect ( effect -- effect' )
[ in>> ] [ out>> ] bi

View File

@ -4,7 +4,8 @@ USING: fry accessors arrays kernel words sequences generic math
namespaces quotations assocs combinators classes.tuple
classes.tuple.private effects summary hashtables classes generic
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
SYMBOL: +transform-quot+
@ -15,8 +16,9 @@ SYMBOL: +transform-n+
drop recursive-state get 1array
] [
consume-d
[ #drop, ]
[ [ literal value>> ] map ]
[ first literal recursion>> ] bi prefix
[ first literal recursion>> ] tri prefix
] if
swap with-datastack ;

View File

@ -11,12 +11,14 @@ M: f #push, 2drop ;
M: f #shuffle, 3drop ;
M: f #>r, 2drop ;
M: f #r>, 2drop ;
M: f #return, 2drop ;
M: f #terminate, ;
M: f #return, drop ;
M: f #enter-recursive, 3drop ;
M: f #return-recursive, 3drop ;
M: f #terminate, drop ;
M: f #if, 3drop ;
M: f #dispatch, 2drop ;
M: f #phi, 2drop 2drop ;
M: f #declare, drop ;
M: f #recursive, drop drop drop drop drop ;
M: f #recursive, 2drop 2drop ;
M: f #copy, 2drop ;
M: f #drop, drop ;

View File

@ -17,11 +17,13 @@ HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- )
HOOK: #drop, stack-visitor ( values -- )
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: #dispatch, stack-visitor ( n branches -- )
HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
HOOK: #declare, stack-visitor ( declaration -- )
HOOK: #return, stack-visitor ( label stack -- )
HOOK: #recursive, stack-visitor ( word label inputs outputs visitor -- )
HOOK: #return, stack-visitor ( stack -- )
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 -- )