steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-07-28 15:43:27 -05:00
parent 345c7d4d1a 47d8a56dc0
commit 0e44b79245
96 changed files with 3427 additions and 992 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
core/math/intervals/intervals.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice. ! Based on Slate's src/unfinished/interval.slate by Brian Rice.
USING: accessors kernel sequences arrays math math.order USING: accessors kernel sequences arrays math math.order
@ -76,9 +76,11 @@ TUPLE: interval { from read-only } { to read-only } ;
[ from>> ] [ to>> ] bi ; [ from>> ] [ to>> ] bi ;
: points>interval ( seq -- interval ) : points>interval ( seq -- interval )
dup [ first fp-nan? ] contains? [ drop [-inf,inf] ] [
dup first dup first
[ [ endpoint-min ] reduce ] 2keep [ [ endpoint-min ] reduce ] 2keep
[ endpoint-max ] reduce <interval> ; [ endpoint-max ] reduce <interval>
] if ;
: (interval-op) ( p1 p2 quot -- p3 ) : (interval-op) ( p1 p2 quot -- p3 )
[ [ first ] [ first ] [ ] tri* call ] [ [ first ] [ first ] [ ] tri* call ]

1
core/prettyprint/prettyprint.factor
View File

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

2
core/sorting/sorting-docs.factor
View File

@ -20,7 +20,7 @@ ABOUT: "sequences-sorting"
HELP: sort HELP: sort
{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } } { $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } }
{ $description "Sorts the elements into a new sequence of the same class as " { $snippet "seq" } "." } ; { $description "Sorts the elements into a new array." } ;
HELP: sort-keys HELP: sort-keys
{ $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } } { $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } }

2
extra/boids/boids.factor
View File

@ -220,7 +220,7 @@ cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: init-boids ( -- ) 50 random-boids >boids ; : init-boids ( -- ) 100 random-boids >boids ;
: init-world-size ( -- ) { 100 100 } >world-size ; : init-world-size ( -- ) { 100 100 } >world-size ;

24
extra/boids/ui/ui.factor
View File

@ -1,6 +1,7 @@
USING: combinators.short-circuit kernel namespaces USING: combinators.short-circuit kernel namespaces
math math
math.trig
math.functions math.functions
math.vectors math.vectors
math.parser math.parser
@ -21,7 +22,8 @@ USING: combinators.short-circuit kernel namespaces
ui.gestures ui.gestures
assocs.lib vars rewrite-closures boids accessors assocs.lib vars rewrite-closures boids accessors
math.geometry.rect math.geometry.rect
newfx ; newfx
processing.shapes ;
IN: boids.ui IN: boids.ui
@ -29,17 +31,21 @@ IN: boids.ui
! draw-boid ! draw-boid
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: point-a ( boid -- a ) pos>> ; : draw-boid ( boid -- )
glPushMatrix
: point-b ( boid -- b ) [ pos>> ] [ vel>> normalize* 20 v*n ] bi v+ ; dup pos>> gl-translate-2d
vel>> first2 rect> arg rad>deg 0 0 1 glRotated
: boid-points ( boid -- point-a point-b ) [ point-a ] [ point-b ] bi ; { { 0 5 } { 0 -5 } { 20 0 } } triangle
fill-mode
: draw-boid ( boid -- ) boid-points gl-line ; glPopMatrix ;
: draw-boids ( -- ) boids> [ draw-boid ] each ; : draw-boids ( -- ) boids> [ draw-boid ] each ;
: display ( -- ) black gl-color draw-boids ; : boid-color ( -- color ) { 1.0 0 0 0.3 } ;
: display ( -- )
boid-color >fill-color
draw-boids ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

3
extra/bubble-chamber/particle/axion/axion.factor
View File

@ -1,7 +1,8 @@
USING: kernel sequences random accessors multi-methods USING: kernel sequences random accessors multi-methods
math math.constants math.ranges math.points combinators.cleave math math.constants math.ranges math.points combinators.cleave
processing bubble-chamber.common bubble-chamber.particle ; processing processing.shapes
bubble-chamber.common bubble-chamber.particle ;
IN: bubble-chamber.particle.axion IN: bubble-chamber.particle.axion

2
extra/bubble-chamber/particle/hadron/hadron.factor
View File

@ -1,6 +1,6 @@
USING: kernel random math math.constants math.points accessors multi-methods USING: kernel random math math.constants math.points accessors multi-methods
processing processing processing.shapes
processing.color processing.color
bubble-chamber.common bubble-chamber.common
bubble-chamber.particle ; bubble-chamber.particle ;

1
extra/bubble-chamber/particle/muon/muon.factor
View File

@ -7,6 +7,7 @@ USING: kernel arrays sequences random
multi-methods accessors multi-methods accessors
combinators.cleave combinators.cleave
processing processing
processing.shapes
bubble-chamber.common bubble-chamber.common
bubble-chamber.particle bubble-chamber.particle
bubble-chamber.particle.muon.colors ; bubble-chamber.particle.muon.colors ;

2
extra/bubble-chamber/particle/quark/quark.factor
View File

@ -1,6 +1,6 @@
USING: kernel arrays sequences random math accessors multi-methods USING: kernel arrays sequences random math accessors multi-methods
processing processing processing.shapes
bubble-chamber.common bubble-chamber.common
bubble-chamber.particle ; bubble-chamber.particle ;

1
extra/cocoa/cocoa.factor
View File

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

16
extra/cocoa/plists/plists.factor
View File

@ -3,7 +3,7 @@
USING: strings arrays hashtables assocs sequences USING: strings arrays hashtables assocs sequences
cocoa.messages cocoa.classes cocoa.application cocoa kernel cocoa.messages cocoa.classes cocoa.application cocoa kernel
namespaces io.backend math cocoa.enumeration byte-arrays namespaces io.backend math cocoa.enumeration byte-arrays
combinators alien.c-types ; combinators alien.c-types core-foundation ;
IN: cocoa.plists IN: cocoa.plists
GENERIC: >plist ( value -- plist ) GENERIC: >plist ( value -- plist )
@ -24,8 +24,8 @@ M: sequence >plist
[ >plist ] map <NSArray> ; [ >plist ] map <NSArray> ;
: write-plist ( assoc path -- ) : write-plist ( assoc path -- )
>r >plist [ >plist ] [ normalize-path <NSString> ] bi* 0
r> normalize-path <NSString> 0 -> writeToFile:atomically: -> writeToFile:atomically:
[ "write-plist failed" throw ] unless ; [ "write-plist failed" throw ] unless ;
DEFER: plist> DEFER: plist>
@ -57,3 +57,13 @@ DEFER: plist>
{ [ dup NSDictionary -> isKindOfClass: c-bool> ] [ (plist-NSDictionary>) ] } { [ dup NSDictionary -> isKindOfClass: c-bool> ] [ (plist-NSDictionary>) ] }
[ ] [ ]
} cond ; } cond ;
: (read-plist) ( NSData -- id )
NSPropertyListSerialization swap kCFPropertyListImmutable f f <void*>
[ -> propertyListFromData:mutabilityOption:format:errorDescription: ] keep
*void* [ -> release "read-plist failed" throw ] when* ;
: read-plist ( path -- assoc )
normalize-path <NSString>
NSData swap -> dataWithContentsOfFile:
[ (read-plist) plist> ] [ "read-plist failed" throw ] if* ;

36
extra/colors/colors.factor
View File

@ -1,7 +1,43 @@
! Copyright (C) 2003, 2007 Slava Pestov. ! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators sequences arrays
classes.tuple multi-methods accessors colors.hsv ;
IN: colors IN: colors
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: color ;
TUPLE: rgba < color red green blue alpha ;
TUPLE: hsva < color hue saturation value alpha ;
TUPLE: grey < color grey alpha ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
GENERIC: >rgba ( object -- rgba )
METHOD: >rgba { rgba } ;
METHOD: >rgba { hsva }
{ [ hue>> ] [ saturation>> ] [ value>> ] [ alpha>> ] } cleave 4array
[ hsv>rgb ] [ peek ] bi suffix first4 rgba boa ;
METHOD: >rgba { grey } [ grey>> dup dup ] [ alpha>> ] bi rgba boa ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USE: syntax
M: color red>> >rgba red>> ;
M: color green>> >rgba green>> ;
M: color blue>> >rgba blue>> ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: black { 0.0 0.0 0.0 1.0 } ; : black { 0.0 0.0 0.0 1.0 } ;
: blue { 0.0 0.0 1.0 1.0 } ; : blue { 0.0 0.0 1.0 1.0 } ;
: cyan { 0 0.941 0.941 1 } ; : cyan { 0 0.941 0.941 1 } ;

9
extra/combinators/lib/lib-tests.factor
View File

@ -2,6 +2,15 @@ USING: combinators.lib kernel math random sequences tools.test continuations
arrays vectors ; arrays vectors ;
IN: combinators.lib.tests IN: combinators.lib.tests
[ 6 -1 ] [ 5 0 1 [ + ] [ - ] bi, bi* ] unit-test
[ 6 -1 1 ] [ 5 0 1 1 [ + ] [ - ] [ * ] tri, tri* ] unit-test
[ 5 4 ] [ 5 0 1 [ + ] [ - ] bi*, bi ] unit-test
[ 5 4 5 ] [ 5 0 1 1 [ + ] [ - ] [ * ] tri*, tri ] unit-test
[ 5 6 ] [ 5 0 1 [ + ] bi@, bi ] unit-test
[ 5 6 7 ] [ 5 0 1 2 [ + ] tri@, tri ] unit-test
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test [ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test

19
extra/combinators/lib/lib.factor
View File

@ -8,6 +8,25 @@ generalizations macros continuations locals ;
IN: combinators.lib IN: combinators.lib
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Currying cleave combinators
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: bi, ( obj quot quot -- quot' quot' )
[ [ curry ] curry ] bi@ bi ; inline
: tri, ( obj quot quot quot -- quot' quot' quot' )
[ [ curry ] curry ] tri@ tri ; inline
: bi*, ( obj obj quot quot -- quot' quot' )
[ [ curry ] curry ] bi@ bi* ; inline
: tri*, ( obj obj obj quot quot quot -- quot' quot' quot' )
[ [ curry ] curry ] tri@ tri* ; inline
: bi@, ( obj obj quot -- quot' quot' )
[ curry ] curry bi@ ; inline
: tri@, ( obj obj obj quot -- quot' quot' quot' )
[ curry ] curry tri@ ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Generalized versions of core combinators ! Generalized versions of core combinators
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

5
extra/core-foundation/core-foundation.factor
View File

@ -43,6 +43,11 @@ TYPEDEF: int CFNumberType
: kCFNumberCGFloatType 16 ; inline : kCFNumberCGFloatType 16 ; inline
: kCFNumberMaxType 16 ; inline : kCFNumberMaxType 16 ; inline
TYPEDEF: int CFPropertyListMutabilityOptions
: kCFPropertyListImmutable 0 ; inline
: kCFPropertyListMutableContainers 1 ; inline
: kCFPropertyListMutableContainersAndLeaves 2 ; inline
FUNCTION: CFArrayRef CFArrayCreateMutable ( CFAllocatorRef allocator, CFIndex capacity, void* callbacks ) ; FUNCTION: CFArrayRef CFArrayCreateMutable ( CFAllocatorRef allocator, CFIndex capacity, void* callbacks ) ;
FUNCTION: void* CFArrayGetValueAtIndex ( CFArrayRef array, CFIndex idx ) ; FUNCTION: void* CFArrayGetValueAtIndex ( CFArrayRef array, CFIndex idx ) ;

1
extra/game-input/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

1
extra/game-input/backend/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

8
extra/game-input/backend/backend.factor Normal file
View File

@ -0,0 +1,8 @@
USING: kernel system combinators parser ;
IN: game-input.backend
<< {
{ [ os macosx? ] [ "game-input.backend.iokit" use+ ] }
{ [ os windows? ] [ "game-input.backend.dinput" use+ ] }
{ [ t ] [ ] }
} cond >>

1
extra/game-input/backend/dinput/authors.txt Executable file
View File

@ -0,0 +1 @@
Joe Groff

282
extra/game-input/backend/dinput/dinput.factor Executable file
View File

@ -0,0 +1,282 @@
USING: windows.dinput windows.dinput.constants game-input
symbols alien.c-types windows.ole32 namespaces assocs kernel
arrays vectors windows.kernel32 windows.com windows.dinput
shuffle windows.user32 windows.messages sequences combinators
math.geometry.rect ui.windows accessors math windows alien
alien.strings io.encodings.utf16 continuations byte-arrays
locals game-input.backend.dinput.keys-array ;
IN: game-input.backend.dinput
SINGLETON: dinput-game-input-backend
SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
+controller-devices+ +controller-guids+
+device-change-window+ +device-change-handle+ ;
: create-dinput ( -- )
f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
f <void*> [ f DirectInput8Create ole32-error ] keep *void*
+dinput+ set-global ;
: delete-dinput ( -- )
+dinput+ global [ com-release f ] change-at ;
: device-for-guid ( guid -- device )
+dinput+ get swap f <void*>
[ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
: set-coop-level ( device -- )
+device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
IDirectInputDevice8W::SetCooperativeLevel ole32-error ;
: set-data-format ( device format-symbol -- )
get IDirectInputDevice8W::SetDataFormat ole32-error ;
: configure-keyboard ( keyboard -- )
[ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
: configure-controller ( controller -- )
[ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ;
: find-keyboard ( -- )
GUID_SysKeyboard device-for-guid
[ configure-keyboard ]
[ +keyboard-device+ set-global ] bi
256 <byte-array> <keys-array> keyboard-state boa
+keyboard-state+ set-global ;
: device-info ( device -- DIDEVICEIMAGEINFOW )
"DIDEVICEINSTANCEW" <c-object>
"DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
[ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ;
: device-caps ( device -- DIDEVCAPS )
"DIDEVCAPS" <c-object>
"DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize
[ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ;
: <guid> ( memory -- byte-array )
"GUID" heap-size memory>byte-array ;
: device-guid ( device -- guid )
device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
: device-attached? ( device -- ? )
+dinput+ get swap device-guid
IDirectInput8W::GetDeviceStatus S_OK = ;
: find-device-axes-callback ( -- alien )
[ ! ( lpddoi pvRef -- BOOL )
+controller-devices+ get at
swap DIDEVICEOBJECTINSTANCEW-guidType <guid> {
{ [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
{ [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
{ [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
{ [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] }
{ [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] }
{ [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] }
{ [ dup GUID_Slider = ] [ drop 0.0 >>slider ] }
[ drop ]
} cond drop
DIENUM_CONTINUE
] LPDIENUMDEVICEOBJECTSCALLBACKW ;
: find-device-axes ( device controller-state -- controller-state )
swap [ +controller-devices+ get set-at ] 2keep
find-device-axes-callback over DIDFT_AXIS
IDirectInputDevice8W::EnumObjects ole32-error ;
: controller-state-template ( device -- controller-state )
controller-state new
over device-caps
[ DIDEVCAPS-dwButtons f <array> >>buttons ]
[ DIDEVCAPS-dwPOVs zero? f pov-neutral ? >>pov ] bi
find-device-axes ;
: device-known? ( guid -- ? )
+controller-guids+ get key? ; inline
: (add-controller) ( guid -- )
device-for-guid {
[ configure-controller ]
[ controller-state-template ]
[ dup device-guid +controller-guids+ get set-at ]
[ +controller-devices+ get set-at ]
} cleave ;
: add-controller ( guid -- )
dup <guid> device-known? [ drop ] [ (add-controller) ] if ;
: remove-controller ( device -- )
[ +controller-devices+ get delete-at ]
[ device-guid +controller-guids+ get delete-at ]
[ com-release ] tri ;
: find-controller-callback ( -- alien )
[ ! ( lpddi pvRef -- BOOL )
drop DIDEVICEINSTANCEW-guidInstance add-controller
DIENUM_CONTINUE
] LPDIENUMDEVICESCALLBACKW ;
: find-controllers ( -- )
+dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ;
: set-up-controllers ( -- )
4 <vector> +controller-devices+ set-global
4 <vector> +controller-guids+ set-global
find-controllers ;
: find-and-remove-detached-devices ( -- )
+controller-devices+ get keys
[ device-attached? not ] filter
[ remove-controller ] each ;
: device-interface? ( dbt-broadcast-hdr -- ? )
DEV_BROADCAST_HDR-dbch_devicetype DBT_DEVTYP_DEVICEINTERFACE = ;
: device-arrived ( dbt-broadcast-hdr -- )
device-interface? [ find-controllers ] when ;
: device-removed ( dbt-broadcast-hdr -- )
device-interface? [ find-and-remove-detached-devices ] when ;
: handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
[ 2drop ] 2dip swap {
{ [ dup DBT_DEVICEARRIVAL = ] [ drop <alien> device-arrived ] }
{ [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <alien> device-removed ] }
[ 2drop ]
} cond ;
TUPLE: window-rect < rect window-loc ;
: <zero-window-rect> ( -- window-rect )
window-rect new
{ 0 0 } >>window-loc
{ 0 0 } >>loc
{ 0 0 } >>dim ;
: (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
"DEV_BROADCAST_DEVICEW" <c-object>
"DEV_BROADCAST_DEVICEW" heap-size over set-DEV_BROADCAST_DEVICEW-dbcc_size
DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
: create-device-change-window ( -- )
<zero-window-rect> create-window
[
(device-notification-filter)
DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor
RegisterDeviceNotification
+device-change-handle+ set-global
]
[ +device-change-window+ set-global ] bi ;
: close-device-change-window ( -- )
+device-change-handle+ global
[ UnregisterDeviceNotification drop f ] change-at
+device-change-window+ global
[ DestroyWindow win32-error=0/f f ] change-at ;
: add-wm-devicechange ( -- )
[ 4dup handle-wm-devicechange DefWindowProc ]
WM_DEVICECHANGE add-wm-handler ;
: remove-wm-devicechange ( -- )
WM_DEVICECHANGE wm-handlers get-global delete-at ;
: release-controllers ( -- )
+controller-devices+ global [
[ drop com-release ] assoc-each f
] change-at
f +controller-guids+ set-global ;
: release-keyboard ( -- )
+keyboard-device+ global
[ com-release f ] change-at
f +keyboard-state+ set-global ;
M: dinput-game-input-backend (open-game-input)
create-dinput
create-device-change-window
find-keyboard
set-up-controllers
add-wm-devicechange ;
M: dinput-game-input-backend (close-game-input)
remove-wm-devicechange
release-controllers
release-keyboard
close-device-change-window
delete-dinput ;
M: dinput-game-input-backend get-controllers
+controller-devices+ get
[ drop controller boa ] { } assoc>map ;
M: dinput-game-input-backend product-string
handle>> device-info DIDEVICEINSTANCEW-tszProductName
utf16n alien>string ;
M: dinput-game-input-backend product-id
handle>> device-info DIDEVICEINSTANCEW-guidProduct <guid> ;
M: dinput-game-input-backend instance-id
handle>> device-guid ;
:: with-acquisition ( device acquired-quot succeeded-quot failed-quot -- result/f )
device IDirectInputDevice8W::Acquire succeeded? [
device acquired-quot call
succeeded-quot call
] failed-quot if ; inline
: pov-values
{
pov-up pov-up-right pov-right pov-down-right
pov-down pov-down-left pov-left pov-up-left
} ; inline
: >axis ( long -- float )
32767 - 32767.0 /f ;
: >slider ( long -- float )
65535.0 /f ;
: >pov ( long -- symbol )
dup HEX: FFFF bitand HEX: FFFF =
[ drop pov-neutral ]
[ 2750 + 4500 /i pov-values nth ] if ;
: >buttons ( alien length -- array )
memory>byte-array <keys-array> ;
: (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
[ drop ] compose [ 2drop ] if ; inline
: fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
{
[ over x>> [ DIJOYSTATE2-lX >axis >>x ] (fill-if) ]
[ over y>> [ DIJOYSTATE2-lY >axis >>y ] (fill-if) ]
[ over z>> [ DIJOYSTATE2-lZ >axis >>z ] (fill-if) ]
[ over rx>> [ DIJOYSTATE2-lRx >axis >>rx ] (fill-if) ]
[ over ry>> [ DIJOYSTATE2-lRy >axis >>ry ] (fill-if) ]
[ over rz>> [ DIJOYSTATE2-lRz >axis >>rz ] (fill-if) ]
[ over slider>> [ DIJOYSTATE2-rglSlider *long >slider >>slider ] (fill-if) ]
[ over pov>> [ DIJOYSTATE2-rgdwPOV *uint >pov >>pov ] (fill-if) ]
[ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
} 2cleave ;
: get-device-state ( device byte-array -- )
[ dup IDirectInputDevice8W::Poll ole32-error ] dip
[ length ] keep
IDirectInputDevice8W::GetDeviceState ole32-error ;
: (read-controller) ( handle template -- state )
swap [ "DIJOYSTATE2" heap-size <byte-array> [ get-device-state ] keep ]
[ fill-controller-state ] [ drop f ] with-acquisition ;
M: dinput-game-input-backend read-controller
handle>> dup +controller-devices+ get at
[ (read-controller) ] [ drop f ] if* ;
M: dinput-game-input-backend calibrate-controller
handle>> f 0 IDirectInputDevice8W::RunControlPanel ole32-error ;
M: dinput-game-input-backend read-keyboard
+keyboard-device+ get
[ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
[ ] [ f ] with-acquisition ;
dinput-game-input-backend game-input-backend set-global

15
extra/game-input/backend/dinput/keys-array/keys-array.factor Executable file
View File

@ -0,0 +1,15 @@
USING: sequences sequences.private math alien.c-types
accessors ;
IN: game-input.backend.dinput.keys-array
TUPLE: keys-array underlying ;
C: <keys-array> keys-array
: >key ( byte -- ? )
HEX: 80 bitand c-bool> ;
M: keys-array length underlying>> length ;
M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
INSTANCE: keys-array sequence

1
extra/game-input/backend/dinput/summary.txt Executable file
View File

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

4
extra/game-input/backend/dinput/tags.txt Executable file
View File

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

1
extra/game-input/backend/iokit/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

275
extra/game-input/backend/iokit/iokit.factor Executable file
View File

@ -0,0 +1,275 @@
USING: cocoa cocoa.plists core-foundation iokit iokit.hid
kernel cocoa.enumeration destructors math.parser cocoa.application
sequences locals combinators.short-circuit game-input threads
symbols namespaces assocs vectors arrays combinators
core-foundation.run-loop accessors sequences.private
alien.c-types math ;
IN: game-input.backend.iokit
SINGLETON: iokit-game-input-backend
: hid-manager-matching ( matching-seq -- alien )
f 0 IOHIDManagerCreate
[ swap >plist IOHIDManagerSetDeviceMatchingMultiple ]
keep ;
: devices-from-hid-manager ( manager -- vector )
[
IOHIDManagerCopyDevices
[ &CFRelease NSFastEnumeration>vector ] [ f ] if*
] with-destructors ;
: game-devices-matching-seq
{
H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
} ; inline
: buttons-matching-hash
H{ { "UsagePage" 9 } { "Type" 2 } } ; inline
: keys-matching-hash
H{ { "UsagePage" 7 } { "Type" 2 } } ; inline
: x-axis-matching-hash
H{ { "UsagePage" 1 } { "Usage" HEX: 30 } { "Type" 1 } } ; inline
: y-axis-matching-hash
H{ { "UsagePage" 1 } { "Usage" HEX: 31 } { "Type" 1 } } ; inline
: z-axis-matching-hash
H{ { "UsagePage" 1 } { "Usage" HEX: 32 } { "Type" 1 } } ; inline
: rx-axis-matching-hash
H{ { "UsagePage" 1 } { "Usage" HEX: 33 } { "Type" 1 } } ; inline
: ry-axis-matching-hash
H{ { "UsagePage" 1 } { "Usage" HEX: 34 } { "Type" 1 } } ; inline
: rz-axis-matching-hash
H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } } ; inline
: slider-matching-hash
H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } } ; inline
: hat-switch-matching-hash
H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } } ; inline
: device-elements-matching ( device matching-hash -- vector )
[
>plist 0 IOHIDDeviceCopyMatchingElements
[ &CFRelease NSFastEnumeration>vector ] [ f ] if*
] with-destructors ;
: button-count ( device -- button-count )
buttons-matching-hash device-elements-matching length ;
: ?axis ( device hash -- axis/f )
device-elements-matching dup empty? [ drop f ] [ first ] if ;
: ?x-axis ( device -- ? )
x-axis-matching-hash ?axis ;
: ?y-axis ( device -- ? )
y-axis-matching-hash ?axis ;
: ?z-axis ( device -- ? )
z-axis-matching-hash ?axis ;
: ?rx-axis ( device -- ? )
rx-axis-matching-hash ?axis ;
: ?ry-axis ( device -- ? )
ry-axis-matching-hash ?axis ;
: ?rz-axis ( device -- ? )
rz-axis-matching-hash ?axis ;
: ?slider ( device -- ? )
slider-matching-hash ?axis ;
: ?hat-switch ( device -- ? )
hat-switch-matching-hash ?axis ;
: hid-manager-matching-game-devices ( -- alien )
game-devices-matching-seq hid-manager-matching ;
: device-property ( device key -- value )
<NSString> IOHIDDeviceGetProperty plist> ;
: element-property ( element key -- value )
<NSString> IOHIDElementGetProperty plist> ;
: set-element-property ( element key value -- )
[ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
: transfer-element-property ( element from-key to-key -- )
[ dupd element-property ] dip swap set-element-property ;
: controller-device? ( device -- ? )
{
[ 1 4 IOHIDDeviceConformsTo ]
[ 1 5 IOHIDDeviceConformsTo ]
} 1|| ;
: element-usage ( element -- {usage-page,usage} )
[ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
2array ;
: button? ( {usage-page,usage} -- ? )
first 9 = ; inline
: keyboard-key? ( {usage-page,usage} -- ? )
first 7 = ; inline
: x-axis? ( {usage-page,usage} -- ? )
{ 1 HEX: 30 } = ; inline
: y-axis? ( {usage-page,usage} -- ? )
{ 1 HEX: 31 } = ; inline
: z-axis? ( {usage-page,usage} -- ? )
{ 1 HEX: 32 } = ; inline
: rx-axis? ( {usage-page,usage} -- ? )
{ 1 HEX: 33 } = ; inline
: ry-axis? ( {usage-page,usage} -- ? )
{ 1 HEX: 34 } = ; inline
: rz-axis? ( {usage-page,usage} -- ? )
{ 1 HEX: 35 } = ; inline
: slider? ( {usage-page,usage} -- ? )
{ 1 HEX: 36 } = ; inline
: hat-switch? ( {usage-page,usage} -- ? )
{ 1 HEX: 39 } = ; inline
: pov-values
{
pov-up pov-up-right pov-right pov-down-right
pov-down pov-down-left pov-left pov-up-left
pov-neutral
} ; inline
: button-value ( value -- f/(0,1] )
IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
: axis-value ( value -- [-1,1] )
kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
: pov-value ( value -- pov-direction )
IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
: record-controller ( controller-state value -- )
dup IOHIDValueGetElement element-usage {
{ [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] }
{ [ dup x-axis? ] [ drop axis-value >>x drop ] }
{ [ dup y-axis? ] [ drop axis-value >>y drop ] }
{ [ dup z-axis? ] [ drop axis-value >>z drop ] }
{ [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
{ [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
{ [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
{ [ dup slider? ] [ drop axis-value >>slider drop ] }
{ [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
[ 3drop ]
} cond ;
SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
: ?set-nth ( value nth seq -- )
2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
: record-keyboard ( value -- )
dup IOHIDValueGetElement element-usage keyboard-key? [
[ IOHIDValueGetIntegerValue c-bool> ]
[ IOHIDValueGetElement IOHIDElementGetUsage ] bi
+keyboard-state+ get ?set-nth
] [ drop ] if ;
: default-calibrate-saturation ( element -- )
[ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
[ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ]
bi ;
: default-calibrate-axis ( element -- )
[ kIOHIDElementCalibrationMinKey -1.0 set-element-property ]
[ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
[ default-calibrate-saturation ]
tri ;
: default-calibrate-slider ( element -- )
[ kIOHIDElementCalibrationMinKey 0.0 set-element-property ]
[ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
[ default-calibrate-saturation ]
tri ;
: (default) ( ? quot -- )
[ f ] if* ; inline
: <device-controller-state> ( device -- controller-state )
{
[ ?x-axis [ default-calibrate-axis 0.0 ] (default) ]
[ ?y-axis [ default-calibrate-axis 0.0 ] (default) ]
[ ?z-axis [ default-calibrate-axis 0.0 ] (default) ]
[ ?rx-axis [ default-calibrate-axis 0.0 ] (default) ]
[ ?ry-axis [ default-calibrate-axis 0.0 ] (default) ]
[ ?rz-axis [ default-calibrate-axis 0.0 ] (default) ]
[ ?slider [ default-calibrate-slider 0.0 ] (default) ]
[ ?hat-switch pov-neutral and ]
[ button-count f <array> ]
} cleave controller-state boa ;
: device-matched-callback ( -- alien )
[| context result sender device |
device controller-device? [
device <device-controller-state>
device +controller-states+ get set-at
] when
] IOHIDDeviceCallback ;
: device-removed-callback ( -- alien )
[| context result sender device |
device +controller-states+ get delete-at
] IOHIDDeviceCallback ;
: device-input-callback ( -- alien )
[| context result sender value |
sender controller-device?
[ sender +controller-states+ get at value record-controller ]
[ value record-keyboard ]
if
] IOHIDValueCallback ;
: initialize-variables ( manager -- )
+hid-manager+ set-global
4 <vector> +controller-states+ set-global
256 f <array> +keyboard-state+ set-global ;
M: iokit-game-input-backend (open-game-input)
hid-manager-matching-game-devices {
[ initialize-variables ]
[ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
[ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
[ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
[ 0 IOHIDManagerOpen mach-error ]
[
CFRunLoopGetMain CFRunLoopDefaultMode
IOHIDManagerScheduleWithRunLoop
]
} cleave ;
M: iokit-game-input-backend (close-game-input)
+hid-manager+ get-global [
+hid-manager+ global [
[
CFRunLoopGetMain CFRunLoopDefaultMode
IOHIDManagerUnscheduleFromRunLoop
]
[ 0 IOHIDManagerClose drop ]
[ CFRelease ] tri
f
] change-at
f +keyboard-state+ set-global
f +controller-states+ set-global
] when ;
M: iokit-game-input-backend get-controllers ( -- sequence )
+controller-states+ get keys [ controller boa ] map ;
: ?join ( pre post sep -- string )
2over start [ swap 2nip ] [ [ 2array ] dip join ] if ;
M: iokit-game-input-backend product-string ( controller -- string )
handle>>
[ kIOHIDManufacturerKey device-property ]
[ kIOHIDProductKey device-property ] bi " " ?join ;
M: iokit-game-input-backend product-id ( controller -- integer )
handle>>
[ kIOHIDVendorIDKey device-property ]
[ kIOHIDProductIDKey device-property ] bi 2array ;
M: iokit-game-input-backend instance-id ( controller -- integer )
handle>> kIOHIDLocationIDKey device-property ;
M: iokit-game-input-backend read-controller ( controller -- controller-state )
handle>> +controller-states+ get at clone ;
M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
+keyboard-state+ get clone keyboard-state boa ;
M: iokit-game-input-backend calibrate-controller ( controller -- )
drop ;
iokit-game-input-backend game-input-backend set-global

1
extra/game-input/backend/iokit/summary.txt Normal file
View File

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

4
extra/game-input/backend/iokit/tags.txt Normal file
View File

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

1
extra/game-input/backend/summary.txt Normal file
View File

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

3
extra/game-input/backend/tags.txt Normal file
View File

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

126
extra/game-input/game-input-docs.factor Executable file
View File

@ -0,0 +1,126 @@
USING: help.markup help.syntax kernel ui.gestures quotations
sequences strings math ;
IN: game-input
ARTICLE: "game-input" "Game controller input"
"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard input." $nl
"The game input interface must be initialized before being used:"
{ $subsection open-game-input }
{ $subsection close-game-input }
{ $subsection with-game-input }
"Once the game input interface is open, connected controller devices can be enumerated:"
{ $subsection get-controllers }
{ $subsection find-controller-products }
{ $subsection find-controller-instance }
"These " { $link controller } " objects can be queried of their identity:"
{ $subsection product-string }
{ $subsection product-id }
{ $subsection instance-id }
"A hook is provided for invoking the system calibration tool:"
{ $subsection calibrate-controller }
"The current state of a controller or the keyboard can be read:"
{ $subsection read-controller }
{ $subsection read-keyboard }
{ $subsection controller-state }
{ $subsection keyboard-state } ;
HELP: open-game-input
{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ;
HELP: close-game-input
{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid. If the game input interface is not opened, nothing happens." } ;
HELP: game-input-opened?
{ $values { "?" "a boolean" } }
{ $description "Returns true if the game input interface is open, false otherwise." } ;
HELP: with-game-input
{ $values { "quot" quotation } }
{ $description "Initializes the game input interface for the dynamic extent of " { $snippet "quotation" } "." } ;
{ open-game-input close-game-input with-game-input game-input-opened? } related-words
HELP: get-controllers
{ $values { "sequence" "A " { $link sequence } " of " { $link controller } "s" } }
{ $description "Returns a " { $link sequence } " of " { $link controller } " objects representing the currently connected game controllers. The order of the controller objects in the sequence is not significant or guaranteed to be stable between calls to " { $snippet "get-controllers" } "." } ;
HELP: find-controller-products
{ $values { "product-id" "A product ID as returned by " { $link product-id } } { "sequence" "A " { $link sequence } " of " { $link controller } "s" } }
{ $description "Returns a " { $link sequence } " of " { $link controller } " objects representing the currently connected game controllers with the given " { $link product-id } ". The order of the controller objects in the sequence is not significant or guaranteed to be stable between calls to " { $snippet "find-controller-products" } "." } ;
HELP: find-controller-instance
{ $values { "product-id" "A product ID as returned by " { $link product-id } } { "instance-id" "An instance ID as returned by " { $link instance-id } "." } { "controller/f" "A " { $link controller } " object, or " { $link f } } }
{ $description "Returns the " { $link controller } " instance identified by " { $snippet "product-id" } " and " { $snippet "instance-id" } ". If the identified device is not currently attached, " { $link f } " is returned." } ;
HELP: controller
{ $class-description "Objects of this class represent game controller devices such as joysticks and gamepads. They should be treated as opaque by client code." } ;
HELP: product-string
{ $values { "controller" controller } { "string" string } }
{ $description "Returns a human-readable string describing the game controller device represented by " { $snippet "controller" } ". This string is not necessarily unique to the product or instance; to uniquely identify the device, see " { $link product-id } " and " { $link instance-id } "." } ;
HELP: product-id
{ $values { "controller" controller } { "id" "A unique identifier" } }
{ $description "Returns an identifier uniquely representing the kind of game controller device represented by " { $snippet "controller" } ". This identifier will be the same for devices of the same make and manufacturer. The type of the identifier value is platform-specific, but equivalent " { $snippet "product-id" } "s are guaranteed to be testable with the " { $link = } " word. The identifier can be used to find devices of the same kind with the " { $link find-controller-products } " word." } ;
HELP: instance-id
{ $values { "controller" controller } { "id" "A unique identifier" } }
{ $description "Returns an identifier uniquely representing the game controller device represented by " { $snippet "controller" } ". This identifier paired with the device's " { $link product-id } " provides a unique identifier for a particular device that persists between reboots (but not necessarily between computers). This unique identifier can be used to find the same device again with the " { $snippet "find-controller-instance" } " word. Depending on the platform, the instance-id may change if the device is plugged into a different port. The type of the identifier value is platform-specific, but equivalent " { $snippet "instance-id" } "s are guaranteed to be testable with the " { $link = } " word." } ;
{ product-string product-id instance-id find-controller-products find-controller-instance } related-words
HELP: calibrate-controller
{ $values { "controller" controller } }
{ $description "Invokes the operating system's calibration tool for " { $snippet "controller" } ". If the operating system does not have a calibration tool, this word does nothing." } ;
HELP: read-controller
{ $values { "controller" controller } { "controller-state" controller-state } }
{ $description "Reads the current state of " { $snippet "controller" } ". See the documentation for the " { $link controller-state } " class for details of the returned value's format. If the device is no longer available, " { $link f } " is returned." }
{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "controller-state" } " object next time " { $snippet "read-controller" } " is called on the same controller. You should " { $link clone } " any values from the returned tuple you need to preserve." } ;
{ controller-state controller read-controller } related-words
HELP: read-keyboard
{ $values { "keyboard-state" keyboard-state } }
{ $description "Reads the current raw state of the keyboard. See the documentation for the " { $link keyboard-state } " class for details on the returned value's format." }
{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "keyboard-state" } " object next time " { $snippet "read-keyboard" } " is called. You should " { $link clone } " any values from the returned tuple you need to preserve."
$nl "The keyboard state returned by this word is unprocessed by any keymaps, modifier keys, key repeat settings, or other operating environment postprocessing. Because of this, " { $snippet "read-keyboard" } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
HELP: controller-state
{ $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:"
{ $list
{ { $snippet "x" } " contains the position of the device's X axis." }
{ { $snippet "y" } " contains the position of the device's Y axis." }
{ { $snippet "z" } " contains the position of the device's Z axis, if any." }
{ { $snippet "rx" } " contains the rotational position of the device's X axis, if available." }
{ { $snippet "ry" } " contains the rotational position of the device's Y axis, if available." }
{ { $snippet "rz" } " contains the rotational position of the device's Z axis, if available." }
{ { $snippet "slider" } " contains the position of the device's throttle slider, if any." }
{ { $snippet "pov" } " contains the state of the device's POV hat, if any." }
{ { $snippet "buttons" } " contains a sequence of values indicating the state of every button on the device." }
}
"The values are formatted as follows:"
{ $list
{ "For the axis slots (" { $snippet "x" } ", " { $snippet "y" } ", " { $snippet "z" } ", " { $snippet "rx" } ", " { $snippet "ry" } ", " { $snippet "rz" } "), a " { $link float } " value between -1.0 and 1.0 is returned." }
{ "For the " { $snippet "slider" } " slot, a value between 0.0 and 1.0 is returned." }
{ "For the " { $snippet "pov" } " slot, one of the following symbols is returned:" { $list
{ { $link pov-neutral } }
{ { $link pov-up } }
{ { $link pov-up-right } }
{ { $link pov-right } }
{ { $link pov-down-right } }
{ { $link pov-down } }
{ { $link pov-down-left } }
{ { $link pov-left } }
{ { $link pov-up-left } }
} }
{ "For each element of the " { $snippet "buttons" } " array, " { $link f } " indicates that the corresponding button is released. If the button is pressed, a value between 0.0 and 1.0 is returned indicating the pressure on the button (or simply 1.0 if the device's buttons are on/off only)." }
{ "A value of " { $link f } " in any slot (besides the elements of " { $snippet "buttons" } ") indicates that the corresponding element is not present on the device." } } } ;
HELP: keyboard-state
{ $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined under usage page 7 of the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game-input.scancodes" } " vocabulary." }
{ $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps, modifier keys, or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game-input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
{ keyboard-state read-keyboard } related-words
ABOUT: "game-input"

60
extra/game-input/game-input.factor Executable file
View File

@ -0,0 +1,60 @@
USING: arrays accessors continuations kernel symbols
combinators.lib sequences namespaces ;
IN: game-input
SYMBOLS: game-input-backend game-input-opened ;
HOOK: (open-game-input) game-input-backend ( -- )
HOOK: (close-game-input) game-input-backend ( -- )
: game-input-opened? ( -- ? )
game-input-opened get ;
: open-game-input ( -- )
game-input-opened? [
(open-game-input)
game-input-opened on
] unless ;
: close-game-input ( -- )
game-input-opened? [
(close-game-input)
game-input-opened off
] when ;
: with-game-input ( quot -- )
open-game-input [ close-game-input ] [ ] cleanup ;
TUPLE: controller handle ;
TUPLE: controller-state x y z rx ry rz slider pov buttons ;
M: controller-state clone
call-next-method dup buttons>> clone >>buttons ;
SYMBOLS:
pov-neutral
pov-up pov-up-right pov-right pov-down-right
pov-down pov-down-left pov-left pov-up-left ;
HOOK: get-controllers game-input-backend ( -- sequence )
HOOK: product-string game-input-backend ( controller -- string )
HOOK: product-id game-input-backend ( controller -- id )
HOOK: instance-id game-input-backend ( controller -- id )
: find-controller-products ( product-id -- sequence )
get-controllers [ product-id = ] with filter ;
: find-controller-instance ( product-id instance-id -- controller/f )
get-controllers [
[ product-id = ]
[ instance-id = ] bi, bi* and
] 2with find nip ;
HOOK: read-controller game-input-backend ( controller -- controller-state )
HOOK: calibrate-controller game-input-backend ( controller -- )
TUPLE: keyboard-state keys ;
M: keyboard-state clone
call-next-method dup keys>> clone >>keys ;
HOOK: read-keyboard game-input-backend ( -- keyboard-state )

1
extra/game-input/scancodes/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

175
extra/game-input/scancodes/scancodes.factor Normal file
View File

@ -0,0 +1,175 @@
IN: game-input.scancodes
: key-undefined HEX: 0000 ; inline
: key-error-roll-over HEX: 0001 ; inline
: key-error-post-fail HEX: 0002 ; inline
: key-error-undefined HEX: 0003 ; inline
: key-a HEX: 0004 ; inline
: key-b HEX: 0005 ; inline
: key-c HEX: 0006 ; inline
: key-d HEX: 0007 ; inline
: key-e HEX: 0008 ; inline
: key-f HEX: 0009 ; inline
: key-g HEX: 000a ; inline
: key-h HEX: 000b ; inline
: key-i HEX: 000c ; inline
: key-j HEX: 000d ; inline
: key-k HEX: 000e ; inline
: key-l HEX: 000f ; inline
: key-m HEX: 0010 ; inline
: key-n HEX: 0011 ; inline
: key-o HEX: 0012 ; inline
: key-p HEX: 0013 ; inline
: key-q HEX: 0014 ; inline
: key-r HEX: 0015 ; inline
: key-s HEX: 0016 ; inline
: key-t HEX: 0017 ; inline
: key-u HEX: 0018 ; inline
: key-v HEX: 0019 ; inline
: key-w HEX: 001a ; inline
: key-x HEX: 001b ; inline
: key-y HEX: 001c ; inline
: key-z HEX: 001d ; inline
: key-1 HEX: 001e ; inline
: key-2 HEX: 001f ; inline
: key-3 HEX: 0020 ; inline
: key-4 HEX: 0021 ; inline
: key-5 HEX: 0022 ; inline
: key-6 HEX: 0023 ; inline
: key-7 HEX: 0024 ; inline
: key-8 HEX: 0025 ; inline
: key-9 HEX: 0026 ; inline
: key-0 HEX: 0027 ; inline
: key-return HEX: 0028 ; inline
: key-escape HEX: 0029 ; inline
: key-backspace HEX: 002a ; inline
: key-tab HEX: 002b ; inline
: key-space HEX: 002c ; inline
: key-- HEX: 002d ; inline
: key-= HEX: 002e ; inline
: key-[ HEX: 002f ; inline
: key-] HEX: 0030 ; inline
: key-\ HEX: 0031 ; inline
: key-#-non-us HEX: 0032 ; inline
: key-; HEX: 0033 ; inline
: key-' HEX: 0034 ; inline
: key-` HEX: 0035 ; inline
: key-, HEX: 0036 ; inline
: key-. HEX: 0037 ; inline
: key-/ HEX: 0038 ; inline
: key-caps-lock HEX: 0039 ; inline
: key-f1 HEX: 003a ; inline
: key-f2 HEX: 003b ; inline
: key-f3 HEX: 003c ; inline
: key-f4 HEX: 003d ; inline
: key-f5 HEX: 003e ; inline
: key-f6 HEX: 003f ; inline
: key-f7 HEX: 0040 ; inline
: key-f8 HEX: 0041 ; inline
: key-f9 HEX: 0042 ; inline
: key-f10 HEX: 0043 ; inline
: key-f11 HEX: 0044 ; inline
: key-f12 HEX: 0045 ; inline
: key-print-screen HEX: 0046 ; inline
: key-scroll-lock HEX: 0047 ; inline
: key-pause HEX: 0048 ; inline
: key-insert HEX: 0049 ; inline
: key-home HEX: 004a ; inline
: key-page-up HEX: 004b ; inline
: key-delete HEX: 004c ; inline
: key-end HEX: 004d ; inline
: key-page-down HEX: 004e ; inline
: key-right-arrow HEX: 004f ; inline
: key-left-arrow HEX: 0050 ; inline
: key-down-arrow HEX: 0051 ; inline
: key-up-arrow HEX: 0052 ; inline
: key-keypad-numlock HEX: 0053 ; inline
: key-keypad-/ HEX: 0054 ; inline
: key-keypad-* HEX: 0055 ; inline
: key-keypad-- HEX: 0056 ; inline
: key-keypad-+ HEX: 0057 ; inline
: key-keypad-enter HEX: 0058 ; inline
: key-keypad-1 HEX: 0059 ; inline
: key-keypad-2 HEX: 005a ; inline
: key-keypad-3 HEX: 005b ; inline
: key-keypad-4 HEX: 005c ; inline
: key-keypad-5 HEX: 005d ; inline
: key-keypad-6 HEX: 005e ; inline
: key-keypad-7 HEX: 005f ; inline
: key-keypad-8 HEX: 0060 ; inline
: key-keypad-9 HEX: 0061 ; inline
: key-keypad-0 HEX: 0062 ; inline
: key-keypad-. HEX: 0063 ; inline
: key-\-non-us HEX: 0064 ; inline
: key-application HEX: 0065 ; inline
: key-power HEX: 0066 ; inline
: key-keypad-= HEX: 0067 ; inline
: key-f13 HEX: 0068 ; inline
: key-f14 HEX: 0069 ; inline
: key-f15 HEX: 006a ; inline
: key-f16 HEX: 006b ; inline
: key-f17 HEX: 006c ; inline
: key-f18 HEX: 006d ; inline
: key-f19 HEX: 006e ; inline
: key-f20 HEX: 006f ; inline
: key-f21 HEX: 0070 ; inline
: key-f22 HEX: 0071 ; inline
: key-f23 HEX: 0072 ; inline
: key-f24 HEX: 0073 ; inline
: key-execute HEX: 0074 ; inline
: key-help HEX: 0075 ; inline
: key-menu HEX: 0076 ; inline
: key-select HEX: 0077 ; inline
: key-stop HEX: 0078 ; inline
: key-again HEX: 0079 ; inline
: key-undo HEX: 007a ; inline
: key-cut HEX: 007b ; inline
: key-copy HEX: 007c ; inline
: key-paste HEX: 007d ; inline
: key-find HEX: 007e ; inline
: key-mute HEX: 007f ; inline
: key-volume-up HEX: 0080 ; inline
: key-volume-down HEX: 0081 ; inline
: key-locking-caps-lock HEX: 0082 ; inline
: key-locking-num-lock HEX: 0083 ; inline
: key-locking-scroll-lock HEX: 0084 ; inline
: key-keypad-, HEX: 0085 ; inline
: key-keypad-=-as-400 HEX: 0086 ; inline
: key-international-1 HEX: 0087 ; inline
: key-international-2 HEX: 0088 ; inline
: key-international-3 HEX: 0089 ; inline
: key-international-4 HEX: 008a ; inline
: key-international-5 HEX: 008b ; inline
: key-international-6 HEX: 008c ; inline
: key-international-7 HEX: 008d ; inline
: key-international-8 HEX: 008e ; inline
: key-international-9 HEX: 008f ; inline
: key-lang-1 HEX: 0090 ; inline
: key-lang-2 HEX: 0091 ; inline
: key-lang-3 HEX: 0092 ; inline
: key-lang-4 HEX: 0093 ; inline
: key-lang-5 HEX: 0094 ; inline
: key-lang-6 HEX: 0095 ; inline
: key-lang-7 HEX: 0096 ; inline
: key-lang-8 HEX: 0097 ; inline
: key-lang-9 HEX: 0098 ; inline
: key-alternate-erase HEX: 0099 ; inline
: key-sysreq HEX: 009a ; inline
: key-cancel HEX: 009b ; inline
: key-clear HEX: 009c ; inline
: key-prior HEX: 009d ; inline
: key-enter HEX: 009e ; inline
: key-separator HEX: 009f ; inline
: key-out HEX: 00a0 ; inline
: key-oper HEX: 00a1 ; inline
: key-clear-again HEX: 00a2 ; inline
: key-crsel-props HEX: 00a3 ; inline
: key-exsel HEX: 00a4 ; inline
: key-left-control HEX: 00e0 ; inline
: key-left-shift HEX: 00e1 ; inline
: key-left-alt HEX: 00e2 ; inline
: key-left-gui HEX: 00e3 ; inline
: key-right-control HEX: 00e4 ; inline
: key-right-shift HEX: 00e5 ; inline
: key-right-alt HEX: 00e6 ; inline
: key-right-gui HEX: 00e7 ; inline

1
extra/game-input/scancodes/summary.txt Normal file
View File

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

2
extra/game-input/scancodes/tags.txt Normal file
View File

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

1
extra/game-input/summary.txt Normal file
View File

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

3
extra/game-input/tags.txt Normal file
View File

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

24
extra/golden-section/golden-section.factor
View File

@ -1,21 +1,14 @@
USING: kernel namespaces math math.constants math.functions arrays sequences USING: kernel namespaces math math.constants math.functions math.order
arrays sequences
opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
ui.gadgets.slate colors accessors combinators.cleave ; ui.gadgets.slate colors accessors combinators.cleave
processing.shapes ;
IN: golden-section IN: golden-section
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: disk ( radius center -- )
glPushMatrix
gl-translate
dup 0 glScalef
gluNewQuadric [ 0 1 20 20 gluDisk ] [ gluDeleteQuadric ] bi
glPopMatrix ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! omega(i) = 2*pi*i*(phi-1) ! omega(i) = 2*pi*i*(phi-1)
! x(i) = 0.5*i*cos(omega(i)) ! x(i) = 0.5*i*cos(omega(i))
@ -34,12 +27,13 @@ IN: golden-section
: radius ( i -- radius ) pi * 720 / sin 10 * ; : radius ( i -- radius ) pi * 720 / sin 10 * ;
: color ( i -- color ) 360.0 / dup 0.25 1 4array ; : color ( i -- i ) dup 360.0 / dup 0.25 1 4array >fill-color ;
: rim ( i -- ) [ drop black gl-color ] [ radius 1.5 * ] [ center ] tri disk ; : line-width ( i -- i ) dup radius 0.5 * 1 max glLineWidth ;
: inner ( i -- ) [ color gl-color ] [ radius ] [ center ] tri disk ;
: dot ( i -- ) [ rim ] [ inner ] bi ; : draw ( i -- ) [ center ] [ radius 1.5 * 2 * ] bi circle ;
: dot ( i -- ) color line-width draw ;
: golden-section ( -- ) 720 [ dot ] each ; : golden-section ( -- ) 720 [ dot ] each ;

1
extra/iokit/hid/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

1
extra/iokit/hid/hid.factor
View File

@ -269,3 +269,4 @@ FUNCTION: IOHIDValueRef IOHIDTransactionGetValue ( IOHIDTransactionRef transacti
FUNCTION: IOReturn IOHIDTransactionCommit ( IOHIDTransactionRef transaction ) ; FUNCTION: IOReturn IOHIDTransactionCommit ( IOHIDTransactionRef transaction ) ;
FUNCTION: IOReturn IOHIDTransactionCommitWithCallback ( IOHIDTransactionRef transaction, CFTimeInterval timeout, IOHIDCallback callback, void* context ) ; FUNCTION: IOReturn IOHIDTransactionCommitWithCallback ( IOHIDTransactionRef transaction, CFTimeInterval timeout, IOHIDCallback callback, void* context ) ;
FUNCTION: void IOHIDTransactionClear ( IOHIDTransactionRef transaction ) ; FUNCTION: void IOHIDTransactionClear ( IOHIDTransactionRef transaction ) ;

1
extra/iokit/hid/summary.txt Normal file
View File

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

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

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

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

1
extra/joystick-demo/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

145
extra/joystick-demo/joystick-demo.factor Executable file
View File

@ -0,0 +1,145 @@
USING: ui ui.gadgets sequences kernel arrays math colors
ui.render math.vectors accessors fry ui.gadgets.packs game-input
game-input.backend ui.gadgets.labels ui.gadgets.borders alarms
calendar locals combinators.lib strings ui.gadgets.buttons
combinators math.parser assocs threads ;
IN: joystick-demo
: SIZE { 151 151 } ;
: INDICATOR-SIZE { 4 4 } ;
: FREQUENCY ( -- f ) 30 recip seconds ;
TUPLE: axis-gadget < gadget indicator z-indicator pov ;
M: axis-gadget pref-dim* drop SIZE ;
: (rect-polygon) ( lo hi -- polygon )
2dup
[ [ second ] [ first ] bi* swap 2array ]
[ [ first ] [ second ] bi* 2array ] 2bi swapd 4array ;
: indicator-polygon ( -- polygon )
{ 0 0 } INDICATOR-SIZE (rect-polygon) ;
: pov-polygons
V{
{ pov-neutral { { 70 75 } { 75 70 } { 80 75 } { 75 80 } } }
{ pov-up { { 70 65 } { 75 60 } { 80 65 } } }
{ pov-up-right { { 83 60 } { 90 60 } { 90 67 } } }
{ pov-right { { 85 70 } { 90 75 } { 85 80 } } }
{ pov-down-right { { 90 83 } { 90 90 } { 83 90 } } }
{ pov-down { { 70 85 } { 75 90 } { 80 85 } } }
{ pov-down-left { { 67 90 } { 60 90 } { 60 83 } } }
{ pov-left { { 65 70 } { 60 75 } { 65 80 } } }
{ pov-up-left { { 67 60 } { 60 60 } { 60 67 } } }
} ;
: <indicator-gadget> ( color -- indicator )
indicator-polygon <polygon-gadget> ;
: (>loc) ( axisloc -- windowloc )
0.5 v*n { 0.5 0.5 } v+ SIZE v* [ >integer ] map
INDICATOR-SIZE 2 v/n v- ;
: (xy>loc) ( x y -- xyloc )
2array (>loc) ;
: (z>loc) ( z -- zloc )
0.0 swap 2array (>loc) ;
: (xyz>loc) ( x y z -- xyloc zloc )
[ [ 0.0 ] unless* ] tri@
[ (xy>loc) ] dip (z>loc) ;
: move-axis ( gadget x y z -- )
(xyz>loc) rot
[ indicator>> (>>loc) ]
[ z-indicator>> (>>loc) ] bi, bi* ;
: move-pov ( gadget pov -- )
swap pov>> [ interior>> -rot = [ gray ] [ white ] if >>color drop ]
with assoc-each ;
:: add-pov-gadget ( gadget direction polygon -- gadget direction gadget )
gadget white polygon <polygon-gadget> [ add-gadget ] keep
direction swap ;
: add-pov-gadgets ( gadget -- gadget )
pov-polygons [ add-pov-gadget ] assoc-map >>pov ;
: <axis-gadget> ( -- gadget )
axis-gadget new-gadget
add-pov-gadgets
black <indicator-gadget> [ >>z-indicator ] [ add-gadget ] bi
red <indicator-gadget> [ >>indicator ] [ add-gadget ] bi
dup [ 0.0 0.0 0.0 move-axis ] [ f move-pov ] bi ;
TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
: add-gadget-with-border ( parent child -- parent )
2 <border> gray <solid> >>boundary add-gadget ;
: add-controller-label ( gadget controller -- gadget )
[ >>controller ] [ product-string <label> add-gadget ] bi ;
: add-axis-gadget ( gadget shelf -- gadget shelf )
<axis-gadget> [ >>axis ] [ add-gadget-with-border ] bi, bi* ;
: add-raxis-gadget ( gadget shelf -- gadget shelf )
<axis-gadget> [ >>raxis ] [ add-gadget-with-border ] bi, bi* ;
:: (add-button-gadgets) ( gadget shelf -- )
gadget controller>> read-controller buttons>> length [
number>string [ ] <bevel-button>
shelf over add-gadget drop
] map gadget (>>buttons) ;
: add-button-gadgets ( gadget shelf -- gadget shelf )
[ (add-button-gadgets) ] 2keep ;
: <joystick-demo-gadget> ( controller -- gadget )
joystick-demo-gadget new-gadget
{ 0 1 } >>orientation
swap add-controller-label
<shelf> add-axis-gadget add-raxis-gadget add-gadget
<shelf> add-button-gadgets add-gadget ;
: update-buttons ( buttons button-states -- )
[ >>selected? drop ] 2each ;
: kill-update-axes ( gadget -- )
gray <solid> >>interior
[ [ cancel-alarm ] when* f ] change-alarm
relayout-1 ;
: (update-axes) ( gadget controller-state -- )
{
[ [ axis>> ] [ [ x>> ] [ y>> ] [ z>> ] tri ] bi* move-axis ]
[ [ raxis>> ] [ [ rx>> ] [ ry>> ] [ rz>> ] tri ] bi* move-axis ]
[ [ axis>> ] [ pov>> ] bi* move-pov ]
[ [ buttons>> ] [ buttons>> ] bi* update-buttons ]
[ drop relayout-1 ]
} 2cleave ;
: update-axes ( gadget -- )
dup controller>> read-controller
[ (update-axes) ] [ kill-update-axes ] if* ;
M: joystick-demo-gadget graft*
dup '[ , update-axes ] FREQUENCY every >>alarm
drop ;
M: joystick-demo-gadget ungraft*
alarm>> [ cancel-alarm ] when* ;
: joystick-window ( controller -- )
[ <joystick-demo-gadget> ] [ product-string ] bi
open-window ;
: joystick-demo ( -- )
[
open-game-input
0.1 seconds sleep ! It might take a moment to find devices...
get-controllers [ joystick-window ] each
] with-ui ;
MAIN: joystick-demo

1
extra/joystick-demo/summary.txt Normal file
View File

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

2
extra/joystick-demo/tags.txt Normal file
View File

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

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

@ -0,0 +1 @@
Joe Groff

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

@ -0,0 +1,180 @@
USING: game-input game-input.backend game-input.scancodes
kernel ui.gadgets ui.gadgets.buttons sequences accessors
words arrays assocs math calendar fry alarms ui
ui.gadgets.borders ui.gestures ;
IN: key-caps
: key-locations H{
{ key-escape { { 0 0 } { 10 10 } } }
{ key-f1 { { 20 0 } { 10 10 } } }
{ key-f2 { { 30 0 } { 10 10 } } }
{ key-f3 { { 40 0 } { 10 10 } } }
{ key-f4 { { 50 0 } { 10 10 } } }
{ key-f5 { { 65 0 } { 10 10 } } }
{ key-f6 { { 75 0 } { 10 10 } } }
{ key-f7 { { 85 0 } { 10 10 } } }
{ key-f8 { { 95 0 } { 10 10 } } }
{ key-f9 { { 110 0 } { 10 10 } } }
{ key-f10 { { 120 0 } { 10 10 } } }
{ key-f11 { { 130 0 } { 10 10 } } }
{ key-f12 { { 140 0 } { 10 10 } } }
{ key-` { { 0 15 } { 10 10 } } }
{ key-1 { { 10 15 } { 10 10 } } }
{ key-2 { { 20 15 } { 10 10 } } }
{ key-3 { { 30 15 } { 10 10 } } }
{ key-4 { { 40 15 } { 10 10 } } }
{ key-5 { { 50 15 } { 10 10 } } }
{ key-6 { { 60 15 } { 10 10 } } }
{ key-7 { { 70 15 } { 10 10 } } }
{ key-8 { { 80 15 } { 10 10 } } }
{ key-9 { { 90 15 } { 10 10 } } }
{ key-0 { { 100 15 } { 10 10 } } }
{ key-- { { 110 15 } { 10 10 } } }
{ key-= { { 120 15 } { 10 10 } } }
{ key-backspace { { 130 15 } { 20 10 } } }
{ key-tab { { 0 25 } { 15 10 } } }
{ key-q { { 15 25 } { 10 10 } } }
{ key-w { { 25 25 } { 10 10 } } }
{ key-e { { 35 25 } { 10 10 } } }
{ key-r { { 45 25 } { 10 10 } } }
{ key-t { { 55 25 } { 10 10 } } }
{ key-y { { 65 25 } { 10 10 } } }
{ key-u { { 75 25 } { 10 10 } } }
{ key-i { { 85 25 } { 10 10 } } }
{ key-o { { 95 25 } { 10 10 } } }
{ key-p { { 105 25 } { 10 10 } } }
{ key-[ { { 115 25 } { 10 10 } } }
{ key-] { { 125 25 } { 10 10 } } }
{ key-\ { { 135 25 } { 15 10 } } }
{ key-caps-lock { { 0 35 } { 20 10 } } }
{ key-a { { 20 35 } { 10 10 } } }
{ key-s { { 30 35 } { 10 10 } } }
{ key-d { { 40 35 } { 10 10 } } }
{ key-f { { 50 35 } { 10 10 } } }
{ key-g { { 60 35 } { 10 10 } } }
{ key-h { { 70 35 } { 10 10 } } }
{ key-j { { 80 35 } { 10 10 } } }
{ key-k { { 90 35 } { 10 10 } } }
{ key-l { { 100 35 } { 10 10 } } }
{ key-; { { 110 35 } { 10 10 } } }
{ key-' { { 120 35 } { 10 10 } } }
{ key-return { { 130 35 } { 20 10 } } }
{ key-left-shift { { 0 45 } { 25 10 } } }
{ key-z { { 25 45 } { 10 10 } } }
{ key-x { { 35 45 } { 10 10 } } }
{ key-c { { 45 45 } { 10 10 } } }
{ key-v { { 55 45 } { 10 10 } } }
{ key-b { { 65 45 } { 10 10 } } }
{ key-n { { 75 45 } { 10 10 } } }
{ key-m { { 85 45 } { 10 10 } } }
{ key-, { { 95 45 } { 10 10 } } }
{ key-. { { 105 45 } { 10 10 } } }
{ key-/ { { 115 45 } { 10 10 } } }
{ key-right-shift { { 125 45 } { 25 10 } } }
{ key-left-control { { 0 55 } { 15 10 } } }
{ key-left-gui { { 15 55 } { 15 10 } } }
{ key-left-alt { { 30 55 } { 15 10 } } }
{ key-space { { 45 55 } { 45 10 } } }
{ key-right-alt { { 90 55 } { 15 10 } } }
{ key-right-gui { { 105 55 } { 15 10 } } }
{ key-application { { 120 55 } { 15 10 } } }
{ key-right-control { { 135 55 } { 15 10 } } }
{ key-print-screen { { 155 0 } { 10 10 } } }
{ key-scroll-lock { { 165 0 } { 10 10 } } }
{ key-pause { { 175 0 } { 10 10 } } }
{ key-insert { { 155 15 } { 10 10 } } }
{ key-home { { 165 15 } { 10 10 } } }
{ key-page-up { { 175 15 } { 10 10 } } }
{ key-delete { { 155 25 } { 10 10 } } }
{ key-end { { 165 25 } { 10 10 } } }
{ key-page-down { { 175 25 } { 10 10 } } }
{ key-up-arrow { { 165 45 } { 10 10 } } }
{ key-left-arrow { { 155 55 } { 10 10 } } }
{ key-down-arrow { { 165 55 } { 10 10 } } }
{ key-right-arrow { { 175 55 } { 10 10 } } }
{ key-keypad-numlock { { 190 15 } { 10 10 } } }
{ key-keypad-/ { { 200 15 } { 10 10 } } }
{ key-keypad-* { { 210 15 } { 10 10 } } }
{ key-keypad-- { { 220 15 } { 10 10 } } }
{ key-keypad-7 { { 190 25 } { 10 10 } } }
{ key-keypad-8 { { 200 25 } { 10 10 } } }
{ key-keypad-9 { { 210 25 } { 10 10 } } }
{ key-keypad-+ { { 220 25 } { 10 20 } } }
{ key-keypad-4 { { 190 35 } { 10 10 } } }
{ key-keypad-5 { { 200 35 } { 10 10 } } }
{ key-keypad-6 { { 210 35 } { 10 10 } } }
{ key-keypad-1 { { 190 45 } { 10 10 } } }
{ key-keypad-2 { { 200 45 } { 10 10 } } }
{ key-keypad-3 { { 210 45 } { 10 10 } } }
{ key-keypad-enter { { 220 45 } { 10 20 } } }
{ key-keypad-0 { { 190 55 } { 20 10 } } }
{ key-keypad-. { { 210 55 } { 10 10 } } }
} ;
: KEYBOARD-SIZE { 230 65 } ;
: FREQUENCY ( -- f ) 30 recip seconds ;
TUPLE: key-caps-gadget < gadget keys alarm ;
: make-key-gadget ( scancode dim array -- )
[
swap [
" " [ ] <bevel-button>
swap [ first >>loc ] [ second >>dim ] bi
] [ execute ] bi*
] dip set-nth ;
: add-keys-gadgets ( gadget -- gadget )
key-locations 256 f <array>
[ [ make-key-gadget ] curry assoc-each ]
[ [ [ add-gadget ] when* ] each ]
[ >>keys ] tri ;
: <key-caps-gadget> ( -- gadget )
key-caps-gadget new-gadget
add-keys-gadgets ;
M: key-caps-gadget pref-dim* drop KEYBOARD-SIZE ;
: update-key-caps-state ( gadget -- )
read-keyboard keys>> over keys>>
[ [ (>>selected?) ] [ drop ] if* ] 2each
relayout-1 ;
M: key-caps-gadget graft*
dup '[ , update-key-caps-state ] FREQUENCY every >>alarm
drop ;
M: key-caps-gadget ungraft*
alarm>> [ cancel-alarm ] when* ;
M: key-caps-gadget handle-gesture*
drop nip [ key-down? ] [ key-up? ] bi or not ;
: key-caps ( -- )
[
open-game-input
<key-caps-gadget> 5 <border> "Key Caps" open-window
] with-ui ;
MAIN: key-caps

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

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

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

@ -0,0 +1 @@
keyboard

11
extra/math/blas/matrices/matrices-docs.factor
View File

@ -34,7 +34,16 @@ ARTICLE: "math.blas-types" "BLAS interface types"
{ $subsection <double-complex-blas-matrix> } { $subsection <double-complex-blas-matrix> }
"For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:" "For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:"
{ $subsection <empty-vector> } { $subsection <empty-vector> }
{ $subsection <empty-matrix> } ; { $subsection <empty-matrix> }
"BLAS vectors and matrices can also be constructed from other Factor sequences:"
{ $subsection >float-blas-vector }
{ $subsection >double-blas-vector }
{ $subsection >float-complex-blas-vector }
{ $subsection >double-complex-blas-vector }
{ $subsection >float-blas-matrix }
{ $subsection >double-blas-matrix }
{ $subsection >float-complex-blas-matrix }
{ $subsection >double-complex-blas-matrix } ;
ARTICLE: "math.blas.matrices" "BLAS interface matrix operations" ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
"Transposing and slicing matrices:" "Transposing and slicing matrices:"

11
extra/math/geometry/rect/rect.factor
View File

@ -1,5 +1,7 @@
USING: kernel arrays sequences math.vectors math.geometry accessors ; USING: kernel arrays sequences
math math.points math.vectors math.geometry
accessors ;
IN: math.geometry.rect IN: math.geometry.rect
@ -50,3 +52,10 @@ M: rect set-height! ( rect height -- rect ) over dim>> set-second ;
M: rect set-x! ( rect x -- rect ) over loc>> set-first ; M: rect set-x! ( rect x -- rect ) over loc>> set-first ;
M: rect set-y! ( rect y -- rect ) over loc>> set-second ; M: rect set-y! ( rect y -- rect ) over loc>> set-second ;
! Accessing corners
: top-left ( rect -- point ) loc>> ;
: top-right ( rect -- point ) [ loc>> ] [ width 1 - ] bi v+x ;
: bottom-left ( rect -- point ) [ loc>> ] [ height 1 - ] bi v+y ;
: bottom-right ( rect -- point ) [ loc>> ] [ dim>> ] bi v+ { 1 1 } v- ;

20
extra/opengl/opengl.factor
View File

@ -2,10 +2,12 @@
! Portions copyright (C) 2007 Eduardo Cavazos. ! Portions copyright (C) 2007 Eduardo Cavazos.
! Portions copyright (C) 2008 Joe Groff. ! Portions copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types continuations kernel libc math macros USING: alien alien.c-types continuations kernel libc math macros
namespaces math.vectors math.constants math.functions namespaces math.vectors math.constants math.functions
math.parser opengl.gl opengl.glu combinators arrays sequences math.parser opengl.gl opengl.glu combinators arrays sequences
splitting words byte-arrays assocs ; splitting words byte-arrays assocs colors accessors ;
IN: opengl IN: opengl
: coordinates ( point1 point2 -- x1 y2 x2 y2 ) : coordinates ( point1 point2 -- x1 y2 x2 y2 )
@ -14,6 +16,8 @@ IN: opengl
: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 ) : fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
[ first2 [ >fixnum ] bi@ ] bi@ ; [ first2 [ >fixnum ] bi@ ] bi@ ;
: gl-color ( color -- ) first4 glColor4d ; inline : gl-color ( color -- ) first4 glColor4d ; inline
: gl-clear-color ( color -- ) : gl-clear-color ( color -- )
@ -22,6 +26,16 @@ IN: opengl
: gl-clear ( color -- ) : gl-clear ( color -- )
gl-clear-color GL_COLOR_BUFFER_BIT glClear ; gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
: color>raw ( object -- 4array )
>rgba
{ [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave
4array ;
: set-color ( object -- ) color>raw first4 glColor4d ;
: set-clear-color ( object -- ) color>raw first4 glClearColor ;
: gl-error ( -- ) : gl-error ( -- )
glGetError dup zero? [ glGetError dup zero? [
"GL error: " over gluErrorString append throw "GL error: " over gluErrorString append throw
@ -195,6 +209,8 @@ TUPLE: sprite loc dim dim2 dlist texture ;
: gl-translate ( point -- ) first2 0.0 glTranslated ; : gl-translate ( point -- ) first2 0.0 glTranslated ;
<PRIVATE
: top-left drop 0 0 glTexCoord2i 0.0 0.0 glVertex2d ; inline : top-left drop 0 0 glTexCoord2i 0.0 0.0 glVertex2d ; inline
: top-right 1 0 glTexCoord2i first 0.0 glVertex2d ; inline : top-right 1 0 glTexCoord2i first 0.0 glVertex2d ; inline
@ -203,6 +219,8 @@ TUPLE: sprite loc dim dim2 dlist texture ;
: bottom-right 1 1 glTexCoord2i gl-vertex ; inline : bottom-right 1 1 glTexCoord2i gl-vertex ; inline
PRIVATE>
: four-sides ( dim -- ) : four-sides ( dim -- )
dup top-left dup top-right dup bottom-right bottom-left ; dup top-left dup top-right dup bottom-right bottom-left ;

2
extra/processing/gallery/trails/trails.factor
View File

@ -1,6 +1,6 @@
USING: kernel arrays sequences math math.order qualified USING: kernel arrays sequences math math.order qualified
sequences.lib circular processing ui newfx ; sequences.lib circular processing ui newfx processing.shapes ;
IN: processing.gallery.trails IN: processing.gallery.trails

269
extra/processing/processing.factor
View File

@ -10,7 +10,8 @@ USING: kernel namespaces threads combinators sequences arrays
combinators.cleave combinators.cleave
rewrite-closures fry accessors newfx rewrite-closures fry accessors newfx
processing.color processing.color
processing.gadget math.geometry.rect ; processing.gadget math.geometry.rect
processing.shapes ;
IN: processing IN: processing
@ -36,53 +37,29 @@ IN: processing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: fill-color GENERIC: canonical-color-value ( obj -- color )
VAR: stroke-color
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! METHOD: canonical-color-value { number } dup dup 1 4array ;
GENERIC: set-color ( value -- ) METHOD: canonical-color-value { array }
METHOD: set-color { number } dup dup glColor3d ;
METHOD: set-color { array }
dup length dup length
{ {
{ 2 [ first2 >r dup dup r> glColor4d ] } { 2 [ first2 >r dup dup r> 4array ] }
{ 3 [ first3 glColor3d ] } { 3 [ 1 suffix ] }
{ 4 [ first4 glColor4d ] } { 4 [ ] }
} }
case ; case ;
METHOD: set-color { rgba } METHOD: canonical-color-value { rgba }
{ [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ; { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave 4array ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: fill ( value -- ) >fill-color ; : fill ( value -- ) canonical-color-value >fill-color ;
: stroke ( value -- ) >stroke-color ; : stroke ( value -- ) canonical-color-value >stroke-color ;
: no-fill ( -- ) : no-fill ( -- ) 0 fill-color> set-fourth ;
fill-color> : no-stroke ( -- ) 0 stroke-color> set-fourth ;
{
{ [ dup number? ] [ 0 2array fill ] }
{ [ t ]
[
[ drop 0 ] [ length 1- ] [ ] tri set-nth
] }
}
cond ;
: no-stroke ( -- )
stroke-color>
{
{ [ dup number? ] [ 0 2array stroke ] }
{ [ t ]
[
[ drop 0 ] [ length 1- ] [ ] tri set-nth
] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -90,167 +67,93 @@ METHOD: set-color { rgba }
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: point* ( x y -- ) ! : quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
stroke-color> set-color ! GL_POLYGON glBegin
GL_POINTS glBegin ! glVertex2d
glVertex2d ! glVertex2d
glEnd ; ! glVertex2d
! glVertex2d
! glEnd ;
: point ( seq -- ) first2 point* ; ! : quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
: line ( x1 y1 x2 y2 -- ) ! 8 ndup
stroke-color> set-color
GL_LINES glBegin ! GL_FRONT_AND_BACK GL_FILL glPolygonMode
glVertex2d ! fill-color> set-color
glVertex2d
glEnd ; ! quad-vertices
! GL_FRONT_AND_BACK GL_LINE glPolygonMode
! stroke-color> set-color
! quad-vertices ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: triangle ( x1 y1 x2 y2 x3 y3 -- ) ! : ellipse-disk ( x y width height -- )
! glPushMatrix
! >r >r
! 0 glTranslated
! r> r> 1 glScaled
! gluNewQuadric
! dup 0 0.5 20 1 gluDisk
! gluDeleteQuadric
! glPopMatrix ;
GL_FRONT_AND_BACK GL_FILL glPolygonMode ! : ellipse-center ( x y width height -- )
fill-color> set-color
6 ndup ! 4dup
GL_TRIANGLES glBegin ! GL_FRONT_AND_BACK GL_FILL glPolygonMode
glVertex2d ! stroke-color> set-color
glVertex2d
glVertex2d
glEnd
GL_FRONT_AND_BACK GL_LINE glPolygonMode ! ellipse-disk
stroke-color> set-color
GL_TRIANGLES glBegin ! GL_FRONT_AND_BACK GL_FILL glPolygonMode
glVertex2d ! fill-color> set-color
glVertex2d
glVertex2d ! [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
glEnd ;
! ellipse-disk ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- ) ! SYMBOL: CENTER
GL_POLYGON glBegin ! SYMBOL: RADIUS
glVertex2d ! SYMBOL: CORNER
glVertex2d ! SYMBOL: CORNERS
glVertex2d
glVertex2d
glEnd ;
: quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- ) ! SYMBOL: ellipse-mode-value
8 ndup ! : ellipse-mode ( val -- ) ellipse-mode-value set ;
GL_FRONT_AND_BACK GL_FILL glPolygonMode ! : ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ;
fill-color> set-color
quad-vertices ! : ellipse-corner ( x y width height -- )
! [ drop nip 2 / + ] 4keep
! [ nip rot drop 2 / + ] 4keep
! [ >r >r 2drop r> r> ] 4keep
! 4drop
! ellipse-center ;
GL_FRONT_AND_BACK GL_LINE glPolygonMode ! : ellipse-corners ( x1 y1 x2 y2 -- )
stroke-color> set-color ! [ drop nip + 2 / ] 4keep
! [ nip rot drop + 2 / ] 4keep
! [ drop nip - abs 1+ ] 4keep
! [ nip rot drop - abs 1+ ] 4keep
! 4drop
! ellipse-center ;
quad-vertices ; ! : ellipse ( a b c d -- )
! ellipse-mode-value get
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! {
! { CENTER [ ellipse-center ] }
: rect-vertices ( x y width height -- ) ! { RADIUS [ ellipse-radius ] }
GL_POLYGON glBegin ! { CORNER [ ellipse-corner ] }
[ 2drop glVertex2d ] 4keep ! { CORNERS [ ellipse-corners ] }
[ drop swap >r + 1- r> glVertex2d ] 4keep ! }
[ >r swap >r + 1- r> r> + 1- glVertex2d ] 4keep ! case ;
[ nip + 1- glVertex2d ] 4keep
4drop
glEnd ;
: rect ( x y width height -- )
4dup
GL_FRONT_AND_BACK GL_FILL glPolygonMode
fill-color> set-color
rect-vertices
GL_FRONT_AND_BACK GL_LINE glPolygonMode
stroke-color> set-color
rect-vertices ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ellipse-disk ( x y width height -- )
glPushMatrix
>r >r
0 glTranslated
r> r> 1 glScaled
gluNewQuadric
dup 0 0.5 20 1 gluDisk
gluDeleteQuadric
glPopMatrix ;
: ellipse-center ( x y width height -- )
4dup
GL_FRONT_AND_BACK GL_FILL glPolygonMode
stroke-color> set-color
ellipse-disk
GL_FRONT_AND_BACK GL_FILL glPolygonMode
fill-color> set-color
[ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
ellipse-disk ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: CENTER
SYMBOL: RADIUS
SYMBOL: CORNER
SYMBOL: CORNERS
SYMBOL: ellipse-mode-value
: ellipse-mode ( val -- ) ellipse-mode-value set ;
: ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ;
: ellipse-corner ( x y width height -- )
[ drop nip 2 / + ] 4keep
[ nip rot drop 2 / + ] 4keep
[ >r >r 2drop r> r> ] 4keep
4drop
ellipse-center ;
: ellipse-corners ( x1 y1 x2 y2 -- )
[ drop nip + 2 / ] 4keep
[ nip rot drop + 2 / ] 4keep
[ drop nip - abs 1+ ] 4keep
[ nip rot drop - abs 1+ ] 4keep
4drop
ellipse-center ;
: ellipse ( a b c d -- )
ellipse-mode-value get
{
{ CENTER [ ellipse-center ] }
{ RADIUS [ ellipse-radius ] }
{ CORNER [ ellipse-corner ] }
{ CORNERS [ ellipse-corners ] }
}
case ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: circle ( pos size -- ) [ first2 ] [ dup ] bi* ellipse ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: multi-methods ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -279,8 +182,8 @@ METHOD: background { array }
: mouse ( -- point ) hand-loc get ; : mouse ( -- point ) hand-loc get ;
: mouse-x mouse first ; : mouse-x ( -- x ) mouse first ;
: mouse-y mouse second ; : mouse-y ( -- y ) mouse second ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -296,9 +199,7 @@ VAR: loop-flag
: defaults ( -- ) : defaults ( -- )
0.8 background 0.8 background
0 >stroke-color ! CENTER ellipse-mode
1 >fill-color
CENTER ellipse-mode
60 frame-rate ; 60 frame-rate ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

112
extra/processing/shapes/shapes.factor Normal file
View File

@ -0,0 +1,112 @@
USING: kernel namespaces arrays sequences grouping
alien.c-types
math math.vectors math.geometry.rect
opengl.gl opengl.glu opengl generalizations vars
combinators.cleave ;
IN: processing.shapes
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: fill-color
VAR: stroke-color
{ 0 0 0 1 } stroke-color set-global
{ 1 1 1 1 } fill-color set-global
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: fill-mode ( -- )
GL_FRONT_AND_BACK GL_FILL glPolygonMode
fill-color> gl-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: stroke-mode ( -- )
GL_FRONT_AND_BACK GL_LINE glPolygonMode
stroke-color> gl-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gl-vertex-2d ( vertex -- ) first2 glVertex2d ;
: gl-vertices-2d ( vertices -- ) [ gl-vertex-2d ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: point* ( x y -- ) stroke-mode GL_POINTS [ glVertex2d ] do-state ;
: point ( point -- ) stroke-mode GL_POINTS [ gl-vertex-2d ] do-state ;
: points ( points -- ) stroke-mode GL_POINTS [ gl-vertices-2d ] do-state ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: line** ( x y x y -- )
stroke-mode GL_LINES [ glVertex2d glVertex2d ] do-state ;
: line* ( a b -- ) stroke-mode GL_LINES [ [ gl-vertex-2d ] bi@ ] do-state ;
: lines ( seq -- ) stroke-mode GL_LINES [ gl-vertices-2d ] do-state ;
: line ( seq -- ) lines ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: triangles ( seq -- )
[ fill-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ]
[ stroke-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] bi ;
: triangle ( seq -- ) triangles ;
: triangle* ( a b c -- ) 3array triangles ;
: triangle** ( x y x y x y -- ) 6 narray 2 group triangles ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: polygon ( seq -- )
[ fill-mode GL_POLYGON [ gl-vertices-2d ] do-state ]
[ stroke-mode GL_POLYGON [ gl-vertices-2d ] do-state ] bi ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rectangle ( loc dim -- )
<rect>
{ top-left top-right bottom-right bottom-left }
1arr
polygon ;
: rectangle* ( x y width height -- ) [ 2array ] 2bi@ rectangle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gl-translate-2d ( pos -- ) first2 0 glTranslated ;
: gl-scale-2d ( xy -- ) first2 1 glScaled ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gl-ellipse ( center dim -- )
glPushMatrix
[ gl-translate-2d ] [ gl-scale-2d ] bi*
gluNewQuadric
dup 0 0.5 20 1 gluDisk
gluDeleteQuadric
glPopMatrix ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gl-get-line-width ( -- width )
GL_LINE_WIDTH 0 <double> tuck glGetDoublev *double ;
: ellipse ( center dim -- )
GL_FRONT_AND_BACK GL_FILL glPolygonMode
[ stroke-color> gl-color gl-ellipse ]
[ fill-color> gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: circle ( center size -- ) dup 2array ellipse ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

10
extra/sequences/deep/deep.factor
View File

@ -5,10 +5,12 @@ IN: sequences.deep
! All traversal goes in postorder ! All traversal goes in postorder
: branch? ( object -- ? ) GENERIC: branch? ( object -- ? )
dup sequence? [
dup string? swap number? or not M: sequence branch? drop t ;
] [ drop f ] if ; M: integer branch? drop f ;
M: string branch? drop f ;
M: object branch? drop f ;
: deep-each ( obj quot: ( elt -- ) -- ) : deep-each ( obj quot: ( elt -- ) -- )
[ call ] 2keep over branch? [ call ] 2keep over branch?

951
extra/windows/dinput/constants/constants.factor
View File

File diff suppressed because it is too large Load Diff

348
extra/windows/dinput/dinput.factor
View File

@ -31,10 +31,12 @@ TYPEDEF: void* LPDIENUMCREATEDEFFECTOBJECTSCALLBACK
[ "BOOL" { "LPDIRECTINPUTEFFECT" "LPVOID" } "stdcall" ] [ "BOOL" { "LPDIRECTINPUTEFFECT" "LPVOID" } "stdcall" ]
dip alien-callback ; inline dip alien-callback ; inline
TYPEDEF: void* LPDIENUMEFFECTSINFILECALLBACK TYPEDEF: void* LPDIENUMEFFECTSINFILECALLBACK
: LPDIENUMEFFECTSINFILECALLBACK
[ "BOOL" { "LPCDIFILEEFFECT" "LPVOID" } "stdcall" ] [ "BOOL" { "LPCDIFILEEFFECT" "LPVOID" } "stdcall" ]
dip alien-callback ; inline dip alien-callback ; inline
TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW
[ "BOOL" { "LPCDIDEVICEOBJECTINSTANCE" "LPVOID" } "stdcall" ] : LPDIENUMDEVICEOBJECTSCALLBACKW
[ "BOOL" { "LPCDIDEVICEOBJECTINSTANCEW" "LPVOID" } "stdcall" ]
dip alien-callback ; inline dip alien-callback ; inline
TYPEDEF: DWORD D3DCOLOR TYPEDEF: DWORD D3DCOLOR
@ -105,29 +107,35 @@ TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
C-STRUCT: DIDEVCAPS C-STRUCT: DIDEVCAPS
{ "DWORD" "wSize" } { "DWORD" "dwSize" }
{ "DWORD" "wFlags" } { "DWORD" "dwFlags" }
{ "DWORD" "wDevType" } { "DWORD" "dwDevType" }
{ "DWORD" "wAxes" } { "DWORD" "dwAxes" }
{ "DWORD" "wButtons" } { "DWORD" "dwButtons" }
{ "DWORD" "wPOVs" } { "DWORD" "dwPOVs" }
{ "DWORD" "wFFSamplePeriod" } { "DWORD" "dwFFSamplePeriod" }
{ "DWORD" "wFFMinTimeResolution" } { "DWORD" "dwFFMinTimeResolution" }
{ "DWORD" "wFirmwareRevision" } { "DWORD" "dwFirmwareRevision" }
{ "DWORD" "wHardwareRevision" } { "DWORD" "dwHardwareRevision" }
{ "DWORD" "wFFDriverVersion" } ; { "DWORD" "dwFFDriverVersion" } ;
TYPEDEF: DIDEVCAPS* LPDIDEVCAPS TYPEDEF: DIDEVCAPS* LPDIDEVCAPS
TYPEDEF: DIDEVCAPS* LPCDIDEVCAPS TYPEDEF: DIDEVCAPS* LPCDIDEVCAPS
C-STRUCT: DIDEVICEOBJECTINSTANCEW C-STRUCT: DIDEVICEOBJECTINSTANCEW
{ "DWORD" "dwSize" } { "DWORD" "dwSize" }
{ "GUID" "guidInstance" } { "GUID" "guidType" }
{ "GUID" "guidProduct" } { "DWORD" "dwOfs" }
{ "DWORD" "dwDevType" } { "DWORD" "dwType" }
{ "WCHAR[260]" "tszInstanceName" } { "DWORD" "dwFlags" }
{ "WCHAR[260]" "tszProductName" } { "WCHAR[260]" "tszName" }
{ "GUID" "guidFFDriver" } { "DWORD" "dwFFMaxForce" }
{ "DWORD" "dwFFForceResolution" }
{ "WORD" "wCollectionNumber" }
{ "WORD" "wDesignatorIndex" }
{ "WORD" "wUsagePage" } { "WORD" "wUsagePage" }
{ "WORD" "wUsage" } ; { "WORD" "wUsage" }
{ "DWORD" "dwDimension" }
{ "WORD" "wExponent" }
{ "WORD" "wReportId" } ;
TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPDIDEVICEOBJECTINSTANCEW TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPDIDEVICEOBJECTINSTANCEW
TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPCDIDEVICEOBJECTINSTANCEW TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPCDIDEVICEOBJECTINSTANCEW
C-STRUCT: DIDEVICEOBJECTDATA C-STRUCT: DIDEVICEOBJECTDATA
@ -161,6 +169,49 @@ C-STRUCT: DIPROPHEADER
{ "DWORD" "dwHow" } ; { "DWORD" "dwHow" } ;
TYPEDEF: DIPROPHEADER* LPDIPROPHEADER TYPEDEF: DIPROPHEADER* LPDIPROPHEADER
TYPEDEF: DIPROPHEADER* LPCDIPROPHEADER TYPEDEF: DIPROPHEADER* LPCDIPROPHEADER
C-STRUCT: DIPROPDWORD
{ "DIPROPHEADER" "diph" }
{ "DWORD" "dwData" } ;
TYPEDEF: DIPROPDWORD* LPDIPROPDWORD
TYPEDEF: DIPROPDWORD* LPCDIPROPDWORD
C-STRUCT: DIPROPPOINTER
{ "DIPROPHEADER" "diph" }
{ "UINT_PTR" "uData" } ;
TYPEDEF: DIPROPPOINTER* LPDIPROPPOINTER
TYPEDEF: DIPROPPOINTER* LPCDIPROPPOINTER
C-STRUCT: DIPROPRANGE
{ "DIPROPHEADER" "diph" }
{ "LONG" "lMin" }
{ "LONG" "lMax" } ;
TYPEDEF: DIPROPRANGE* LPDIPROPRANGE
TYPEDEF: DIPROPRANGE* LPCDIPROPRANGE
C-STRUCT: DIPROPCAL
{ "DIPROPHEADER" "diph" }
{ "LONG" "lMin" }
{ "LONG" "lCenter" }
{ "LONG" "lMax" } ;
TYPEDEF: DIPROPCAL* LPDIPROPCAL
TYPEDEF: DIPROPCAL* LPCDIPROPCAL
C-STRUCT: DIPROPGUIDANDPATH
{ "DIPROPHEADER" "diph" }
{ "GUID" "guidClass" }
{ "WCHAR[260]" "wszPath" } ;
TYPEDEF: DIPROPGUIDANDPATH* LPDIPROPGUIDANDPATH
TYPEDEF: DIPROPGUIDANDPATH* LPCDIPROPGUIDANDPATH
C-STRUCT: DIPROPSTRING
{ "DIPROPHEADER" "diph" }
{ "WCHAR[260]" "wsz" } ;
TYPEDEF: DIPROPSTRING* LPDIPROPSTRING
TYPEDEF: DIPROPSTRING* LPCDIPROPSTRING
C-STRUCT: CPOINT
{ "LONG" "lP" }
{ "DWORD" "dwLog" } ;
C-STRUCT: DIPROPCPOINTS
{ "DIPROPHEADER" "diph" }
{ "DWORD" "dwCPointsNum" }
{ "CPOINT[8]" "cp" } ;
TYPEDEF: DIPROPCPOINTS* LPDIPROPCPOINTS
TYPEDEF: DIPROPCPOINTS* LPCDIPROPCPOINTS
C-STRUCT: DIENVELOPE C-STRUCT: DIENVELOPE
{ "DWORD" "dwSize" } { "DWORD" "dwSize" }
{ "DWORD" "dwAttackLevel" } { "DWORD" "dwAttackLevel" }
@ -383,19 +434,264 @@ FUNCTION: HRESULT DirectInput8Create ( HINSTANCE hinst, DWORD dwVersion, REFIID
: DIDFT_ENUMCOLLECTION ( n -- instance ) 8 shift HEX: FFFF bitand ; inline : DIDFT_ENUMCOLLECTION ( n -- instance ) 8 shift HEX: FFFF bitand ; inline
: DIDFT_NOCOLLECTION HEX: 00FFFF00 ; inline : DIDFT_NOCOLLECTION HEX: 00FFFF00 ; inline
: DIDOI_FFACTUATOR HEX: 00000001 ; inline
: DIDOI_FFEFFECTTRIGGER HEX: 00000002 ; inline
: DIDOI_POLLED HEX: 00008000 ; inline
: DIDOI_ASPECTPOSITION HEX: 00000100 ; inline
: DIDOI_ASPECTVELOCITY HEX: 00000200 ; inline
: DIDOI_ASPECTACCEL HEX: 00000300 ; inline
: DIDOI_ASPECTFORCE HEX: 00000400 ; inline
: DIDOI_ASPECTMASK HEX: 00000F00 ; inline
: DIDOI_GUIDISUSAGE HEX: 00010000 ; inline
: DISCL_EXCLUSIVE HEX: 00000001 ; inline : DISCL_EXCLUSIVE HEX: 00000001 ; inline
: DISCL_NONEXCLUSIVE HEX: 00000002 ; inline : DISCL_NONEXCLUSIVE HEX: 00000002 ; inline
: DISCL_FOREGROUND HEX: 00000004 ; inline : DISCL_FOREGROUND HEX: 00000004 ; inline
: DISCL_BACKGROUND HEX: 00000008 ; inline : DISCL_BACKGROUND HEX: 00000008 ; inline
: DISCL_NOWINKEY HEX: 00000010 ; inline : DISCL_NOWINKEY HEX: 00000010 ; inline
SYMBOL: +dinput+ : DIK_ESCAPE HEX: 01 ; inline
: DIK_1 HEX: 02 ; inline
: DIK_2 HEX: 03 ; inline
: DIK_3 HEX: 04 ; inline
: DIK_4 HEX: 05 ; inline
: DIK_5 HEX: 06 ; inline
: DIK_6 HEX: 07 ; inline
: DIK_7 HEX: 08 ; inline
: DIK_8 HEX: 09 ; inline
: DIK_9 HEX: 0A ; inline
: DIK_0 HEX: 0B ; inline
: DIK_MINUS HEX: 0C ; inline
: DIK_EQUALS HEX: 0D ; inline
: DIK_BACK HEX: 0E ; inline
: DIK_TAB HEX: 0F ; inline
: DIK_Q HEX: 10 ; inline
: DIK_W HEX: 11 ; inline
: DIK_E HEX: 12 ; inline
: DIK_R HEX: 13 ; inline
: DIK_T HEX: 14 ; inline
: DIK_Y HEX: 15 ; inline
: DIK_U HEX: 16 ; inline
: DIK_I HEX: 17 ; inline
: DIK_O HEX: 18 ; inline
: DIK_P HEX: 19 ; inline
: DIK_LBRACKET HEX: 1A ; inline
: DIK_RBRACKET HEX: 1B ; inline
: DIK_RETURN HEX: 1C ; inline
: DIK_LCONTROL HEX: 1D ; inline
: DIK_A HEX: 1E ; inline
: DIK_S HEX: 1F ; inline
: DIK_D HEX: 20 ; inline
: DIK_F HEX: 21 ; inline
: DIK_G HEX: 22 ; inline
: DIK_H HEX: 23 ; inline
: DIK_J HEX: 24 ; inline
: DIK_K HEX: 25 ; inline
: DIK_L HEX: 26 ; inline
: DIK_SEMICOLON HEX: 27 ; inline
: DIK_APOSTROPHE HEX: 28 ; inline
: DIK_GRAVE HEX: 29 ; inline
: DIK_LSHIFT HEX: 2A ; inline
: DIK_BACKSLASH HEX: 2B ; inline
: DIK_Z HEX: 2C ; inline
: DIK_X HEX: 2D ; inline
: DIK_C HEX: 2E ; inline
: DIK_V HEX: 2F ; inline
: DIK_B HEX: 30 ; inline
: DIK_N HEX: 31 ; inline
: DIK_M HEX: 32 ; inline
: DIK_COMMA HEX: 33 ; inline
: DIK_PERIOD HEX: 34 ; inline
: DIK_SLASH HEX: 35 ; inline
: DIK_RSHIFT HEX: 36 ; inline
: DIK_MULTIPLY HEX: 37 ; inline
: DIK_LMENU HEX: 38 ; inline
: DIK_SPACE HEX: 39 ; inline
: DIK_CAPITAL HEX: 3A ; inline
: DIK_F1 HEX: 3B ; inline
: DIK_F2 HEX: 3C ; inline
: DIK_F3 HEX: 3D ; inline
: DIK_F4 HEX: 3E ; inline
: DIK_F5 HEX: 3F ; inline
: DIK_F6 HEX: 40 ; inline
: DIK_F7 HEX: 41 ; inline
: DIK_F8 HEX: 42 ; inline
: DIK_F9 HEX: 43 ; inline
: DIK_F10 HEX: 44 ; inline
: DIK_NUMLOCK HEX: 45 ; inline
: DIK_SCROLL HEX: 46 ; inline
: DIK_NUMPAD7 HEX: 47 ; inline
: DIK_NUMPAD8 HEX: 48 ; inline
: DIK_NUMPAD9 HEX: 49 ; inline
: DIK_SUBTRACT HEX: 4A ; inline
: DIK_NUMPAD4 HEX: 4B ; inline
: DIK_NUMPAD5 HEX: 4C ; inline
: DIK_NUMPAD6 HEX: 4D ; inline
: DIK_ADD HEX: 4E ; inline
: DIK_NUMPAD1 HEX: 4F ; inline
: DIK_NUMPAD2 HEX: 50 ; inline
: DIK_NUMPAD3 HEX: 51 ; inline
: DIK_NUMPAD0 HEX: 52 ; inline
: DIK_DECIMAL HEX: 53 ; inline
: DIK_OEM_102 HEX: 56 ; inline
: DIK_F11 HEX: 57 ; inline
: DIK_F12 HEX: 58 ; inline
: DIK_F13 HEX: 64 ; inline
: DIK_F14 HEX: 65 ; inline
: DIK_F15 HEX: 66 ; inline
: DIK_KANA HEX: 70 ; inline
: DIK_ABNT_C1 HEX: 73 ; inline
: DIK_CONVERT HEX: 79 ; inline
: DIK_NOCONVERT HEX: 7B ; inline
: DIK_YEN HEX: 7D ; inline
: DIK_ABNT_C2 HEX: 7E ; inline
: DIK_NUMPADEQUALS HEX: 8D ; inline
: DIK_PREVTRACK HEX: 90 ; inline
: DIK_AT HEX: 91 ; inline
: DIK_COLON HEX: 92 ; inline
: DIK_UNDERLINE HEX: 93 ; inline
: DIK_KANJI HEX: 94 ; inline
: DIK_STOP HEX: 95 ; inline
: DIK_AX HEX: 96 ; inline
: DIK_UNLABELED HEX: 97 ; inline
: DIK_NEXTTRACK HEX: 99 ; inline
: DIK_NUMPADENTER HEX: 9C ; inline
: DIK_RCONTROL HEX: 9D ; inline
: DIK_MUTE HEX: A0 ; inline
: DIK_CALCULATOR HEX: A1 ; inline
: DIK_PLAYPAUSE HEX: A2 ; inline
: DIK_MEDIASTOP HEX: A4 ; inline
: DIK_VOLUMEDOWN HEX: AE ; inline
: DIK_VOLUMEUP HEX: B0 ; inline
: DIK_WEBHOME HEX: B2 ; inline
: DIK_NUMPADCOMMA HEX: B3 ; inline
: DIK_DIVIDE HEX: B5 ; inline
: DIK_SYSRQ HEX: B7 ; inline
: DIK_RMENU HEX: B8 ; inline
: DIK_PAUSE HEX: C5 ; inline
: DIK_HOME HEX: C7 ; inline
: DIK_UP HEX: C8 ; inline
: DIK_PRIOR HEX: C9 ; inline
: DIK_LEFT HEX: CB ; inline
: DIK_RIGHT HEX: CD ; inline
: DIK_END HEX: CF ; inline
: DIK_DOWN HEX: D0 ; inline
: DIK_NEXT HEX: D1 ; inline
: DIK_INSERT HEX: D2 ; inline
: DIK_DELETE HEX: D3 ; inline
: DIK_LWIN HEX: DB ; inline
: DIK_RWIN HEX: DC ; inline
: DIK_APPS HEX: DD ; inline
: DIK_POWER HEX: DE ; inline
: DIK_SLEEP HEX: DF ; inline
: DIK_WAKE HEX: E3 ; inline
: DIK_WEBSEARCH HEX: E5 ; inline
: DIK_WEBFAVORITES HEX: E6 ; inline
: DIK_WEBREFRESH HEX: E7 ; inline
: DIK_WEBSTOP HEX: E8 ; inline
: DIK_WEBFORWARD HEX: E9 ; inline
: DIK_WEBBACK HEX: EA ; inline
: DIK_MYCOMPUTER HEX: EB ; inline
: DIK_MAIL HEX: EC ; inline
: DIK_MEDIASELECT HEX: ED ; inline
: create-dinput ( -- ) : DIK_BACKSPACE DIK_BACK ; inline
f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid : DIK_NUMPADSTAR DIK_MULTIPLY ; inline
f <void*> [ f DirectInput8Create ole32-error ] keep *void* : DIK_LALT DIK_LMENU ; inline
+dinput+ set ; : DIK_CAPSLOCK DIK_CAPITAL ; inline
: DIK_NUMPADMINUS DIK_SUBTRACT ; inline
: DIK_NUMPADPLUS DIK_ADD ; inline
: DIK_NUMPADPERIOD DIK_DECIMAL ; inline
: DIK_NUMPADSLASH DIK_DIVIDE ; inline
: DIK_RALT DIK_RMENU ; inline
: DIK_UPARROW DIK_UP ; inline
: DIK_PGUP DIK_PRIOR ; inline
: DIK_LEFTARROW DIK_LEFT ; inline
: DIK_RIGHTARROW DIK_RIGHT ; inline
: DIK_DOWNARROW DIK_DOWN ; inline
: DIK_PGDN DIK_NEXT ; inline
: delete-dinput ( -- ) : DIK_CIRCUMFLEX DIK_PREVTRACK ; inline
+dinput+ [ com-release f ] change ;
: DI8DEVTYPE_DEVICE HEX: 11 ; inline
: DI8DEVTYPE_MOUSE HEX: 12 ; inline
: DI8DEVTYPE_KEYBOARD HEX: 13 ; inline
: DI8DEVTYPE_JOYSTICK HEX: 14 ; inline
: DI8DEVTYPE_GAMEPAD HEX: 15 ; inline
: DI8DEVTYPE_DRIVING HEX: 16 ; inline
: DI8DEVTYPE_FLIGHT HEX: 17 ; inline
: DI8DEVTYPE_1STPERSON HEX: 18 ; inline
: DI8DEVTYPE_DEVICECTRL HEX: 19 ; inline
: DI8DEVTYPE_SCREENPOINTER HEX: 1A ; inline
: DI8DEVTYPE_REMOTE HEX: 1B ; inline
: DI8DEVTYPE_SUPPLEMENTAL HEX: 1C ; inline
: GET_DIDEVICE_TYPE ( dwType -- type ) HEX: FF bitand ; inline
: DIPROPRANGE_NOMIN HEX: 80000000 ; inline
: DIPROPRANGE_NOMAX HEX: 7FFFFFFF ; inline
: MAXCPOINTSNUM 8 ; inline
: DIPH_DEVICE 0 ; inline
: DIPH_BYOFFSET 1 ; inline
: DIPH_BYID 2 ; inline
: DIPH_BYUSAGE 3 ; inline
: DIMAKEUSAGEDWORD ( UsagePage Usage -- DWORD ) 16 shift bitor ; inline
: DIPROP_BUFFERSIZE 1 <alien> ; inline
: DIPROP_AXISMODE 2 <alien> ; inline
: DIPROPAXISMODE_ABS 0 ; inline
: DIPROPAXISMODE_REL 1 ; inline
: DIPROP_GRANULARITY 3 <alien> ; inline
: DIPROP_RANGE 4 <alien> ; inline
: DIPROP_DEADZONE 5 <alien> ; inline
: DIPROP_SATURATION 6 <alien> ; inline
: DIPROP_FFGAIN 7 <alien> ; inline
: DIPROP_FFLOAD 8 <alien> ; inline
: DIPROP_AUTOCENTER 9 <alien> ; inline
: DIPROPAUTOCENTER_OFF 0 ; inline
: DIPROPAUTOCENTER_ON 1 ; inline
: DIPROP_CALIBRATIONMODE 10 <alien> ; inline
: DIPROPCALIBRATIONMODE_COOKED 0 ; inline
: DIPROPCALIBRATIONMODE_RAW 1 ; inline
: DIPROP_CALIBRATION 11 <alien> ; inline
: DIPROP_GUIDANDPATH 12 <alien> ; inline
: DIPROP_INSTANCENAME 13 <alien> ; inline
: DIPROP_PRODUCTNAME 14 <alien> ; inline
: DIPROP_JOYSTICKID 15 <alien> ; inline
: DIPROP_GETPORTDISPLAYNAME 16 <alien> ; inline
: DIPROP_PHYSICALRANGE 18 <alien> ; inline
: DIPROP_LOGICALRANGE 19 <alien> ; inline
: DIPROP_KEYNAME 20 <alien> ; inline
: DIPROP_CPOINTS 21 <alien> ; inline
: DIPROP_APPDATA 22 <alien> ; inline
: DIPROP_SCANCODE 23 <alien> ; inline
: DIPROP_VIDPID 24 <alien> ; inline
: DIPROP_USERNAME 25 <alien> ; inline
: DIPROP_TYPENAME 26 <alien> ; inline
: GUID_XAxis GUID: {A36D02E0-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_YAxis GUID: {A36D02E1-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_ZAxis GUID: {A36D02E2-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_RxAxis GUID: {A36D02F4-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_RyAxis GUID: {A36D02F5-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_RzAxis GUID: {A36D02E3-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_Slider GUID: {A36D02E4-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_Button GUID: {A36D02F0-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_Key GUID: {55728220-D33C-11CF-BFC7-444553540000} ; inline
: GUID_POV GUID: {A36D02F2-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_Unknown GUID: {A36D02F3-C9F3-11CF-BFC7-444553540000} ; inline
: GUID_SysMouse GUID: {6F1D2B60-D5A0-11CF-BFC7-444553540000} ; inline
: GUID_SysKeyboard GUID: {6F1D2B61-D5A0-11CF-BFC7-444553540000} ; inline
: GUID_Joystick GUID: {6F1D2B70-D5A0-11CF-BFC7-444553540000} ; inline
: GUID_SysMouseEm GUID: {6F1D2B80-D5A0-11CF-BFC7-444553540000} ; inline
: GUID_SysMouseEm2 GUID: {6F1D2B81-D5A0-11CF-BFC7-444553540000} ; inline
: GUID_SysKeyboardEm GUID: {6F1D2B82-D5A0-11CF-BFC7-444553540000} ; inline
: GUID_SysKeyboardEm2 GUID: {6F1D2B83-D5A0-11CF-BFC7-444553540000} ; inline

12
extra/windows/ole32/ole32.factor
View File

@ -1,5 +1,5 @@
USING: alien alien.syntax alien.c-types alien.strings math USING: alien alien.syntax alien.c-types alien.strings math
kernel sequences windows windows.types kernel sequences windows windows.types debugger io accessors
math.order ; math.order ;
IN: windows.ole32 IN: windows.ole32
@ -115,10 +115,14 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
: succeeded? ( hresult -- ? ) : succeeded? ( hresult -- ? )
0 HEX: 7FFFFFFF between? ; 0 HEX: 7FFFFFFF between? ;
TUPLE: ole32-error error-code ;
C: <ole32-error> ole32-error
M: ole32-error error.
"COM method failed: " print error-code>> (win32-error-string) print ;
: ole32-error ( hresult -- ) : ole32-error ( hresult -- )
dup succeeded? [ dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
drop
] [ (win32-error-string) throw ] if ;
: ole-initialize ( -- ) : ole-initialize ( -- )
f OleInitialize ole32-error ; f OleInitialize ole32-error ;

28
extra/windows/user32/user32.factor
View File

@ -528,6 +528,27 @@ C-STRUCT: TRACKMOUSEEVENT
{ "DWORD" "dwHoverTime" } ; { "DWORD" "dwHoverTime" } ;
TYPEDEF: TRACKMOUSEEVENT* LPTRACKMOUSEEVENT TYPEDEF: TRACKMOUSEEVENT* LPTRACKMOUSEEVENT
: DBT_DEVICEARRIVAL HEX: 8000 ; inline
: DBT_DEVICEREMOVECOMPLETE HEX: 8004 ; inline
: DBT_DEVTYP_DEVICEINTERFACE 5 ; inline
: DEVICE_NOTIFY_WINDOW_HANDLE 0 ; inline
: DEVICE_NOTIFY_SERVICE_HANDLE 1 ; inline
: DEVICE_NOTIFY_ALL_INTERFACE_CLASSES 4 ; inline
C-STRUCT: DEV_BROADCAST_HDR
{ "DWORD" "dbch_size" }
{ "DWORD" "dbch_devicetype" }
{ "DWORD" "dbch_reserved" } ;
C-STRUCT: DEV_BROADCAST_DEVICEW
{ "DWORD" "dbcc_size" }
{ "DWORD" "dbcc_devicetype" }
{ "DWORD" "dbcc_reserved" }
{ "GUID" "dbcc_classguid" }
{ "WCHAR[1]" "dbcc_name" } ;
LIBRARY: user32 LIBRARY: user32
FUNCTION: HKL ActivateKeyboardLayout ( HKL hkl, UINT Flags ) ; FUNCTION: HKL ActivateKeyboardLayout ( HKL hkl, UINT Flags ) ;
@ -1176,8 +1197,9 @@ ALIAS: RegisterClassEx RegisterClassExW
! FUNCTION: RegisterClipboardFormatA ! FUNCTION: RegisterClipboardFormatA
! FUNCTION: RegisterClipboardFormatW ! FUNCTION: RegisterClipboardFormatW
! FUNCTION: RegisterDeviceNotificationA FUNCTION: HANDLE RegisterDeviceNotificationA ( HANDLE hRecipient, LPVOID NotificationFilter, DWORD Flags ) ;
! FUNCTION: RegisterDeviceNotificationW FUNCTION: HANDLE RegisterDeviceNotificationW ( HANDLE hRecipient, LPVOID NotificationFilter, DWORD Flags ) ;
ALIAS: RegisterDeviceNotification RegisterDeviceNotificationW
! FUNCTION: RegisterHotKey ! FUNCTION: RegisterHotKey
! FUNCTION: RegisterLogonProcess ! FUNCTION: RegisterLogonProcess
! FUNCTION: RegisterMessagePumpHook ! FUNCTION: RegisterMessagePumpHook
@ -1344,7 +1366,7 @@ FUNCTION: BOOL TranslateMessage ( MSG* lpMsg ) ;
! FUNCTION: UnpackDDElParam ! FUNCTION: UnpackDDElParam
FUNCTION: BOOL UnregisterClassW ( LPCWSTR lpClassName, HINSTANCE hInstance ) ; FUNCTION: BOOL UnregisterClassW ( LPCWSTR lpClassName, HINSTANCE hInstance ) ;
ALIAS: UnregisterClass UnregisterClassW ALIAS: UnregisterClass UnregisterClassW
! FUNCTION: UnregisterDeviceNotification FUNCTION: BOOL UnregisterDeviceNotification ( HANDLE hDevNotify ) ;
! FUNCTION: UnregisterHotKey ! FUNCTION: UnregisterHotKey
! FUNCTION: UnregisterMessagePumpHook ! FUNCTION: UnregisterMessagePumpHook
! FUNCTION: UnregisterUserApiHook ! FUNCTION: UnregisterUserApiHook

5
unfinished/compiler/tree/branch-fusion/branch-fusion.factor Normal file
View File

@ -0,0 +1,5 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.branch-fusion
: fuse-branches ( nodes -- nodes' ) ;

12
unfinished/compiler/tree/builder/builder.factor
View File

@ -7,11 +7,11 @@ stack-checker.state stack-checker.visitor stack-checker.errors
stack-checker.backend compiler.tree ; stack-checker.backend compiler.tree ;
IN: compiler.tree.builder IN: compiler.tree.builder
: with-tree-builder ( quot -- dataflow ) : with-tree-builder ( quot -- nodes )
[ node-list new stack-visitor set ] prepose [ V{ } clone stack-visitor set ] prepose
with-infer first>> ; inline with-infer ; inline
GENERIC# build-tree-with 1 ( quot stack -- dataflow ) GENERIC# build-tree-with 1 ( quot stack -- nodes )
M: callable build-tree-with M: callable build-tree-with
#! Not safe to call from inference transforms. #! Not safe to call from inference transforms.
@ -20,7 +20,7 @@ M: callable build-tree-with
f infer-quot f infer-quot
] with-tree-builder nip ; ] with-tree-builder nip ;
: build-tree ( quot -- dataflow ) f build-tree-with ; : build-tree ( quot -- nodes ) f build-tree-with ;
: (make-specializer) ( class picker -- quot ) : (make-specializer) ( class picker -- quot )
swap "predicate" word-prop append ; swap "predicate" word-prop append ;
@ -65,7 +65,7 @@ M: callable build-tree-with
[ drop ] [ drop ]
} cond ; } cond ;
: build-tree-from-word ( word -- effect dataflow ) : build-tree-from-word ( word -- effect nodes )
[ [
[ [
dup +cannot-infer+ word-prop [ cannot-infer-effect ] when dup +cannot-infer+ word-prop [ cannot-infer-effect ] when

5
unfinished/compiler/tree/cleanup/cleanup.factor Normal file
View File

@ -0,0 +1,5 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.cleanup
: cleanup ( nodes -- nodes' ) ;

16
unfinished/compiler/tree/combinators/combinators-tests.factor
View File

@ -1,17 +1,5 @@
IN: compiler.tree.combinators.tests IN: compiler.tree.combinators.tests
USING: compiler.tree.combinators compiler.tree.builder tools.test USING: compiler.tree.combinators tools.test kernel ;
kernel ;
[ ] [ [ 1 ] build-tree [ ] transform-nodes drop ] unit-test
[ ] [ [ 1 2 3 ] build-tree [ ] transform-nodes drop ] unit-test
{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
{ 1 0 }
[
[ [ iterate-next ] iterate-nodes ] with-node-iterator
] must-infer-as
{ 1 0 } [ [ drop ] each-node ] must-infer-as { 1 0 } [ [ drop ] each-node ] must-infer-as
{ 1 1 } [ [ ] map-nodes ] must-infer-as
{ 1 0 } [ [ ] map-children ] must-infer-as

80
unfinished/compiler/tree/combinators/combinators.factor
View File

@ -1,64 +1,30 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry arrays generic assocs kernel math namespaces parser USING: fry kernel accessors sequences sequences.deep
sequences words vectors math.intervals effects classes compiler.tree ;
accessors combinators compiler.tree ;
IN: compiler.tree.combinators IN: compiler.tree.combinators
SYMBOL: node-stack : each-node ( nodes quot -- )
dup dup '[
: >node ( node -- ) node-stack get push ; , [
: node> ( -- node ) node-stack get pop ; dup #branch? [
: node@ ( -- node ) node-stack get peek ; children>> [ , each-node ] each
: iterate-next ( -- node ) node@ successor>> ;
: iterate-nodes ( node quot -- )
over [
[ swap >node call node> drop ] keep iterate-nodes
] [ ] [
2drop dup #recursive? [
] if ; inline child>> , each-node
] [ drop ] if
] if
] bi
] each ; inline
: (each-node) ( quot -- next ) : map-nodes ( nodes quot: ( node -- node' ) -- nodes )
node@ [ swap call ] 2keep dup dup '[
children>> [ @
first>> [ dup #branch? [
[ (each-node) ] keep swap [ [ , map-nodes ] map ] change-children
] iterate-nodes
] each drop
iterate-next ; inline
: with-node-iterator ( quot -- )
>r V{ } clone node-stack r> with-variable ; inline
: each-node ( node quot -- )
[
swap [
[ (each-node) ] keep swap
] iterate-nodes drop
] with-node-iterator ; inline
: map-children ( node quot -- )
[ children>> ] dip '[ , change-first drop ] each ; inline
: (transform-nodes) ( prev node quot -- )
dup >r call dup [
>>successor
successor>> dup successor>>
r> (transform-nodes)
] [ ] [
r> 2drop f >>successor drop dup #recursive? [
] if ; inline [ , map-nodes ] change-child
] when
: transform-nodes ( node quot -- new-node ) ] if
over [ ] map flatten ; inline recursive
[ call dup dup successor>> ] keep (transform-nodes)
] [ drop ] if ; inline
: tail-call? ( -- ? )
#! We don't consider calls which do non-local exits to be
#! tail calls, because this gives better error traces.
node-stack get [
successor>> [ #tail? ] [ #terminate? not ] bi and
] all? ;

18
unfinished/compiler/tree/copy-equiv/copy-equiv.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces disjoint-sets sequences assocs USING: namespaces disjoint-sets sequences assocs math
kernel accessors fry kernel accessors fry
compiler.tree compiler.tree.def-use compiler.tree.combinators ; compiler.tree compiler.tree.def-use compiler.tree.combinators ;
IN: compiler.tree.copy-equiv IN: compiler.tree.copy-equiv
@ -31,6 +31,22 @@ M: #r> compute-copy-equiv*
M: #copy compute-copy-equiv* M: #copy compute-copy-equiv*
[ in-d>> ] [ out-d>> ] bi are-copies-of ; [ in-d>> ] [ out-d>> ] bi are-copies-of ;
M: #return-recursive compute-copy-equiv*
[ in-d>> ] [ out-d>> ] bi are-copies-of ;
: compute-phi-equiv ( inputs outputs -- )
#! An output is a copy of every input if all inputs are
#! copies of the same original value.
[
swap [ resolve-copy ] map sift
dup [ all-equal? ] [ empty? not ] bi and
[ first swap is-copy-of ] [ 2drop ] if
] 2each ;
M: #phi compute-copy-equiv*
[ [ phi-in-d>> ] [ out-d>> ] bi compute-phi-equiv ]
[ [ phi-in-r>> ] [ out-r>> ] bi compute-phi-equiv ] bi ;
M: node compute-copy-equiv* drop ; M: node compute-copy-equiv* drop ;
: compute-copy-equiv ( node -- node ) : compute-copy-equiv ( node -- node )

4
unfinished/compiler/tree/dfa/backward/backward.factor → unfinished/compiler/tree/dataflow-analysis/backward/backward.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.dfa.backward IN: compiler.tree.dataflow-analysis.backward
USING: accessors sequences assocs kernel compiler.tree USING: accessors sequences assocs kernel compiler.tree
compiler.tree.dfa ; compiler.tree.dataflow-analysis ;
GENERIC: backward ( value node -- ) GENERIC: backward ( value node -- )

2
unfinished/compiler/tree/dfa/dfa.factor → unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor
View File

@ -3,7 +3,7 @@
USING: fry accessors namespaces assocs dequeues search-dequeues USING: fry accessors namespaces assocs dequeues search-dequeues
kernel sequences words sets stack-checker.inlining compiler.tree kernel sequences words sets stack-checker.inlining compiler.tree
compiler.tree.def-use compiler.tree.combinators ; compiler.tree.def-use compiler.tree.combinators ;
IN: compiler.tree.dfa IN: compiler.tree.dataflow-analysis
! Dataflow analysis ! Dataflow analysis
SYMBOL: work-list SYMBOL: work-list

8
unfinished/compiler/tree/dead-code/dead-code.factor
View File

@ -3,8 +3,8 @@
USING: fry accessors namespaces assocs dequeues search-dequeues USING: fry accessors namespaces assocs dequeues search-dequeues
kernel sequences words sets stack-checker.inlining kernel sequences words sets stack-checker.inlining
compiler.tree compiler.tree
compiler.tree.dfa compiler.tree.dataflow-analysis
compiler.tree.dfa.backward compiler.tree.dataflow-analysis.backward
compiler.tree.combinators ; compiler.tree.combinators ;
IN: compiler.tree.dead-code IN: compiler.tree.dead-code
@ -21,9 +21,7 @@ M: #call mark-live-values
[ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ; [ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
M: #return mark-live-values M: #return mark-live-values
#! Values returned by local #recursive functions can be look-at-inputs ;
#! killed if they're unused.
dup label>> [ drop ] [ look-at-inputs ] if ;
M: node mark-live-values drop ; M: node mark-live-values drop ;

52
unfinished/compiler/tree/def-use/def-use.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sequences kernel generic assocs classes USING: arrays namespaces assocs sequences kernel generic assocs
vectors accessors combinators sets stack-checker.state classes vectors accessors combinators sets stack-checker.state
compiler.tree compiler.tree.combinators ; compiler.tree compiler.tree.combinators ;
IN: compiler.tree.def-use IN: compiler.tree.def-use
@ -9,56 +9,60 @@ SYMBOL: def-use
TUPLE: definition value node uses ; TUPLE: definition value node uses ;
: <definition> ( value -- definition ) : <definition> ( node value -- definition )
definition new definition new
swap >>value swap >>value
swap >>node
V{ } clone >>uses ; V{ } clone >>uses ;
: def-of ( value -- definition ) : def-of ( value -- definition )
def-use get [ <definition> ] cache ; def-use get at* [ "No def" throw ] unless ;
: def-value ( node value -- ) : def-value ( node value -- )
def-of [ [ "Multiple defs" throw ] when ] change-node drop ; def-use get 2dup key? [
"Multiple defs" throw
] [
[ [ <definition> ] keep ] dip set-at
] if ;
: used-by ( value -- nodes ) def-of uses>> ; : used-by ( value -- nodes ) def-of uses>> ;
: use-value ( node value -- ) used-by push ; : use-value ( node value -- ) used-by push ;
: defined-by ( value -- node ) def-use get at node>> ; : defined-by ( value -- node ) def-of node>> ;
GENERIC: node-uses-values ( node -- values ) GENERIC: node-uses-values ( node -- values )
M: #declare node-uses-values declaration>> keys ; M: #introduce node-uses-values drop f ;
M: #push node-uses-values drop f ;
M: #phi node-uses-values
[ phi-in-d>> concat ] [ phi-in-r>> concat ] bi
append sift prune ;
M: #r> node-uses-values in-r>> ; M: #r> node-uses-values in-r>> ;
M: #phi node-uses-values
[ phi-in-d>> ] [ phi-in-r>> ] bi append concat sift prune ;
M: #declare node-uses-values declaration>> keys ;
M: node node-uses-values in-d>> ; M: node node-uses-values in-d>> ;
GENERIC: node-defs-values ( node -- values ) GENERIC: node-defs-values ( node -- values )
M: #introduce node-defs-values values>> ; M: #introduce node-defs-values value>> 1array ;
M: #>r node-defs-values out-r>> ; M: #>r node-defs-values out-r>> ;
M: #branch node-defs-values drop f ;
M: #phi node-defs-values [ out-d>> ] [ out-r>> ] bi append ; M: #phi node-defs-values [ out-d>> ] [ out-r>> ] bi append ;
M: #declare node-defs-values drop f ;
M: #return node-defs-values drop f ;
M: #recursive node-defs-values drop f ;
M: #terminate node-defs-values drop f ;
M: node node-defs-values out-d>> ; M: node node-defs-values out-d>> ;
: node-def-use ( node -- ) : node-def-use ( node -- )
[ dup node-uses-values [ use-value ] with each ] [ dup node-uses-values [ use-value ] with each ]
[ dup node-defs-values [ def-value ] with each ] bi ; [ dup node-defs-values [ def-value ] with each ] bi ;
: check-use ( uses -- )
[ empty? [ "No use" throw ] when ]
[ all-unique? [ "Uses not all unique" throw ] unless ] bi ;
: check-def-use ( -- ) : check-def-use ( -- )
def-use get [ def-use get [ nip uses>> check-use ] assoc-each ;
nip
[ node>> [ "No def" throw ] unless ]
[ uses>> all-unique? [ "Uses not all unique" throw ] unless ]
bi
] assoc-each ;
: compute-def-use ( node -- node ) : compute-def-use ( node -- node )
H{ } clone def-use set H{ } clone def-use set

5
unfinished/compiler/tree/elaboration/elaboration.factor Normal file
View File

@ -0,0 +1,5 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.elaboration
: elaborate ( nodes -- nodes' ) ;

5
unfinished/compiler/tree/loop-detection/loop-detection.factor Normal file
View File

@ -0,0 +1,5 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.loop-detection
: detect-loops ( nodes -- nodes' ) ;

27
unfinished/compiler/tree/normalization/normalization-tests.factor Normal file
View File

@ -0,0 +1,27 @@
IN: compiler.tree.normalization.tests
USING: compiler.tree.builder compiler.tree.normalization
compiler.tree sequences accessors tools.test kernel ;
\ count-introductions must-infer
\ fixup-enter-recursive must-infer
\ eliminate-introductions must-infer
\ normalize must-infer
[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
[ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree count-introductions ] unit-test
[ 3 ] [ [ [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
: foo ( -- ) swap ; inline recursive
: recursive-inputs ( nodes -- n )
[ #recursive? ] find nip child>> first in-d>> length ;
[ 0 2 ] [
[ foo ] build-tree
[ recursive-inputs ]
[ normalize recursive-inputs ] bi
] unit-test

125
unfinished/compiler/tree/normalization/normalization.factor Normal file
View File

@ -0,0 +1,125 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces sequences math accessors kernel arrays
stack-checker.backend stack-checker.inlining compiler.tree
compiler.tree.combinators ;
IN: compiler.tree.normalization
! A transform pass done before optimization can begin to
! fix up some oddities in the tree output by the stack checker:
!
! - We rewrite the code is that #introduce nodes only appear
! at the top level, and not inside #recursive. This enables more
! accurate type inference for 'row polymorphic' combinators.
!
! - We collect #return-recursive and #call-recursive nodes and
! store them in the #recursive's label slot.
!
! - We normalize #call-recursive as follows. The stack checker
! says that the inputs of a #call-recursive are the entire stack
! at the time of the call. This is a conservative estimate; we
! don't know the exact number of stack values it touches until
! the #return-recursive node has been visited, because of row
! polymorphism. So in the normalize pass, we split a
! #call-recursive into a #copy of the unchanged values and a
! #call-recursive with trimmed inputs and outputs.
! Collect introductions
SYMBOL: introductions
GENERIC: count-introductions* ( node -- )
: count-introductions ( nodes -- n )
#! Note: we use each, not each-node, since the #branch
#! method recurses into children directly and we don't
#! recurse into #recursive at all.
[
0 introductions set
[ count-introductions* ] each
introductions get
] with-scope ;
M: #introduce count-introductions* drop introductions inc ;
M: #branch count-introductions*
children>>
[ count-introductions ] map supremum
introductions [ + ] change ;
M: node count-introductions* drop ;
! Collect label info
GENERIC: collect-label-info ( node -- )
M: #return-recursive collect-label-info dup label>> (>>return) ;
M: #call-recursive collect-label-info dup label>> calls>> push ;
M: #recursive collect-label-info
[ label>> ] [ child>> count-introductions ] bi
>>introductions drop ;
M: node collect-label-info drop ;
! Eliminate introductions
SYMBOL: introduction-stack
: fixup-enter-recursive ( recursive -- )
[ child>> first ] [ in-d>> ] bi >>in-d
[ introduction-stack get prepend ] change-out-d
drop ;
GENERIC: eliminate-introductions* ( node -- node' )
: pop-introduction ( -- value )
introduction-stack [ unclip-last swap ] change ;
M: #introduce eliminate-introductions*
pop-introduction swap value>> [ 1array ] bi@ #copy ;
SYMBOL: remaining-introductions
M: #branch eliminate-introductions*
dup children>> [
[
[ eliminate-introductions* ] change-each
introduction-stack get
] with-scope
] map
[ remaining-introductions set ]
[ [ length ] map infimum introduction-stack [ swap head ] change ]
bi ;
M: #phi eliminate-introductions*
remaining-introductions get swap
[ flip [ over length tail append ] 2map flip ] change-phi-in-d ;
M: node eliminate-introductions* ;
: eliminate-introductions ( recursive n -- )
make-values introduction-stack [
[ fixup-enter-recursive ]
[ child>> [ eliminate-introductions* ] change-each ] bi
] with-variable ;
! Normalize
GENERIC: normalize* ( node -- node' )
M: #recursive normalize*
dup dup label>> introductions>> eliminate-introductions ;
: unchanged-underneath ( #call-recursive -- n )
[ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
M: #call-recursive normalize*
dup unchanged-underneath
[ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ , head ] ] bi* bi@ #copy ]
[ '[ , tail ] [ change-in-d ] [ change-out-d ] bi ]
2bi 2array ;
M: node normalize* ;
: normalize ( nodes -- nodes' )
[ [ collect-label-info ] each-node ]
[ [ normalize* ] map-nodes ]
bi ;

22
unfinished/compiler/tree/optimizer/optimizer.factor Normal file
View File

@ -0,0 +1,22 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.tree.normalization compiler.tree.copy-equiv
compiler.tree.propagation compiler.tree.cleanup
compiler.tree.def-use compiler.tree.untupling
compiler.tree.dead-code compiler.tree.strength-reduction
compiler.tree.loop-detection compiler.tree.branch-fusion ;
IN: compiler.tree.optimizer
: optimize-tree ( nodes -- nodes' )
normalize
compute-copy-equiv
propagate
cleanup
compute-def-use
unbox-tuples
compute-def-use
remove-dead-code
strength-reduce
detect-loops
fuse-branches
elaborate ;

102
unfinished/compiler/tree/propagation/branches/branches.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry kernel sequences assocs accessors namespaces USING: fry kernel sequences assocs accessors namespaces
math.intervals arrays classes.algebra locals math.intervals arrays classes.algebra combinators
compiler.tree compiler.tree
compiler.tree.def-use compiler.tree.def-use
compiler.tree.propagation.info compiler.tree.propagation.info
@ -31,46 +31,94 @@ M: #dispatch live-children
[ children>> ] [ in-d>> first value-info interval>> ] bi [ children>> ] [ in-d>> first value-info interval>> ] bi
'[ , interval-contains? [ drop f ] unless ] map-index ; '[ , interval-contains? [ drop f ] unless ] map-index ;
: infer-children ( node -- assocs ) SYMBOL: infer-children-data
: copy-value-info ( -- )
value-infos [ clone ] change
constraints [ clone ] change ;
: infer-children ( node -- )
[ live-children ] [ child-constraints ] bi [ [ live-children ] [ child-constraints ] bi [
[ [
over [ over [
value-infos [ clone ] change copy-value-info
constraints [ clone ] change
assume assume
first>> (propagate) (propagate)
] [ ] [
2drop 2drop
value-infos off value-infos off
constraints off constraints off
] if ] if
] H{ } make-assoc ] H{ } make-assoc
] 2map ; ] 2map infer-children-data set ;
: (merge-value-infos) ( inputs results -- infos ) : compute-phi-input-infos ( phi-in -- phi-info )
'[ , [ [ value-info ] bind ] 2map value-infos-union ] map ; infer-children-data get
'[ , [ [ value-info ] bind ] 2map ] map ;
: merge-value-infos ( results inputs outputs -- ) : annotate-phi-node ( #phi -- )
[ swap (merge-value-infos) ] dip set-value-infos ; dup phi-in-d>> compute-phi-input-infos >>phi-info-d
dup phi-in-r>> compute-phi-input-infos >>phi-info-r
dup [ out-d>> ] [ out-r>> ] bi append extract-value-info >>info
drop ;
: propagate-branch-phi ( results #phi -- ) : merge-value-infos ( infos outputs -- )
[ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ] [ [ value-infos-union ] map ] dip set-value-infos ;
[ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
2bi ;
:: branch-phi-constraints ( x #phi -- ) SYMBOL: condition-value
#phi [ out-d>> ] [ phi-in-d>> ] bi [
first2 2dup and [ USE: prettyprint
[ [ =t x =t /\ ] [ =t x =f /\ ] bi* \/ swap t--> dup . assume ]
[ [ =f x =t /\ ] [ =f x =f /\ ] bi* \/ swap f--> dup . assume ]
3bi
] [ 3drop ] if
] 2each ;
: merge-children ( results node -- ) M: #phi propagate-before ( #phi -- )
[ successor>> propagate-branch-phi ] [ annotate-phi-node ]
[ [ in-d>> first ] [ successor>> ] bi 2drop ] ! branch-phi-constraints ] [ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ]
bi ; [ [ phi-info-r>> ] [ out-r>> ] bi merge-value-infos ]
tri ;
: branch-phi-constraints ( output values booleans -- )
{
{
{ { t } { f } }
[
drop condition-value get
[ [ =t ] [ =t ] bi* <--> ]
[ [ =f ] [ =f ] bi* <--> ] 2bi /\ assume
]
}
{
{ { f } { t } }
[
drop condition-value get
[ [ =t ] [ =f ] bi* <--> ]
[ [ =f ] [ =t ] bi* <--> ] 2bi /\ assume
]
}
{
{ { t f } { f } }
[ first =t condition-value get =t /\ swap t--> assume ]
}
{
{ { f } { t f } }
[ second =t condition-value get =f /\ swap t--> assume ]
}
[ 3drop ]
} case ;
M: #phi propagate-after ( #phi -- )
condition-value get [
[ out-d>> ] [ phi-in-d>> ] [ phi-info-d>> ] tri
3array flip [
first3 [ possible-boolean-values ] map
branch-phi-constraints
] each
] [ drop ] if ;
M: #phi propagate-around ( #phi -- )
[ propagate-before ] [ propagate-after ] bi ;
M: #branch propagate-around M: #branch propagate-around
[ infer-children ] [ merge-children ] [ annotate-node ] tri ; [ infer-children ] [ annotate-node ] bi ;
M: #if propagate-around
[ in-d>> first condition-value set ] [ call-next-method ] bi ;
M: #dispatch propagate-around
condition-value off call-next-method ;

82
unfinished/compiler/tree/propagation/constraints/constraints.factor
View File

@ -12,38 +12,42 @@ IN: compiler.tree.propagation.constraints
! Maps constraints to constraints ("A implies B") ! Maps constraints to constraints ("A implies B")
SYMBOL: constraints SYMBOL: constraints
GENERIC: assume ( constraint -- ) GENERIC: assume* ( constraint -- )
GENERIC: satisfied? ( constraint -- ? ) GENERIC: satisfied? ( constraint -- ? )
GENERIC: satisfiable? ( constraint -- ? )
M: f assume* drop ;
! satisfied? is inaccurate. It's just used to prevent infinite
! loops so its only implemented for true-constraints and
! false-constraints.
M: object satisfied? drop f ;
: assume ( constraint -- ) dup satisfied? [ drop ] [ assume* ] if ;
! Boolean constraints ! Boolean constraints
TUPLE: true-constraint value ; TUPLE: true-constraint value ;
: =t ( value -- constriant ) resolve-copy true-constraint boa ; : =t ( value -- constriant ) resolve-copy true-constraint boa ;
M: true-constraint assume M: true-constraint assume*
[ constraints get at [ assume ] when* ]
[ \ f class-not <class-info> swap value>> refine-value-info ] [ \ f class-not <class-info> swap value>> refine-value-info ]
[ constraints get at [ assume ] when* ]
bi ; bi ;
M: true-constraint satisfied? value>> \ f class-not value-is? ; M: true-constraint satisfied?
value>> value-info class>> true-class? ;
M: true-constraint satisfiable? value>> \ f class-not value-is? ;
TUPLE: false-constraint value ; TUPLE: false-constraint value ;
: =f ( value -- constriant ) resolve-copy false-constraint boa ; : =f ( value -- constriant ) resolve-copy false-constraint boa ;
M: false-constraint assume M: false-constraint assume*
[ constraints get at [ assume ] when* ]
[ \ f <class-info> swap value>> refine-value-info ] [ \ f <class-info> swap value>> refine-value-info ]
[ constraints get at [ assume ] when* ]
bi ; bi ;
M: false-constraint satisfied? M: false-constraint satisfied?
value>> value-info class>> \ f class<= ; value>> value-info class>> false-class? ;
M: false-constraint satisfiable?
value>> value-info class>> \ f classes-intersect? ;
! Class constraints ! Class constraints
TUPLE: class-constraint value class ; TUPLE: class-constraint value class ;
@ -51,7 +55,7 @@ TUPLE: class-constraint value class ;
: is-instance-of ( value class -- constraint ) : is-instance-of ( value class -- constraint )
[ resolve-copy ] dip class-constraint boa ; [ resolve-copy ] dip class-constraint boa ;
M: class-constraint assume M: class-constraint assume*
[ class>> <class-info> ] [ value>> ] bi refine-value-info ; [ class>> <class-info> ] [ value>> ] bi refine-value-info ;
! Interval constraints ! Interval constraints
@ -60,7 +64,7 @@ TUPLE: interval-constraint value interval ;
: is-in-interval ( value interval -- constraint ) : is-in-interval ( value interval -- constraint )
[ resolve-copy ] dip interval-constraint boa ; [ resolve-copy ] dip interval-constraint boa ;
M: interval-constraint assume M: interval-constraint assume*
[ interval>> <interval-info> ] [ value>> ] bi refine-value-info ; [ interval>> <interval-info> ] [ value>> ] bi refine-value-info ;
! Literal constraints ! Literal constraints
@ -69,7 +73,7 @@ TUPLE: literal-constraint value literal ;
: is-equal-to ( value literal -- constraint ) : is-equal-to ( value literal -- constraint )
[ resolve-copy ] dip literal-constraint boa ; [ resolve-copy ] dip literal-constraint boa ;
M: literal-constraint assume M: literal-constraint assume*
[ literal>> <literal-info> ] [ value>> ] bi refine-value-info ; [ literal>> <literal-info> ] [ value>> ] bi refine-value-info ;
! Implication constraints ! Implication constraints
@ -77,46 +81,32 @@ TUPLE: implication p q ;
C: --> implication C: --> implication
M: implication assume : assume-implication ( p q -- )
[ q>> ] [ p>> ] bi [ constraints get [ swap suffix ] change-at ]
[ constraints get set-at ]
[ satisfied? [ assume ] [ drop ] if ] 2bi ; [ satisfied? [ assume ] [ drop ] if ] 2bi ;
M: implication satisfiable? M: implication assume*
[ q>> satisfiable? ] [ p>> satisfiable? not ] bi or ; [ q>> ] [ p>> ] bi assume-implication ;
! Conjunction constraints ! Equivalence constraints
TUPLE: conjunction p q ; TUPLE: equivalence p q ;
C: /\ conjunction C: <--> equivalence
M: conjunction assume [ p>> assume ] [ q>> assume ] bi ; M: equivalence assume*
[ p>> ] [ q>> ] bi
[ assume-implication ]
[ swap assume-implication ] 2bi ;
M: conjunction satisfiable? ! Conjunction constraints -- sequences act as conjunctions
[ p>> satisfiable? ] [ q>> satisfiable? ] bi and ; M: sequence assume* [ assume ] each ;
! Disjunction constraints : /\ ( p q -- constraint ) 2array ;
TUPLE: disjunction p q ;
C: \/ disjunction
M: disjunction assume
{
{ [ dup p>> satisfiable? not ] [ q>> assume ] }
{ [ dup q>> satisfiable? not ] [ p>> assume ] }
[ drop ]
} cond ;
M: disjunction satisfiable?
[ p>> satisfiable? ] [ q>> satisfiable? ] bi or ;
! No-op
M: f assume drop ;
! Utilities ! Utilities
: t--> ( constraint boolean-value -- constraint' ) =t swap --> ; : t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
: f--> ( constraint boolean-value -- constraint' ) =f swap --> ; : f--> ( constraint boolean-value -- constraint' ) =f swap --> ;
: <conditional> ( true-constr false-constr boolean-value -- constraint ) : save-constraints ( quot -- )
tuck [ t--> ] [ f--> ] 2bi* /\ ; constraints get clone slip constraints set ; inline

4
unfinished/compiler/tree/propagation/info/info-tests.factor
View File

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

49
unfinished/compiler/tree/propagation/info/info.factor
View File

@ -27,6 +27,8 @@ literal?
length length
slots ; slots ;
: null-info T{ value-info f null empty-interval } ; inline
: class-interval ( class -- interval ) : class-interval ( class -- interval )
dup real class<= dup real class<=
[ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ; [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
@ -113,6 +115,8 @@ slots ;
DEFER: value-info-intersect DEFER: value-info-intersect
DEFER: (value-info-intersect)
: intersect-lengths ( info1 info2 -- length ) : intersect-lengths ( info1 info2 -- length )
[ length>> ] bi@ { [ length>> ] bi@ {
{ [ dup not ] [ drop ] } { [ dup not ] [ drop ] }
@ -120,10 +124,17 @@ DEFER: value-info-intersect
[ value-info-intersect ] [ value-info-intersect ]
} cond ; } cond ;
: intersect-slot ( info1 info2 -- info )
{
{ [ dup not ] [ nip ] }
{ [ over not ] [ drop ] }
[ (value-info-intersect) ]
} cond ;
: intersect-slots ( info1 info2 -- slots ) : intersect-slots ( info1 info2 -- slots )
[ slots>> ] bi@ [ slots>> ] bi@
2dup [ length ] bi@ = 2dup [ length ] bi@ =
[ [ value-info-intersect ] 2map ] [ 2drop f ] if ; [ [ intersect-slot ] 2map ] [ 2drop f ] if ;
: (value-info-intersect) ( info1 info2 -- info ) : (value-info-intersect) ( info1 info2 -- info )
[ <value-info> ] 2dip [ <value-info> ] 2dip
@ -150,6 +161,8 @@ DEFER: value-info-intersect
DEFER: value-info-union DEFER: value-info-union
DEFER: (value-info-union)
: union-lengths ( info1 info2 -- length ) : union-lengths ( info1 info2 -- length )
[ length>> ] bi@ { [ length>> ] bi@ {
{ [ dup not ] [ nip ] } { [ dup not ] [ nip ] }
@ -157,10 +170,17 @@ DEFER: value-info-union
[ value-info-union ] [ value-info-union ]
} cond ; } cond ;
: union-slot ( info1 info2 -- info )
{
{ [ dup not ] [ nip ] }
{ [ over not ] [ drop ] }
[ (value-info-union) ]
} cond ;
: union-slots ( info1 info2 -- slots ) : union-slots ( info1 info2 -- slots )
[ slots>> ] bi@ [ slots>> ] bi@
2dup [ length ] bi@ = 2dup [ length ] bi@ =
[ [ value-info-union ] 2map ] [ 2drop f ] if ; [ [ union-slot ] 2map ] [ 2drop f ] if ;
: (value-info-union) ( info1 info2 -- info ) : (value-info-union) ( info1 info2 -- info )
[ <value-info> ] 2dip [ <value-info> ] 2dip
@ -181,14 +201,15 @@ DEFER: value-info-union
} cond ; } cond ;
: value-infos-union ( infos -- info ) : value-infos-union ( infos -- info )
dup first [ value-info-union ] reduce ; dup empty?
[ drop null-info ]
[ dup first [ value-info-union ] reduce ] if ;
! Current value --> info mapping ! Current value --> info mapping
SYMBOL: value-infos SYMBOL: value-infos
: value-info ( value -- info ) : value-info ( value -- info )
resolve-copy value-infos get at resolve-copy value-infos get at null-info or ;
T{ value-info f null empty-interval } or ;
: set-value-info ( info value -- ) : set-value-info ( info value -- )
resolve-copy value-infos get set-at ; resolve-copy value-infos get set-at ;
@ -199,17 +220,27 @@ SYMBOL: value-infos
: value-literal ( value -- obj ? ) : value-literal ( value -- obj ? )
value-info >literal< ; value-info >literal< ;
: false-class? ( class -- ? ) \ f class<= ;
: true-class? ( class -- ? ) \ f class-not class<= ;
: possible-boolean-values ( info -- values ) : possible-boolean-values ( info -- values )
dup literal?>> [ dup literal?>> [
literal>> 1array literal>> 1array
] [ ] [
class>> { class>> {
{ [ dup null class<= ] [ { } ] } { [ dup null class<= ] [ { } ] }
{ [ dup \ f class-not class<= ] [ { t } ] } { [ dup true-class? ] [ { t } ] }
{ [ dup \ f class<= ] [ { f } ] } { [ dup false-class? ] [ { f } ] }
[ { t f } ] [ { t f } ]
} cond nip } cond nip
] if ; ] if ;
: value-is? ( value class -- ? ) : node-value-info ( node value -- info )
[ value-info class>> ] dip class<= ; 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 ;

3
unfinished/compiler/tree/propagation/inlining/inlining.factor Normal file
View File

@ -0,0 +1,3 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.propagation.inlining

19
unfinished/compiler/tree/propagation/known-words/known-words.factor
View File

@ -4,9 +4,10 @@ USING: kernel effects accessors math math.private math.libm
math.partial-dispatch math.intervals math.parser math.order math.partial-dispatch math.intervals math.parser math.order
layouts words sequences sequences.private arrays assocs classes layouts words sequences sequences.private arrays assocs classes
classes.algebra combinators generic.math splitting fry locals classes.algebra combinators generic.math splitting fry locals
classes.tuple alien.accessors classes.tuple.private classes.tuple alien.accessors classes.tuple.private slots.private
compiler.tree.propagation.info compiler.tree.propagation.nodes compiler.tree.propagation.info compiler.tree.propagation.nodes
compiler.tree.propagation.constraints compiler.tree.propagation.constraints
compiler.tree.propagation.slots
compiler.tree.comparisons ; compiler.tree.comparisons ;
IN: compiler.tree.propagation.known-words IN: compiler.tree.propagation.known-words
@ -148,12 +149,9 @@ most-negative-fixnum most-positive-fixnum [a,b]
/\ /\
] ; ] ;
: comparison-constraints ( in1 in2 out op -- constraint ) :: comparison-constraints ( in1 in2 out op -- constraint )
swap [ in1 in2 op (comparison-constraints) out t-->
[ (comparison-constraints) ] in1 in2 op negate-comparison (comparison-constraints) out f--> /\ ;
[ negate-comparison (comparison-constraints) ]
3bi
] dip <conditional> ;
: define-comparison-constraints ( word op -- ) : define-comparison-constraints ( word op -- )
'[ , comparison-constraints ] +constraints+ set-word-prop ; '[ , comparison-constraints ] +constraints+ set-word-prop ;
@ -203,7 +201,7 @@ generic-comparison-ops [
\ eq? [ \ eq? [
[ info-intervals-intersect? ] [ info-intervals-intersect? ]
[ info-classes-intersect? ] [ info-classes-intersect? ]
bi or maybe-or-never 2bi or maybe-or-never
] +outputs+ set-word-prop ] +outputs+ set-word-prop
{ {
@ -258,3 +256,8 @@ generic-comparison-ops [
! the output of clone has the same type as the input ! the output of clone has the same type as the input
{ clone (clone) } [ [ ] +outputs+ set-word-prop ] each { clone (clone) } [ [ ] +outputs+ set-word-prop ] each
\ slot [
dup literal?>>
[ literal>> swap value-info-slot ] [ 2drop object <class-info> ] if
] +outputs+ set-word-prop

6
unfinished/compiler/tree/propagation/nodes/nodes.factor
View File

@ -14,8 +14,4 @@ GENERIC: propagate-after ( node -- )
GENERIC: propagate-around ( node -- ) GENERIC: propagate-around ( node -- )
: (propagate) ( node -- ) : (propagate) ( node -- ) [ [ propagate-around ] each ] when* ;
[
[ propagate-around ] [ successor>> ] bi
(propagate)
] when* ;

129
unfinished/compiler/tree/propagation/propagation-tests.factor
View File

@ -1,10 +1,11 @@
USING: kernel compiler.tree.builder compiler.tree USING: kernel compiler.tree.builder compiler.tree
compiler.tree.propagation compiler.tree.copy-equiv compiler.tree.propagation compiler.tree.copy-equiv
compiler.tree.def-use tools.test math math.order compiler.tree.normalization tools.test math math.order
accessors sequences arrays kernel.private vectors accessors sequences arrays kernel.private vectors
alien.accessors alien.c-types sequences.private alien.accessors alien.c-types sequences.private
byte-arrays classes.algebra math.functions math.private byte-arrays classes.algebra classes.tuple.private
strings ; math.functions math.private strings layouts
compiler.tree.propagation.info ;
IN: compiler.tree.propagation.tests IN: compiler.tree.propagation.tests
\ propagate must-infer \ propagate must-infer
@ -12,10 +13,10 @@ IN: compiler.tree.propagation.tests
: final-info ( quot -- seq ) : final-info ( quot -- seq )
build-tree build-tree
compute-def-use normalize
compute-copy-equiv compute-copy-equiv
propagate propagate
last-node node-input-infos ; peek node-input-infos ;
: final-classes ( quot -- seq ) : final-classes ( quot -- seq )
final-info [ class>> ] map ; final-info [ class>> ] map ;
@ -128,6 +129,36 @@ IN: compiler.tree.propagation.tests
] final-literals ] final-literals
] unit-test ] unit-test
[ V{ string } ] [
[ dup string? not [ "Oops" throw ] [ ] if ] final-classes
] unit-test
[ V{ string } ] [
[ dup string? not not >boolean [ ] [ "Oops" throw ] if ] final-classes
] unit-test
[ V{ string } ] [
[ dup string? t xor [ "A" throw ] [ ] if ] final-classes
] unit-test
[ t ] [ [ t or ] final-classes first true-class? ] unit-test
[ t ] [ [ t swap or ] final-classes first true-class? ] unit-test
[ t ] [ [ f and ] final-classes first false-class? ] unit-test
[ t ] [ [ f swap and ] final-classes first false-class? ] unit-test
[ t ] [ [ dup not or ] final-classes first true-class? ] unit-test
[ t ] [ [ dup not swap or ] final-classes first true-class? ] unit-test
[ t ] [ [ dup not and ] final-classes first false-class? ] unit-test
[ t ] [ [ dup not swap and ] final-classes first false-class? ] unit-test
[ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
[ V{ fixnum } ] [ [ V{ fixnum } ] [
[ [
>fixnum >fixnum
@ -235,12 +266,45 @@ IN: compiler.tree.propagation.tests
[ [ 1 ] [ 1 ] if 1 + ] final-literals [ [ 1 ] [ 1 ] if 1 + ] final-literals
] unit-test ] unit-test
[ V{ object } ] [
[ 0 * 10 < ] final-classes
] unit-test
[ V{ 27 } ] [
[
123 bitand dup 10 < over 8 > and [ 3 * ] [ "B" throw ] if
] final-literals
] unit-test
[ V{ string string } ] [ [ V{ string string } ] [
[ [
2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop 2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
] final-classes ] final-classes
] unit-test ] unit-test
[ V{ float } ] [
[ { real float } declare + ] final-classes
] unit-test
[ V{ float } ] [
[ { float real } declare + ] final-classes
] unit-test
[ V{ fixnum } ] [
[ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
] unit-test
[ V{ fixnum } ] [
[ { fixnum } declare 1 swap 7 bitand shift ] final-classes
] unit-test
cell-bits 32 = [
[ V{ integer } ] [
[ { fixnum } declare 1 swap 31 bitand shift ]
final-classes
] unit-test
] when
! Array length propagation ! Array length propagation
[ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test [ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
@ -323,6 +387,10 @@ TUPLE: mutable-tuple-test { x sequence } ;
[ T{ mutable-tuple-test f "hey" } x>> ] final-classes [ T{ mutable-tuple-test f "hey" } x>> ] final-classes
] unit-test ] unit-test
[ V{ tuple-layout } ] [
[ T{ mutable-tuple-test f "hey" } layout-of ] final-classes
] unit-test
! Mixed mutable and immutable slots ! Mixed mutable and immutable slots
TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
@ -332,3 +400,54 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
[ x>> ] [ y>> ] bi [ x>> ] [ y>> ] bi
] final-classes ] final-classes
] unit-test ] unit-test
! Recursive propagation
: recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
[ V{ null } ] [ [ recursive-test-1 ] final-classes ] unit-test
: recursive-test-2 ( a -- b ) dup 10 < [ recursive-test-2 ] when ; inline recursive
[ V{ real } ] [ [ recursive-test-2 ] final-classes ] unit-test
: recursive-test-3 ( a -- b ) dup 10 < drop ; inline recursive
[ V{ real } ] [ [ recursive-test-3 ] final-classes ] unit-test
[ V{ real } ] [ [ [ dup 10 < ] [ ] [ ] while ] final-classes ] unit-test
[ V{ float } ] [
[ { float } declare 10 [ 2.3 * ] times ] final-classes
] unit-test
[ V{ fixnum } ] [
[ 0 10 [ nip ] each-integer ] final-classes
] unit-test
[ V{ t } ] [
[ t 10 [ nip 0 >= ] each-integer ] final-literals
] unit-test
: recursive-test-4 ( i n -- )
2dup < [ >r 1+ r> recursive-test-4 ] [ 2drop ] if ; inline recursive
[ ] [ [ recursive-test-4 ] final-info drop ] unit-test
: recursive-test-5 ( a -- b )
dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-5 * ] if ; inline recursive
[ V{ integer } ] [ [ { integer } declare recursive-test-5 ] final-classes ] unit-test
: recursive-test-6 ( a -- b )
dup 1 <= [ drop 1 ] [ dup 1 - recursive-test-6 swap 2 - recursive-test-6 + ] if ; inline recursive
[ V{ integer } ] [ [ { fixnum } declare recursive-test-6 ] final-classes ] unit-test
: recursive-test-7 ( a -- b )
dup 10 < [ 1+ recursive-test-7 ] when ; inline recursive
[ V{ fixnum } ] [ [ 0 recursive-test-7 ] final-classes ] unit-test
[ V{ fixnum } ] [ [ 1 10 [ dup 10 < [ 2 * ] when ] times ] final-classes ] unit-test
[ V{ integer } ] [ [ 0 2 100 ^ [ nip ] each-integer ] final-classes ] unit-test

82
unfinished/compiler/tree/propagation/recursive/recursive.factor
View File

@ -1,36 +1,78 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors USING: kernel sequences accessors arrays fry math.intervals
combinators
stack-checker.inlining
compiler.tree compiler.tree
compiler.tree.propagation.info compiler.tree.propagation.info
compiler.tree.propagation.nodes compiler.tree.propagation.nodes
compiler.tree.propagation.simple compiler.tree.propagation.simple
compiler.tree.propagation.branches ; compiler.tree.propagation.branches
compiler.tree.propagation.constraints ;
IN: compiler.tree.propagation.recursive IN: compiler.tree.propagation.recursive
! What if we reach a fixed point for the phi but not for the : check-fixed-point ( node infos1 infos2 -- node )
! #call-label output? sequence= [ dup label>> f >>fixed-point drop ] unless ; inline
! We need to compute scalar evolution so that sccp doesn't : recursive-stacks ( #enter-recursive -- stacks initial )
! evaluate loops [ label>> calls>> [ node-input-infos ] map flip ]
[ in-d>> [ value-info ] map ] bi ;
: (merge-value-infos) ( inputs -- infos ) : generalize-counter-interval ( interval initial-interval -- interval' )
[ [ value-info ] map value-infos-union ] map ; {
{ [ 2dup = ] [ empty-interval ] }
{ [ over empty-interval eq? ] [ empty-interval ] }
{ [ 2dup interval>= t eq? ] [ 1./0. [a,a] ] }
{ [ 2dup interval<= t eq? ] [ -1./0. [a,a] ] }
[ [-inf,inf] ]
} cond nip interval-union ;
: merge-value-infos ( inputs outputs -- fixed-point? ) : generalize-counter ( info' initial -- info )
[ (merge-value-infos) ] dip [ drop clone ] [ [ interval>> ] bi@ ] 2bi
[ 2dup value-info = [ 2drop t ] [ set-value-info f ] if ] 2all? ; generalize-counter-interval >>interval ;
: propagate-recursive-phi ( #phi -- fixed-point? ) : unify-recursive-stacks ( stacks initial -- infos )
[ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ] over empty? [ nip ] [
[ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ] [
bi and ; [ sift value-infos-union ] dip
[ generalize-counter ] keep
value-info-union
] 2map
] if ;
: propagate-recursive-phi ( #enter-recursive -- )
[ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri
[ node-output-infos check-fixed-point drop ] 2keep
out-d>> set-value-infos ;
USING: namespaces math ;
SYMBOL: iter-counter
0 iter-counter set-global
M: #recursive propagate-around ( #recursive -- ) M: #recursive propagate-around ( #recursive -- )
dup iter-counter inc
node-child iter-counter get 10 > [ "Oops" throw ] when
[ first>> (propagate) ] [ propagate-recursive-phi ] bi dup label>> t >>fixed-point drop [
[ drop ] [ propagate-around ] if ; [
child>>
[ first propagate-recursive-phi ]
[ (propagate) ]
bi
] save-constraints
] [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] bi ;
: generalize-return-interval ( info -- info' )
dup literal?>> [
clone [-inf,inf] >>interval
] unless ;
: generalize-return ( infos -- infos' )
[ generalize-return-interval ] map ;
M: #call-recursive propagate-before ( #call-label -- ) M: #call-recursive propagate-before ( #call-label -- )
[ label>> returns>> flip ] [ out-d>> ] bi merge-value-infos drop ; dup [ node-output-infos ] [ label>> return>> node-input-infos ] bi
[ check-fixed-point ] keep
generalize-return swap out-d>> set-value-infos ;
M: #return-recursive propagate-before ( #return-recursive -- )
dup [ node-input-infos ] [ in-d>> [ value-info ] map ] bi
check-fixed-point drop ;

9
unfinished/compiler/tree/propagation/simple/simple.factor
View File

@ -13,10 +13,10 @@ compiler.tree.propagation.constraints ;
IN: compiler.tree.propagation.simple IN: compiler.tree.propagation.simple
M: #introduce propagate-before M: #introduce propagate-before
object <class-info> swap values>> [ set-value-info ] with each ; value>> object <class-info> swap set-value-info ;
M: #push propagate-before M: #push propagate-before
[ literal>> value>> <literal-info> ] [ out-d>> first ] bi [ literal>> <literal-info> ] [ out-d>> first ] bi
set-value-info ; set-value-info ;
: refine-value-infos ( classes values -- ) : refine-value-infos ( classes values -- )
@ -117,10 +117,13 @@ M: #call propagate-after
M: node propagate-after drop ; M: node propagate-after drop ;
: extract-value-info ( values -- assoc )
[ dup value-info ] H{ } map>assoc ;
: annotate-node ( node -- ) : annotate-node ( node -- )
dup dup
[ node-defs-values ] [ node-uses-values ] bi append [ node-defs-values ] [ node-uses-values ] bi append
[ dup value-info ] H{ } map>assoc extract-value-info
>>info drop ; >>info drop ;
M: node propagate-around M: node propagate-around

51
unfinished/compiler/tree/propagation/slots/slots.factor
View File

@ -29,7 +29,7 @@ UNION: fixed-length-sequence array byte-array string ;
bi value-info-intersect 1array ; bi value-info-intersect 1array ;
: length-accessor? ( node -- ? ) : length-accessor? ( node -- ? )
dup in-d>> first fixed-length-sequence value-is? dup in-d>> first value-info class>> fixed-length-sequence class<=
[ word>> \ length eq? ] [ drop f ] if ; [ word>> \ length eq? ] [ drop f ] if ;
: propagate-length ( node -- infos ) : propagate-length ( node -- infos )
@ -39,15 +39,25 @@ UNION: fixed-length-sequence array byte-array string ;
: tuple-constructor? ( node -- ? ) : tuple-constructor? ( node -- ? )
word>> { <tuple-boa> <complex> } memq? ; word>> { <tuple-boa> <complex> } memq? ;
: read-only-slots ( values class -- slots )
#! Delegation.
all-slots rest-slice
[ read-only>> [ drop f ] unless ] 2map
{ f f } prepend ;
: fold-<tuple-boa> ( values class -- info )
[ , f , [ literal>> ] map % ] { } make >tuple
<literal-info> ;
: propagate-<tuple-boa> ( node -- info ) : propagate-<tuple-boa> ( node -- info )
#! Delegation #! Delegation
in-d>> [ value-info ] map unclip-last in-d>> [ value-info ] map unclip-last
literal>> class>> dup immutable-tuple-class? [ literal>> class>> [ read-only-slots ] keep
over [ literal?>> ] all? over 2 tail-slice [ dup [ literal?>> ] when ] all? [
[ [ , f , [ literal>> ] map % ] { } make >tuple <literal-info> ] [ 2 tail-slice ] dip fold-<tuple-boa>
[ <tuple-info> ] ] [
if <tuple-info>
] [ nip <class-info> ] if ; ] if ;
: propagate-<complex> ( node -- info ) : propagate-<complex> ( node -- info )
in-d>> [ value-info ] map complex <tuple-info> ; in-d>> [ value-info ] map complex <tuple-info> ;
@ -67,7 +77,7 @@ UNION: fixed-length-sequence array byte-array string ;
relevant-methods [ nip "reading" word-prop ] { } assoc>map ; relevant-methods [ nip "reading" word-prop ] { } assoc>map ;
: no-reader-methods ( input slots -- info ) : no-reader-methods ( input slots -- info )
2drop null <class-info> ; 2drop null-info ;
: same-offset ( slots -- slot/f ) : same-offset ( slots -- slot/f )
dup [ dup [ read-only>> ] when ] all? [ dup [ dup [ read-only>> ] when ] all? [
@ -79,20 +89,29 @@ UNION: fixed-length-sequence array byte-array string ;
[ [ class>> ] [ object ] if* class-or ] reduce [ [ class>> ] [ object ] if* class-or ] reduce
<class-info> ; <class-info> ;
: value-info-slot ( slot info -- info' ) : tuple>array* ( tuple -- array )
#! Delegation. prepare-tuple>array
[ class>> complex class<= 1 3 ? - ] keep >r copy-tuple-slots r>
dup literal?>> [ prefix ;
literal>> {
: literal-info-slot ( slot info -- info' )
{
{ [ dup tuple? ] [ { [ dup tuple? ] [
tuple-slots 1 tail-slice nth <literal-info> tuple>array* nth <literal-info>
] } ] }
{ [ dup complex? ] [ { [ dup complex? ] [
[ real-part ] [ imaginary-part ] bi [ real-part ] [ imaginary-part ] bi
2array nth <literal-info> 2array nth <literal-info>
] } ] }
} cond } cond ;
] [ slots>> ?nth ] if ;
: value-info-slot ( slot info -- info' )
#! Delegation.
{
{ [ over 0 = ] [ 2drop fixnum <class-info> ] }
{ [ dup literal?>> ] [ [ 1- ] [ literal>> ] bi* literal-info-slot ] }
[ [ 1- ] [ slots>> ] bi* ?nth ]
} cond ;
: reader-word-outputs ( node -- infos ) : reader-word-outputs ( node -- infos )
[ relevant-slots ] [ in-d>> first ] bi [ relevant-slots ] [ in-d>> first ] bi

5
unfinished/compiler/tree/strength-reduction/strength-reduction.factor Normal file
View File

@ -0,0 +1,5 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.strength-reduction
: strength-reduce ( nodes -- nodes' ) ;

148
unfinished/compiler/tree/tree.factor
View File

@ -6,50 +6,17 @@ accessors combinators stack-checker.state stack-checker.visitor ;
IN: compiler.tree IN: compiler.tree
! High-level tree SSA form. ! High-level tree SSA form.
!
! Invariants: TUPLE: node < identity-tuple info ;
! 1) Each value has exactly one definition. A "definition" means
! the value appears in the out-d or out-r slot of a node, or the
! values slot of an #introduce node.
! 2) Each value appears only once in the inputs of a node, where
! the inputs are the concatenation of in-d and in-r, or in the
! case of a #phi node, the sequence of sequences in the phi-in-r
! and phi-in-d slots.
! 3) A value is never used in the same node where it is defined.
TUPLE: node < identity-tuple
in-d out-d in-r out-r info
successor children ;
M: node hashcode* drop node hashcode* ; M: node hashcode* drop node hashcode* ;
: node-child ( node -- child ) children>> first ; TUPLE: #introduce < node value ;
: last-node ( node -- last ) : #introduce ( value -- node )
dup successor>> [ last-node ] [ ] ?if ; \ #introduce new swap >>value ;
: penultimate-node ( node -- penultimate ) TUPLE: #call < node word history in-d out-d ;
dup successor>> dup [
dup successor>>
[ nip penultimate-node ] [ drop ] if
] [
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 )
\ #introduce new swap >>values ;
TUPLE: #call < node word history ;
: #call ( inputs outputs word -- node ) : #call ( inputs outputs word -- node )
\ #call new \ #call new
@ -57,7 +24,7 @@ TUPLE: #call < node word history ;
swap >>out-d swap >>out-d
swap >>in-d ; swap >>in-d ;
TUPLE: #call-recursive < node label ; TUPLE: #call-recursive < node label in-d out-d ;
: #call-recursive ( inputs outputs label -- node ) : #call-recursive ( inputs outputs label -- node )
\ #call-recursive new \ #call-recursive new
@ -65,14 +32,14 @@ TUPLE: #call-recursive < node label ;
swap >>out-d swap >>out-d
swap >>in-d ; swap >>in-d ;
TUPLE: #push < node literal ; TUPLE: #push < node literal out-d ;
: #push ( literal value -- node ) : #push ( literal value -- node )
\ #push new \ #push new
swap 1array >>out-d swap 1array >>out-d
swap >>literal ; swap >>literal ;
TUPLE: #shuffle < node mapping ; TUPLE: #shuffle < node mapping in-d out-d ;
: #shuffle ( inputs outputs mapping -- node ) : #shuffle ( inputs outputs mapping -- node )
\ #shuffle new \ #shuffle new
@ -83,25 +50,27 @@ TUPLE: #shuffle < node mapping ;
: #drop ( inputs -- node ) : #drop ( inputs -- node )
{ } { } #shuffle ; { } { } #shuffle ;
TUPLE: #>r < node ; TUPLE: #>r < node in-d out-r ;
: #>r ( inputs outputs -- node ) : #>r ( inputs outputs -- node )
\ #>r new \ #>r new
swap >>out-r swap >>out-r
swap >>in-d ; swap >>in-d ;
TUPLE: #r> < node ; TUPLE: #r> < node in-r out-d ;
: #r> ( inputs outputs -- node ) : #r> ( inputs outputs -- node )
\ #r> new \ #r> new
swap >>out-d swap >>out-d
swap >>in-r ; swap >>in-r ;
TUPLE: #terminate < node ; TUPLE: #terminate < node in-d ;
: #terminate ( -- node ) \ #terminate new ; : #terminate ( stack -- node )
\ #terminate new
swap >>in-d ;
TUPLE: #branch < node ; TUPLE: #branch < node in-d children ;
: new-branch ( value children class -- node ) : new-branch ( value children class -- node )
new new
@ -118,7 +87,7 @@ TUPLE: #dispatch < #branch ;
: #dispatch ( n branches -- node ) : #dispatch ( n branches -- node )
\ #dispatch new-branch ; \ #dispatch new-branch ;
TUPLE: #phi < node phi-in-d phi-in-r ; TUPLE: #phi < node phi-in-d phi-info-d phi-in-r phi-info-r out-d out-r ;
: #phi ( d-phi-in d-phi-out r-phi-in r-phi-out -- node ) : #phi ( d-phi-in d-phi-out r-phi-in r-phi-out -- node )
\ #phi new \ #phi new
@ -133,59 +102,62 @@ TUPLE: #declare < node declaration ;
\ #declare new \ #declare new
swap >>declaration ; swap >>declaration ;
TUPLE: #return < node label ; TUPLE: #return < node in-d ;
: #return ( label stack -- node ) : #return ( stack -- node )
\ #return new \ #return new
swap >>in-d swap >>in-d ;
swap >>label ;
TUPLE: #recursive < node word label loop? returns calls ; TUPLE: #recursive < node in-d word label loop? returns calls child ;
: #recursive ( word label inputs outputs child -- node ) : #recursive ( word label inputs child -- node )
\ #recursive new \ #recursive new
swap 1array >>children swap >>child
swap >>out-d
swap >>in-d swap >>in-d
swap >>label swap >>label
swap >>word ; swap >>word ;
TUPLE: #copy < node ; TUPLE: #enter-recursive < node in-d out-d label ;
: #enter-recursive ( label inputs outputs -- node )
\ #enter-recursive new
swap >>out-d
swap >>in-d
swap >>label ;
TUPLE: #return-recursive < node in-d out-d label ;
: #return-recursive ( label inputs outputs -- node )
\ #return-recursive new
swap >>out-d
swap >>in-d
swap >>label ;
TUPLE: #copy < node in-d out-d ;
: #copy ( inputs outputs -- node ) : #copy ( inputs outputs -- node )
\ #copy new \ #copy new
swap >>out-d swap >>out-d
swap >>in-d ; swap >>in-d ;
DEFER: #tail? : node, ( node -- ) stack-visitor get push ;
PREDICATE: #tail-phi < #phi successor>> #tail? ; M: vector child-visitor V{ } clone ;
M: vector #introduce, #introduce node, ;
UNION: #tail POSTPONE: f #return #tail-phi #terminate ; M: vector #call, #call node, ;
M: vector #push, #push node, ;
TUPLE: node-list first last ; M: vector #shuffle, #shuffle node, ;
M: vector #drop, #drop node, ;
: node, ( node -- ) M: vector #>r, #>r node, ;
stack-visitor get swap M: vector #r>, #r> node, ;
over last>> M: vector #return, #return node, ;
[ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ] M: vector #enter-recursive, #enter-recursive node, ;
[ [ >>first ] [ >>last ] bi drop ] M: vector #return-recursive, #return-recursive node, ;
if ; M: vector #call-recursive, #call-recursive node, ;
M: vector #terminate, #terminate node, ;
M: node-list child-visitor node-list new ; M: vector #if, #if node, ;
M: node-list #introduce, #introduce node, ; M: vector #dispatch, #dispatch node, ;
M: node-list #call, #call node, ; M: vector #phi, #phi node, ;
M: node-list #call-recursive, #call-recursive node, ; M: vector #declare, #declare node, ;
M: node-list #push, #push node, ; M: vector #recursive, #recursive node, ;
M: node-list #shuffle, #shuffle node, ; M: vector #copy, #copy 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 #terminate, #terminate node, ;
M: node-list #if, #if node, ;
M: node-list #dispatch, #dispatch node, ;
M: node-list #phi, #phi node, ;
M: node-list #declare, #declare node, ;
M: node-list #recursive, #recursive node, ;
M: node-list #copy, #copy node, ;

6
unfinished/compiler/tree/untupling/untupling.factor
View File

@ -3,7 +3,8 @@
USING: accessors slots.private kernel namespaces disjoint-sets USING: accessors slots.private kernel namespaces disjoint-sets
math sequences assocs classes.tuple.private combinators fry sets math sequences assocs classes.tuple.private combinators fry sets
compiler.tree compiler.tree.combinators compiler.tree.copy-equiv compiler.tree compiler.tree.combinators compiler.tree.copy-equiv
compiler.tree.dfa compiler.tree.dfa.backward ; compiler.tree.dataflow-analysis
compiler.tree.dataflow-analysis.backward ;
IN: compiler.tree.untupling IN: compiler.tree.untupling
SYMBOL: escaping-values SYMBOL: escaping-values
@ -29,8 +30,7 @@ M: #call compute-untupling*
[ drop mark-escaping-values ] [ drop mark-escaping-values ]
} case ; } case ;
M: #return compute-untupling* M: #return compute-untupling* mark-escaping-values ;
dup label>> [ drop ] [ mark-escaping-values ] if ;
M: node compute-untupling* drop ; M: node compute-untupling* drop ;

17
unfinished/stack-checker/backend/backend.factor
View File

@ -41,7 +41,7 @@ SYMBOL: visited
: pop-d ( -- obj ) : pop-d ( -- obj )
meta-d get dup empty? [ meta-d get dup empty? [
drop <value> dup 1array #introduce, d-in inc drop <value> dup #introduce, d-in inc
] [ pop ] if ; ] [ pop ] if ;
: peek-d ( -- obj ) pop-d dup push-d ; : peek-d ( -- obj ) pop-d dup push-d ;
@ -52,8 +52,11 @@ SYMBOL: visited
: ensure-d ( n -- values ) consume-d dup output-d ; : ensure-d ( n -- values ) consume-d dup output-d ;
: make-values ( n -- values )
[ <value> ] replicate ;
: produce-d ( n -- values ) : produce-d ( n -- values )
[ <value> ] replicate dup meta-d get push-all ; make-values dup meta-d get push-all ;
: push-r ( obj -- ) meta-r get push ; : push-r ( obj -- ) meta-r get push ;
@ -71,7 +74,7 @@ SYMBOL: visited
GENERIC: apply-object ( obj -- ) GENERIC: apply-object ( obj -- )
: push-literal ( obj -- ) : push-literal ( obj -- )
<literal> dup make-known [ nip push-d ] [ #push, ] 2bi ; dup <literal> make-known [ nip push-d ] [ #push, ] 2bi ;
M: wrapper apply-object M: wrapper apply-object
wrapped>> wrapped>>
@ -82,7 +85,7 @@ M: wrapper apply-object
M: object apply-object push-literal ; M: object apply-object push-literal ;
: terminate ( -- ) : terminate ( -- )
terminated? on #terminate, ; terminated? on meta-d get clone #terminate, ;
: infer-quot ( quot rstate -- ) : infer-quot ( quot rstate -- )
recursive-state get [ recursive-state get [
@ -113,10 +116,10 @@ M: object apply-object push-literal ;
] if ; ] if ;
: infer->r ( n -- ) : infer->r ( n -- )
consume-d [ dup copy-values #>r, ] [ output-r ] bi ; consume-d dup copy-values [ #>r, ] [ nip output-r ] 2bi ;
: infer-r> ( n -- ) : infer-r> ( n -- )
consume-r [ dup copy-values #r>, ] [ output-d ] bi ; consume-r dup copy-values [ #r>, ] [ nip output-d ] 2bi ;
: undo-infer ( -- ) : undo-infer ( -- )
recorded get [ f +inferred-effect+ set-word-prop ] each ; recorded get [ f +inferred-effect+ set-word-prop ] each ;
@ -140,7 +143,7 @@ M: object apply-object push-literal ;
: end-infer ( -- ) : end-infer ( -- )
check->r check->r
f meta-d get clone #return, ; meta-d get clone #return, ;
: effect-required? ( word -- ? ) : effect-required? ( word -- ? )
{ {

39
unfinished/stack-checker/inlining/inlining.factor
View File

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

6
unfinished/stack-checker/transforms/transforms.factor
View File

@ -4,7 +4,8 @@ USING: fry accessors arrays kernel words sequences generic math
namespaces quotations assocs combinators classes.tuple namespaces quotations assocs combinators classes.tuple
classes.tuple.private effects summary hashtables classes generic classes.tuple.private effects summary hashtables classes generic
sets definitions generic.standard slots.private continuations sets definitions generic.standard slots.private continuations
stack-checker.backend stack-checker.state stack-checker.errors ; stack-checker.backend stack-checker.state stack-checker.visitor
stack-checker.errors ;
IN: stack-checker.transforms IN: stack-checker.transforms
SYMBOL: +transform-quot+ SYMBOL: +transform-quot+
@ -15,8 +16,9 @@ SYMBOL: +transform-n+
drop recursive-state get 1array drop recursive-state get 1array
] [ ] [
consume-d consume-d
[ #drop, ]
[ [ literal value>> ] map ] [ [ literal value>> ] map ]
[ first literal recursion>> ] bi prefix [ first literal recursion>> ] tri prefix
] if ] if
swap with-datastack ; swap with-datastack ;

8
unfinished/stack-checker/visitor/dummy/dummy.factor
View File

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

10
unfinished/stack-checker/visitor/visitor.factor
View File

@ -9,7 +9,7 @@ HOOK: child-visitor stack-visitor ( -- visitor )
: nest-visitor ( -- ) child-visitor stack-visitor set ; : nest-visitor ( -- ) child-visitor stack-visitor set ;
HOOK: #introduce, stack-visitor ( values -- ) HOOK: #introduce, stack-visitor ( value -- )
HOOK: #call, stack-visitor ( inputs outputs word -- ) HOOK: #call, stack-visitor ( inputs outputs word -- )
HOOK: #call-recursive, stack-visitor ( inputs outputs word -- ) HOOK: #call-recursive, stack-visitor ( inputs outputs word -- )
HOOK: #push, stack-visitor ( literal value -- ) HOOK: #push, stack-visitor ( literal value -- )
@ -17,11 +17,13 @@ HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- )
HOOK: #drop, stack-visitor ( values -- ) HOOK: #drop, stack-visitor ( values -- )
HOOK: #>r, stack-visitor ( inputs outputs -- ) HOOK: #>r, stack-visitor ( inputs outputs -- )
HOOK: #r>, stack-visitor ( inputs outputs -- ) HOOK: #r>, stack-visitor ( inputs outputs -- )
HOOK: #terminate, stack-visitor ( -- ) HOOK: #terminate, stack-visitor ( stack -- )
HOOK: #if, stack-visitor ( ? true false -- ) HOOK: #if, stack-visitor ( ? true false -- )
HOOK: #dispatch, stack-visitor ( n branches -- ) HOOK: #dispatch, stack-visitor ( n branches -- )
HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- ) HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
HOOK: #declare, stack-visitor ( declaration -- ) HOOK: #declare, stack-visitor ( declaration -- )
HOOK: #return, stack-visitor ( label stack -- ) HOOK: #return, stack-visitor ( stack -- )
HOOK: #recursive, stack-visitor ( word label inputs outputs visitor -- ) HOOK: #enter-recursive, stack-visitor ( label inputs outputs -- )
HOOK: #return-recursive, stack-visitor ( label inputs outputs -- )
HOOK: #recursive, stack-visitor ( word label inputs visitor -- )
HOOK: #copy, stack-visitor ( inputs outputs -- ) HOOK: #copy, stack-visitor ( inputs outputs -- )