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

2008-07-31 20:51:07 -04:00 · 2008-07-31 20:51:07 -04:00 · a757af9da5
parent 9f60dd601b fcc1ee9cdd
commit a757af9da5
70 changed files with 2761 additions and 510 deletions
--- a/core/prettyprint/prettyprint.factor
+++ b/core/prettyprint/prettyprint.factor
@ -221,6 +221,7 @@ M: word declarations.
        POSTPONE: parsing
        POSTPONE: delimiter
        POSTPONE: inline
+        POSTPONE: recursive
        POSTPONE: foldable
        POSTPONE: flushable
    } [ declaration. ] with each ;
--- a/core/sorting/sorting-docs.factor
+++ b/core/sorting/sorting-docs.factor
@ -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" } }
--- a/extra/cocoa/cocoa.factor
+++ b/extra/cocoa/cocoa.factor
@ -61,6 +61,7 @@ SYMBOL: super-sent-messages
        "NSOpenGLView"
        "NSOpenPanel"
        "NSPasteboard"
+        "NSPropertyListSerialization"
        "NSResponder"
        "NSSavePanel"
        "NSScreen"
--- a/extra/cocoa/plists/plists.factor
+++ b/extra/cocoa/plists/plists.factor
@ -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* ;
--- a/extra/combinators/lib/lib-tests.factor
+++ b/extra/combinators/lib/lib-tests.factor
@ -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

--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@ -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
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- a/extra/core-foundation/core-foundation.factor
+++ b/extra/core-foundation/core-foundation.factor
@ -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 ) ;
--- a/extra/game-input/authors.txt
+++ b/extra/game-input/authors.txt
@ -0,0 +1 @@
+Joe Groff
--- a/extra/game-input/backend/authors.txt
+++ b/extra/game-input/backend/authors.txt
@ -0,0 +1 @@
+Joe Groff
--- a/extra/game-input/backend/backend.factor
+++ b/extra/game-input/backend/backend.factor
@ -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 >>
--- a/extra/game-input/backend/dinput/authors.txt
+++ b/extra/game-input/backend/dinput/authors.txt
@ -0,0 +1 @@
+Joe Groff
--- a/extra/game-input/backend/dinput/dinput.factor
+++ b/extra/game-input/backend/dinput/dinput.factor
@ -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
--- a/extra/game-input/backend/dinput/keys-array/keys-array.factor
+++ b/extra/game-input/backend/dinput/keys-array/keys-array.factor
@ -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
+
--- a/extra/game-input/backend/dinput/summary.txt
+++ b/extra/game-input/backend/dinput/summary.txt
@ -0,0 +1 @@
+DirectInput backend for game-input
--- a/extra/game-input/backend/dinput/tags.txt
+++ b/extra/game-input/backend/dinput/tags.txt
@ -0,0 +1,4 @@
+input
+gamepads
+joysticks
+windows
--- a/extra/game-input/backend/iokit/authors.txt
+++ b/extra/game-input/backend/iokit/authors.txt
@ -0,0 +1 @@
+Joe Groff
--- a/extra/game-input/backend/iokit/iokit.factor
+++ b/extra/game-input/backend/iokit/iokit.factor
@ -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
--- a/extra/game-input/backend/iokit/summary.txt
+++ b/extra/game-input/backend/iokit/summary.txt
@ -0,0 +1 @@
+IOKit HID Manager backend for game-input
--- a/extra/game-input/backend/iokit/tags.txt
+++ b/extra/game-input/backend/iokit/tags.txt
@ -0,0 +1,4 @@
+gamepads
+joysticks
+mac
+input
--- a/extra/game-input/backend/summary.txt
+++ b/extra/game-input/backend/summary.txt
@ -0,0 +1 @@
+Platform-specific backends for game-input
--- a/extra/game-input/backend/tags.txt
+++ b/extra/game-input/backend/tags.txt
@ -0,0 +1,3 @@
+gamepads
+joysticks
+input
--- a/extra/game-input/game-input-docs.factor
+++ b/extra/game-input/game-input-docs.factor
@ -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"
--- a/extra/game-input/game-input.factor
+++ b/extra/game-input/game-input.factor
@ -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 )
--- a/extra/game-input/scancodes/authors.txt
+++ b/extra/game-input/scancodes/authors.txt
@ -0,0 +1 @@
+Joe Groff
--- a/extra/game-input/scancodes/scancodes.factor
+++ b/extra/game-input/scancodes/scancodes.factor
@ -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
--- a/extra/game-input/scancodes/summary.txt
+++ b/extra/game-input/scancodes/summary.txt
@ -0,0 +1 @@
+Scan code constants for HID keyboards
--- a/extra/game-input/scancodes/tags.txt
+++ b/extra/game-input/scancodes/tags.txt
@ -0,0 +1,2 @@
+keyboard
+input
--- a/extra/game-input/summary.txt
+++ b/extra/game-input/summary.txt
@ -0,0 +1 @@
+Cross-platform joystick, gamepad, and raw keyboard input
--- a/extra/game-input/tags.txt
+++ b/extra/game-input/tags.txt
@ -0,0 +1,3 @@
+joysticks
+gamepads
+input
--- a/extra/iokit/hid/authors.txt
+++ b/extra/iokit/hid/authors.txt
@ -0,0 +1 @@
+Joe Groff
--- a/extra/iokit/hid/hid.factor
+++ b/extra/iokit/hid/hid.factor
@ -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 ) ;
+
--- a/extra/iokit/hid/summary.txt
+++ b/extra/iokit/hid/summary.txt
@ -0,0 +1 @@
+HID Manager bindings
--- a/extra/iokit/hid/tags.txt
+++ b/extra/iokit/hid/tags.txt
@ -0,0 +1,3 @@
+mac
+bindings
+system
--- a/extra/iokit/iokit.factor
+++ b/extra/iokit/iokit.factor
--- a/extra/irc/client/client-tests.factor
+++ b/extra/irc/client/client-tests.factor
@ -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
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@ -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 ;
--- a/extra/irc/messages/messages-tests.factor
+++ b/extra/irc/messages/messages-tests.factor
@ -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
--- a/extra/irc/messages/messages.factor
+++ b/extra/irc/messages/messages.factor
@ -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 ] }
--- a/extra/joystick-demo/authors.txt
+++ b/extra/joystick-demo/authors.txt
@ -0,0 +1 @@
+Joe Groff
--- a/extra/joystick-demo/joystick-demo.factor
+++ b/extra/joystick-demo/joystick-demo.factor
@ -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
--- a/extra/joystick-demo/summary.txt
+++ b/extra/joystick-demo/summary.txt
@ -0,0 +1 @@
+Demonstrate gamepad and joystick input
--- a/extra/joystick-demo/tags.txt
+++ b/extra/joystick-demo/tags.txt
@ -0,0 +1,2 @@
+gamepads
+joysticks
--- a/extra/key-caps/authors.txt
+++ b/extra/key-caps/authors.txt
@ -0,0 +1 @@
+Joe Groff
--- a/extra/key-caps/key-caps.factor
+++ b/extra/key-caps/key-caps.factor
@ -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
--- a/extra/key-caps/summary.txt
+++ b/extra/key-caps/summary.txt
@ -0,0 +1 @@
+Graphical keyboard diagram
--- a/extra/key-caps/tags.txt
+++ b/extra/key-caps/tags.txt
@ -0,0 +1 @@
+keyboard
--- a/extra/math/blas/matrices/matrices-docs.factor
+++ b/extra/math/blas/matrices/matrices-docs.factor
@ -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:"
--- a/extra/math/geometry/rect/rect.factor
+++ b/extra/math/geometry/rect/rect.factor
@ -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- ;
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@ -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 ;

--- a/extra/windows/dinput/constants/constants.factor
+++ b/extra/windows/dinput/constants/constants.factor
--- a/extra/windows/dinput/dinput.factor
+++ b/extra/windows/dinput/dinput.factor
@ -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
--- a/extra/windows/ole32/ole32.factor
+++ b/extra/windows/ole32/ole32.factor
@ -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 ;
--- a/extra/windows/user32/user32.factor
+++ b/extra/windows/user32/user32.factor
@ -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
--- a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor
+++ b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor
@ -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 )
--- a/unfinished/compiler/tree/dead-code/dead-code.factor
+++ b/unfinished/compiler/tree/dead-code/dead-code.factor
@ -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 ;

--- a/unfinished/compiler/tree/def-use/def-use.factor
+++ b/unfinished/compiler/tree/def-use/def-use.factor
@ -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 )
--- a/unfinished/compiler/tree/propagation/info/info-tests.factor
+++ b/unfinished/compiler/tree/propagation/info/info-tests.factor
@ -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
--- a/unfinished/compiler/tree/propagation/info/info.factor
+++ b/unfinished/compiler/tree/propagation/info/info.factor
@ -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 ;
--- a/unfinished/compiler/tree/propagation/known-words/known-words.factor
+++ b/unfinished/compiler/tree/propagation/known-words/known-words.factor
@ -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
--- a/unfinished/compiler/tree/propagation/nodes/nodes.factor
+++ b/unfinished/compiler/tree/propagation/nodes/nodes.factor
@ -16,6 +16,7 @@ GENERIC: propagate-around ( node -- )

 : (propagate) ( node -- )
    [
+        USING: classes prettyprint ; dup class .
        [ propagate-around ] [ successor>> ] bi
        (propagate)
    ] when* ;
--- a/unfinished/compiler/tree/propagation/propagation-tests.factor
+++ b/unfinished/compiler/tree/propagation/propagation-tests.factor
@ -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
--- a/unfinished/compiler/tree/propagation/recursive/recursive.factor
+++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor
@ -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 ;
--- a/unfinished/compiler/tree/propagation/slots/slots.factor
+++ b/unfinished/compiler/tree/propagation/slots/slots.factor
@ -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
--- a/unfinished/compiler/tree/tree.factor
+++ b/unfinished/compiler/tree/tree.factor
@ -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, ;
--- a/unfinished/compiler/tree/untupling/untupling.factor
+++ b/unfinished/compiler/tree/untupling/untupling.factor
@ -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 ;

--- a/unfinished/stack-checker/backend/backend.factor
+++ b/unfinished/stack-checker/backend/backend.factor
@ -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 -- ? )
    {
--- a/unfinished/stack-checker/inlining/inlining.factor
+++ b/unfinished/stack-checker/inlining/inlining.factor
@ -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
--- a/unfinished/stack-checker/transforms/transforms.factor
+++ b/unfinished/stack-checker/transforms/transforms.factor
@ -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 ;

--- a/unfinished/stack-checker/visitor/dummy/dummy.factor
+++ b/unfinished/stack-checker/visitor/dummy/dummy.factor
@ -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 ;
--- a/unfinished/stack-checker/visitor/visitor.factor
+++ b/unfinished/stack-checker/visitor/visitor.factor
@ -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 -- )
				`@ -0,0 +1 @@`
				`Cross-platform joystick, gamepad, and raw keyboard input`