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

Conflicts:
	basis/unix/statfs/netbsd/netbsd.factor

basis/alien/parser/parser.factor

@@ -0,0 +1,19 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types arrays assocs effects grouping kernel
+parser sequences splitting words fry locals ;
+IN: alien.parser
+
+: parse-arglist ( parameters return -- types effect )
+    [ 2 group unzip [ "," ?tail drop ] map ]
+    [ [ { } ] [ 1array ] if-void ]
+    bi* <effect> ;
+
+: function-quot ( return library function types -- quot )
+    '[ _ _ _ _ alien-invoke ] ;
+
+:: define-function ( return library function parameters -- )
+    function create-in dup reset-generic
+    return library function
+    parameters return parse-arglist [ function-quot ] dip
+    define-declared ;

basis/alien/structs/fields/fields.factor

@@ -52,25 +52,21 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
         [ (>>offset) ] [ type>> heap-size + ] 2bi
     ] reduce ;
 
-: define-struct-slot-word ( spec word quot -- )
+: define-struct-slot-word ( word quot spec -- )
-    rot offset>> prefix define-inline ;
+    offset>> prefix define-inline ;
 
 : define-getter ( type spec -- )
     [ set-reader-props ] keep
-    [ ]
     [ reader>> ]
     [
         type>>
         [ c-getter ] [ c-type-boxer-quot ] bi append
-    ] tri
+    ]
-    define-struct-slot-word ;
+    [ ] tri define-struct-slot-word ;
 
 : define-setter ( type spec -- )
     [ set-writer-props ] keep
-    [ ]
+    [ writer>> ] [ type>> c-setter ] [ ] tri define-struct-slot-word ;
-    [ writer>> ]
-    [ type>> c-setter ] tri
-    define-struct-slot-word ;
 
 : define-field ( type spec -- )
     [ define-getter ] [ define-setter ] 2bi ;

basis/alien/syntax/syntax-docs.factor

@@ -1,5 +1,5 @@
 IN: alien.syntax
-USING: alien alien.c-types alien.structs alien.syntax.private
+USING: alien alien.c-types alien.parser alien.structs
 help.markup help.syntax ;
 
 HELP: DLL"
@@ -54,12 +54,6 @@ HELP: TYPEDEF:
 { $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
 { $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
 
-HELP: TYPEDEF-IF:
-{ $syntax "TYPEDEF-IF: word old new" }
-{ $values { "word" "a word with stack effect " { $snippet "( -- ? )" } } { "old" "a C type" } { "new" "a C type" } }
-{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if " { $snippet "word" } " evaluates to a true value." }
-{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
-
 HELP: C-STRUCT:
 { $syntax "C-STRUCT: name pairs... ;" }
 { $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
@@ -88,7 +82,7 @@ HELP: typedef
 { $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
 { $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ;
 
-{ POSTPONE: TYPEDEF-IF: POSTPONE: TYPEDEF: typedef } related-words
+{ POSTPONE: TYPEDEF: typedef } related-words
 
 HELP: c-struct?
 { $values { "type" "a string" } { "?" "a boolean" } }

basis/alien/syntax/syntax.factor

@@ -4,26 +4,9 @@ USING: accessors arrays alien alien.c-types alien.structs
 alien.arrays alien.strings kernel math namespaces parser
 sequences words quotations math.parser splitting grouping
 effects prettyprint prettyprint.sections prettyprint.backend
-assocs combinators lexer strings.parser ;
+assocs combinators lexer strings.parser alien.parser ;
 IN: alien.syntax
 
-<PRIVATE
-
-: parse-arglist ( return seq -- types effect )
-    2 group dup keys swap values [ "," ?tail drop ] map
-    rot dup "void" = [ drop { } ] [ 1array ] if <effect> ;
-
-: function-quot ( type lib func types -- quot )
-    [ alien-invoke ] 2curry 2curry ;
-
-: define-function ( return library function parameters -- )
-    [ pick ] dip parse-arglist
-    pick create-in dup reset-generic
-    [ function-quot ] 2dip
-    -rot define-declared ;
-
-PRIVATE>
-
 : DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
 
 : ALIEN: scan string>number <alien> parsed ; parsing
@@ -40,9 +23,6 @@ PRIVATE>
 : TYPEDEF:
     scan scan typedef ; parsing
 
-: TYPEDEF-IF:
-    scan-word execute scan scan rot [ typedef ] [ 2drop ] if ; parsing
-
 : C-STRUCT:
     scan in get
     parse-definition

basis/cocoa/pasteboard/pasteboard.factor

@@ -20,7 +20,7 @@ IN: cocoa.pasteboard
 : set-pasteboard-string ( str pasteboard -- )
     NSStringPboardType <NSString>
     dup 1array pick set-pasteboard-types
-    >r swap <NSString> r> -> setString:forType: drop ;
+    [ swap <NSString> ] dip -> setString:forType: drop ;
 
 : pasteboard-error ( error -- f )
     "Pasteboard does not hold a string" <NSString>

basis/cocoa/subclassing/subclassing.factor

@@ -36,7 +36,7 @@ IN: cocoa.subclassing
     ] map concat ;
 
 : prepare-method ( ret types quot -- type imp )
-    >r [ encode-types ] 2keep r> [
+    [ [ encode-types ] 2keep ] dip [
         "cdecl" swap 4array % \ alien-callback ,
     ] [ ] make define-temp ;
 

basis/cocoa/views/views.factor

@@ -74,7 +74,7 @@ PRIVATE>
     -> autorelease ;
 
 : <GLView> ( class dim -- view )
-    >r -> alloc 0 0 r> first2 <NSRect> <PixelFormat>
+    [ -> alloc 0 0 ] dip first2 <NSRect> <PixelFormat>
     -> initWithFrame:pixelFormat:
     dup 1 -> setPostsBoundsChangedNotifications:
     dup 1 -> setPostsFrameChangedNotifications: ;
@@ -85,10 +85,11 @@ PRIVATE>
     swap NSRect-h >fixnum 2array ;
 
 : mouse-location ( view event -- loc )
-    over >r
+    [
-    -> locationInWindow f -> convertPoint:fromView:
+        -> locationInWindow f -> convertPoint:fromView:
-    dup NSPoint-x swap NSPoint-y
+        [ NSPoint-x ] [ NSPoint-y ] bi
-    r> -> frame NSRect-h swap - 2array ;
+    ] [ drop -> frame NSRect-h ] 2bi
+    swap - 2array ;
 
 USE: opengl.gl
 USE: alien.syntax

basis/compiler/alien/alien.factor

@@ -18,7 +18,7 @@ IN: compiler.alien
     dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
 
 : parameter-align ( n type -- n delta )
-    over >r c-type-stack-align align dup r> - ;
+    [ c-type-stack-align align dup ] [ drop ] 2bi - ;
 
 : parameter-sizes ( types -- total offsets )
     #! Compute stack frame locations.

basis/compiler/codegen/codegen.factor

@@ -277,7 +277,7 @@ M: object reg-class-full?
 
 : spill-param ( reg-class -- n reg-class )
     stack-params get
-    >r reg-size cell align stack-params +@ r>
+    [ reg-size cell align stack-params +@ ] dip
     stack-params ;
 
 : fastcall-param ( reg-class -- n reg-class )
@@ -313,10 +313,10 @@ M: long-long-type flatten-value-type ( type -- types )
     ] { } make ;
 
 : each-parameter ( parameters quot -- )
-    >r [ parameter-sizes nip ] keep r> 2each ; inline
+    [ [ parameter-sizes nip ] keep ] dip 2each ; inline
 
 : reverse-each-parameter ( parameters quot -- )
-    >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
+    [ [ parameter-sizes nip ] keep ] dip 2reverse-each ; inline
 
 : reset-freg-counts ( -- )
     { int-regs float-regs stack-params } [ 0 swap set ] each ;
@@ -329,15 +329,13 @@ M: long-long-type flatten-value-type ( type -- types )
     #! Moves values from C stack to registers (if word is
     #! %load-param-reg) and registers to C stack (if word is
     #! %save-param-reg).
-    >r
+    [ alien-parameters flatten-value-types ]
-    alien-parameters
+    [ '[ alloc-parameter _ execute ] ]
-    flatten-value-types
+    bi* each-parameter ; inline
-    r> '[ alloc-parameter _ execute ] each-parameter ;
-    inline
 
 : unbox-parameters ( offset node -- )
     parameters>> [
-        %prepare-unbox >r over + r> unbox-parameter
+        %prepare-unbox [ over + ] dip unbox-parameter
     ] reverse-each-parameter drop ;
 
 : prepare-box-struct ( node -- offset )

basis/compiler/codegen/fixup/fixup.factor

@@ -46,28 +46,27 @@ M: integer fixup* , ;
 : indq ( elt seq -- n ) [ eq? ] with find drop ;
 
 : adjoin* ( obj table -- n )
-    2dup indq [ 2nip ] [ dup length >r push r> ] if* ;
+    2dup indq [ 2nip ] [ dup length [ push ] dip ] if* ;
 
 SYMBOL: literal-table
 
 : add-literal ( obj -- n ) literal-table get adjoin* ;
 
 : add-dlsym-literals ( symbol dll -- )
-    >r string>symbol r> 2array literal-table get push-all ;
+    [ string>symbol ] dip 2array literal-table get push-all ;
 
 : rel-dlsym ( name dll class -- )
-    >r literal-table get length >r
+    [ literal-table get length [ add-dlsym-literals ] dip ] dip
-    add-dlsym-literals
+    rt-dlsym rel-fixup ;
-    r> r> rt-dlsym rel-fixup ;
 
 : rel-word ( word class -- )
-    >r add-literal r> rt-xt rel-fixup ;
+    [ add-literal ] dip rt-xt rel-fixup ;
 
 : rel-primitive ( word class -- )
-    >r def>> first r> rt-primitive rel-fixup ;
+    [ def>> first ] dip rt-primitive rel-fixup ;
 
 : rel-immediate ( literal class -- )
-    >r add-literal r> rt-immediate rel-fixup ;
+    [ add-literal ] dip rt-immediate rel-fixup ;
 
 : rel-this ( class -- )
     0 swap rt-label rel-fixup ;

basis/concurrency/conditions/conditions.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: deques threads kernel arrays sequences alarms ;
+USING: deques threads kernel arrays sequences alarms fry ;
 IN: concurrency.conditions
 
 : notify-1 ( deque -- )
@@ -12,15 +12,18 @@ IN: concurrency.conditions
 : queue-timeout ( queue timeout -- alarm )
     #! Add an alarm which removes the current thread from the
     #! queue, and resumes it, passing it a value of t.
-    >r [ self swap push-front* ] keep [
+    [
-        [ delete-node ] [ drop node-value ] 2bi
+        [ self swap push-front* ] keep '[
-        t swap resume-with
+            _ _
-    ] 2curry r> later ;
+            [ delete-node ] [ drop node-value ] 2bi
+            t swap resume-with
+        ]
+    ] dip later ;
 
 : wait ( queue timeout status -- )
     over [
-        >r queue-timeout [ drop ] r> suspend
+        [ queue-timeout [ drop ] ] dip suspend
         [ "Timeout" throw ] [ cancel-alarm ] if
     ] [
-        >r drop [ push-front ] curry r> suspend drop
+        [ drop '[ _ push-front ] ] dip suspend drop
     ] if ;

basis/concurrency/count-downs/count-downs.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: dlists kernel math concurrency.promises
-concurrency.mailboxes debugger accessors ;
+concurrency.mailboxes debugger accessors fry ;
 IN: concurrency.count-downs
 
 ! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html
@@ -26,12 +26,12 @@ ERROR: count-down-already-done ;
     [ 1- >>n count-down-check ] if ;
 
 : await-timeout ( count-down timeout -- )
-    >r promise>> r> ?promise-timeout ?linked t assert= ;
+    [ promise>> ] dip ?promise-timeout ?linked t assert= ;
 
 : await ( count-down -- )
     f await-timeout ;
 
 : spawn-stage ( quot count-down -- )
-    [ [ count-down ] curry compose ] keep
+    [ '[ @ _ count-down ] ] keep
     "Count down stage"
     swap promise>> mailbox>> spawn-linked-to drop ;

basis/concurrency/distributed/distributed-tests.factor

@@ -15,7 +15,7 @@ concurrency.messaging continuations accessors prettyprint ;
 
 [ ] [
     [
-        receive first2 >r 3 + r> send
+        receive first2 [ 3 + ] dip send
         "thread-a" unregister-process
     ] "Thread A" spawn
     "thread-a" swap register-process

basis/concurrency/exchangers/exchangers.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel threads boxes accessors ;
+USING: kernel threads boxes accessors fry ;
 IN: concurrency.exchangers
 
 ! Motivated by
@@ -14,8 +14,8 @@ TUPLE: exchanger thread object ;
 : exchange ( obj exchanger -- newobj )
     dup thread>> occupied>> [
         dup object>> box>
-        >r thread>> box> resume-with r>
+        [ thread>> box> resume-with ] dip
     ] [
         [ object>> >box ] keep
-        [ thread>> >box ] curry "exchange" suspend
+        '[ _ thread>> >box ] "exchange" suspend
     ] if ;

basis/concurrency/flags/flags-tests.factor

@@ -2,7 +2,7 @@ IN: concurrency.flags.tests
 USING: tools.test concurrency.flags concurrency.combinators
 kernel threads locals accessors calendar ;
 
-:: flag-test-1 ( -- )
+:: flag-test-1 ( -- val )
     [let | f [ <flag> ] |
         [ f raise-flag ] "Flag test" spawn drop
         f lower-flag
@@ -20,7 +20,7 @@ kernel threads locals accessors calendar ;
 
 [ f ] [ flag-test-2 ] unit-test
 
-:: flag-test-3 ( -- )
+:: flag-test-3 ( -- val )
     [let | f [ <flag> ] |
         f raise-flag
         f value>>
@@ -28,7 +28,7 @@ kernel threads locals accessors calendar ;
 
 [ t ] [ flag-test-3 ] unit-test
 
-:: flag-test-4 ( -- )
+:: flag-test-4 ( -- val )
     [let | f [ <flag> ] |
         [ f raise-flag ] "Flag test" spawn drop
         f wait-for-flag
@@ -37,7 +37,7 @@ kernel threads locals accessors calendar ;
 
 [ t ] [ flag-test-4 ] unit-test
 
-:: flag-test-5 ( -- )
+:: flag-test-5 ( -- val )
     [let | f [ <flag> ] |
         [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
         f wait-for-flag

basis/concurrency/flags/flags.factor

@@ -11,7 +11,7 @@ TUPLE: flag value threads ;
     dup value>> [ drop ] [ t >>value threads>> notify-all ] if ;
 
 : wait-for-flag-timeout ( flag timeout -- )
-    over value>> [ 2drop ] [ >r threads>> r> "flag" wait ] if ;
+    over value>> [ 2drop ] [ [ threads>> ] dip "flag" wait ] if ;
 
 : wait-for-flag ( flag -- )
     f wait-for-flag-timeout ;

basis/concurrency/futures/futures.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: concurrency.promises concurrency.mailboxes kernel arrays
-continuations accessors ;
+continuations accessors fry ;
 IN: concurrency.futures
 
 : future ( quot -- future )
     <promise> [
-        [ [ >r call r> fulfill ] 2curry "Future" ] keep
+        [ '[ @ _ fulfill ] "Future" ] keep
         mailbox>> spawn-linked-to drop
     ] keep ; inline
 

basis/concurrency/locks/locks-tests.factor

@@ -3,7 +3,7 @@ USING: tools.test concurrency.locks concurrency.count-downs
 concurrency.messaging concurrency.mailboxes locals kernel
 threads sequences calendar accessors ;
 
-:: lock-test-0 ( -- )
+:: lock-test-0 ( -- v )
     [let | v [ V{ } clone ]
            c [ 2 <count-down> ] |
 
@@ -27,7 +27,7 @@ threads sequences calendar accessors ;
            v
     ] ;
 
-:: lock-test-1 ( -- )
+:: lock-test-1 ( -- v )
     [let | v [ V{ } clone ]
            l [ <lock> ]
            c [ 2 <count-down> ] |
@@ -79,7 +79,7 @@ threads sequences calendar accessors ;
 
 [ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
 
-:: rw-lock-test-1 ( -- )
+:: rw-lock-test-1 ( -- v )
     [let | l [ <rw-lock> ]
            c [ 1 <count-down> ]
            c' [ 1 <count-down> ]
@@ -129,7 +129,7 @@ threads sequences calendar accessors ;
 
 [ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
 
-:: rw-lock-test-2 ( -- )
+:: rw-lock-test-2 ( -- v )
     [let | l [ <rw-lock> ]
            c [ 1 <count-down> ]
            c' [ 2 <count-down> ]
@@ -160,7 +160,7 @@ threads sequences calendar accessors ;
 [ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
 
 ! Test lock timeouts
-:: lock-timeout-test ( -- )
+:: lock-timeout-test ( -- v )
     [let | l [ <lock> ] |
         [
             l [ 1 seconds sleep ] with-lock
@@ -177,19 +177,6 @@ threads sequences calendar accessors ;
     thread>> name>> "Lock timeout-er" =
 ] must-fail-with
 
-:: read/write-test ( -- )
-    [let | l [ <lock> ] |
-        [
-            l [ 1 seconds sleep ] with-lock
-        ] "Lock holder" spawn drop
-
-        [
-            l 1/10 seconds [ ] with-lock-timeout
-        ] "Lock timeout-er" spawn-linked drop
-
-        receive
-    ] ;
-
 [
     <rw-lock> dup [
         1 seconds [ ] with-write-lock-timeout

basis/concurrency/locks/locks.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: deques dlists kernel threads continuations math
-concurrency.conditions combinators.short-circuit accessors ;
+concurrency.conditions combinators.short-circuit accessors
+locals ;
 IN: concurrency.locks
 
 ! Simple critical sections
@@ -17,16 +18,16 @@ TUPLE: lock threads owner reentrant? ;
 
 : acquire-lock ( lock timeout -- )
     over owner>>
-    [ 2dup >r threads>> r> "lock" wait ] when drop
+    [ 2dup [ threads>> ] dip "lock" wait ] when drop
     self >>owner drop ;
 
 : release-lock ( lock -- )
     f >>owner
     threads>> notify-1 ;
 
-: do-lock ( lock timeout quot acquire release -- )
+:: do-lock ( lock timeout quot acquire release -- )
-    >r >r pick rot r> call ! use up  timeout acquire
+    lock timeout acquire call
-    swap r> curry [ ] cleanup ; inline
+    quot lock release curry [ ] cleanup ; inline
 
 : (with-lock) ( lock timeout quot -- )
     [ acquire-lock ] [ release-lock ] do-lock ; inline
@@ -60,7 +61,7 @@ TUPLE: rw-lock readers writers reader# writer ;
 
 : acquire-read-lock ( lock timeout -- )
     over writer>>
-    [ 2dup >r readers>> r> "read lock" wait ] when drop
+    [ 2dup [ readers>> ] dip "read lock" wait ] when drop
     add-reader ;
 
 : notify-writer ( lock -- )
@@ -75,7 +76,7 @@ TUPLE: rw-lock readers writers reader# writer ;
 
 : acquire-write-lock ( lock timeout -- )
     over writer>> pick reader#>> 0 > or
-    [ 2dup >r writers>> r> "write lock" wait ] when drop
+    [ 2dup [ writers>> ] dip "write lock" wait ] when drop
     self >>writer drop ;
 
 : release-write-lock ( lock -- )

basis/concurrency/mailboxes/mailboxes.factor

@@ -4,7 +4,7 @@ IN: concurrency.mailboxes
 USING: dlists deques threads sequences continuations
 destructors namespaces math quotations words kernel
 arrays assocs init system concurrency.conditions accessors
-debugger debugger.threads locals ;
+debugger debugger.threads locals fry ;
 
 TUPLE: mailbox threads data disposed ;
 
@@ -21,7 +21,7 @@ M: mailbox dispose* threads>> notify-all ;
     [ threads>> notify-all ] bi yield ;
 
 : wait-for-mailbox ( mailbox timeout -- )
-    >r threads>> r> "mailbox" wait ;
+    [ threads>> ] dip "mailbox" wait ;
 
 :: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
     mailbox check-disposed
@@ -57,11 +57,11 @@ M: mailbox dispose* threads>> notify-all ;
     f mailbox-get-all-timeout ;
 
 : while-mailbox-empty ( mailbox quot -- )
-    [ [ mailbox-empty? ] curry ] dip [ ] while ; inline
+    [ '[ _ mailbox-empty? ] ] dip [ ] while ; inline
 
 : mailbox-get-timeout? ( mailbox timeout pred -- obj )
     [ block-unless-pred ]
-    [ nip >r data>> r> delete-node-if ]
+    [ [ drop data>> ] dip delete-node-if ]
     3bi ; inline
 
 : mailbox-get? ( mailbox pred -- obj )
@@ -90,7 +90,7 @@ M: linked-thread error-in-thread
     [ <linked-error> ] [ supervisor>> ] bi mailbox-put ;
 
 : <linked-thread> ( quot name mailbox -- thread' )
-    >r linked-thread new-thread r> >>supervisor ;
+    [ linked-thread new-thread ] dip >>supervisor ;
 
 : spawn-linked-to ( quot name mailbox -- thread )
     <linked-thread> [ (spawn) ] keep ;

basis/concurrency/messaging/messaging-docs.factor

@@ -55,7 +55,7 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
 { $example
     "USING: concurrency.messaging kernel threads ;"
     ": pong-server ( -- )"
-    "    receive >r \"pong\" r> reply-synchronous ;"
+    "    receive [ \"pong\" ] dip reply-synchronous ;"
     "[ pong-server t ] \"pong-server\" spawn-server"
     "\"ping\" swap send-synchronous ."
     "\"pong\""

basis/concurrency/messaging/messaging.factor

@@ -1,10 +1,7 @@
 ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-!
-! Concurrency library for Factor, based on Erlang/Termite style
-! concurrency.
 USING: kernel threads concurrency.mailboxes continuations
-namespaces assocs accessors summary ;
+namespaces assocs accessors summary fry ;
 IN: concurrency.messaging
 
 GENERIC: send ( message thread -- )
@@ -32,7 +29,7 @@ M: thread send ( message thread -- )
     my-mailbox -rot mailbox-get-timeout? ?linked ; inline
 
 : rethrow-linked ( error process supervisor -- )
-    >r <linked-error> r> send ;
+    [ <linked-error> ] dip send ;
 
 : spawn-linked ( quot name -- thread )
     my-mailbox spawn-linked-to ;
@@ -48,9 +45,7 @@ TUPLE: reply data tag ;
     tag>> \ reply boa ;
 
 : synchronous-reply? ( response synchronous -- ? )
-    over reply?
+    over reply? [ [ tag>> ] bi@ = ] [ 2drop f ] if ;
-    [ >r tag>> r> tag>> = ]
-    [ 2drop f ] if ;
 
 ERROR: cannot-send-synchronous-to-self message thread ;
 
@@ -61,8 +56,8 @@ M: cannot-send-synchronous-to-self summary
     dup self eq? [
         cannot-send-synchronous-to-self
     ] [
-        >r <synchronous> dup r> send
+        [ <synchronous> dup ] dip send
-        [ synchronous-reply? ] curry receive-if
+        '[ _ synchronous-reply? ] receive-if
         data>>
     ] if ;
 

basis/concurrency/promises/promises.factor

@@ -20,7 +20,7 @@ ERROR: promise-already-fulfilled promise ;
     ] if ;
 
 : ?promise-timeout ( promise timeout -- result )
-    >r mailbox>> r> block-if-empty mailbox-peek ;
+    [ mailbox>> ] dip block-if-empty mailbox-peek ;
 
 : ?promise ( promise -- result )
     f ?promise-timeout ;

basis/concurrency/semaphores/semaphores.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: dlists kernel threads math concurrency.conditions
-continuations accessors summary ;
+continuations accessors summary locals fry ;
 IN: concurrency.semaphores
 
 TUPLE: semaphore count threads ;
@@ -30,9 +30,9 @@ M: negative-count-semaphore summary
     [ 1+ ] change-count
     threads>> notify-1 ;
 
-: with-semaphore-timeout ( semaphore timeout quot -- )
+:: with-semaphore-timeout ( semaphore timeout quot -- )
-    pick rot acquire-timeout swap
+    semaphore timeout acquire-timeout
-    [ release ] curry [ ] cleanup ; inline
+    quot [ semaphore release ] [ ] cleanup ; inline
 
 : with-semaphore ( semaphore quot -- )
-    over acquire swap [ release ] curry [ ] cleanup ; inline
+    swap dup acquire '[ _ release ] [ ] cleanup ; inline

basis/cpu/x86/assembler/assembler.factor

@@ -300,7 +300,7 @@ PREDICATE: callable < word register? not ;
 
 GENERIC: MOV ( dst src -- )
 M: immediate MOV swap (MOV-I) ;
-M: callable MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
+M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ;
 M: operand MOV HEX: 88 2-operand ;
 
 : LEA ( dst src -- ) swap HEX: 8d 2-operand ;

basis/dlists/dlists.factor

@@ -93,11 +93,11 @@ M: dlist peek-front ( dlist -- obj )
 
 M: dlist pop-front* ( dlist -- )
     [
-        dup front>> [ empty-dlist ] unless*
+        [
-        dup next>>
+            [ empty-dlist ] unless*
-        f rot (>>next)
+            [ f ] change-next drop
-        f over set-prev-when
+            f over set-prev-when
-        swap (>>front)
+        ] change-front drop
     ] keep
     normalize-back ;
 
@@ -106,11 +106,11 @@ M: dlist peek-back ( dlist -- obj )
 
 M: dlist pop-back* ( dlist -- )
     [
-        dup back>> [ empty-dlist ] unless*
+        [
-        dup prev>>
+            [ empty-dlist ] unless*
-        f rot (>>prev)
+            [ f ] change-prev drop
-        f over set-next-when
+            f over set-next-when
-        swap (>>back)
+        ] change-back drop
     ] keep
     normalize-front ;
 

basis/furnace/sessions/sessions.factor

@@ -3,7 +3,7 @@
 USING: assocs kernel math.intervals math.parser namespaces
 strings random accessors quotations hashtables sequences
 continuations fry calendar combinators combinators.short-circuit
-destructors alarms io.servers.connection db db.tuples db.types
+destructors alarms io.sockets db db.tuples db.types
 http http.server http.server.dispatchers http.server.filters
 html.elements furnace.cache furnace.scopes furnace.utilities ;
 IN: furnace.sessions

basis/io/pipes/pipes.factor

@@ -15,9 +15,10 @@ HOOK: (pipe) io-backend ( -- pipe )
 
 : <pipe> ( encoding -- stream )
     [
-        >r (pipe) |dispose
+        [
-        [ in>> <input-port> ] [ out>> <output-port> ] bi
+            (pipe) |dispose
-        r> <encoder-duplex>
+            [ in>> <input-port> ] [ out>> <output-port> ] bi
+        ] dip <encoder-duplex>
     ] with-destructors ;
 
 <PRIVATE
@@ -32,8 +33,7 @@ GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )
 
 M: callable run-pipeline-element
     [
-        >r [ ?reader ] [ ?writer ] bi*
+        [ [ ?reader ] [ ?writer ] bi* ] dip with-streams*
-        r> with-streams*
     ] with-destructors ;
 
 : <pipes> ( n -- pipes )
@@ -48,8 +48,8 @@ PRIVATE>
 : run-pipeline ( seq -- results )
     [ length dup zero? [ drop { } ] [ 1- <pipes> ] if ] keep
     [
-        >r [ first in>> ] [ second out>> ] bi
+        [ [ first in>> ] [ second out>> ] bi ] dip
-        r> run-pipeline-element
+        run-pipeline-element
     ] 2parallel-map ;
 
 {

basis/io/unix/files/files.factor

@@ -216,19 +216,23 @@ M: unix (directory-entries) ( path -- seq )
 
 : stat-mode ( path -- mode )
     normalize-path file-status stat-st_mode ;
-    
+
-: chmod-set-bit ( path mask ? -- ) 
+: chmod-set-bit ( path mask ? -- )
-    [ dup stat-mode ] 2dip 
+    [ dup stat-mode ] 2dip
     [ bitor ] [ unmask ] if chmod io-error ;
 
-: file-mode? ( path mask -- ? ) [ stat-mode ] dip mask? ;
+GENERIC# file-mode? 1 ( obj mask -- ? )
+
+M: integer file-mode? mask? ;
+M: string file-mode? [ stat-mode ] dip mask? ;
+M: file-info file-mode? [ permissions>> ] dip mask? ;
 
 PRIVATE>
 
 : ch>file-type ( ch -- type )
     {
         { CHAR: b [ +block-device+ ] }
-        { CHAR: c [ +character-device+ ] }   
+        { CHAR: c [ +character-device+ ] }
         { CHAR: d [ +directory+ ] }
         { CHAR: l [ +symbolic-link+ ] }
         { CHAR: s [ +socket+ ] }
@@ -254,29 +258,29 @@ PRIVATE>
 : STICKY        OCT: 0001000 ; inline
 : USER-ALL      OCT: 0000700 ; inline
 : USER-READ     OCT: 0000400 ; inline
-: USER-WRITE    OCT: 0000200 ; inline 
+: USER-WRITE    OCT: 0000200 ; inline
-: USER-EXECUTE  OCT: 0000100 ; inline   
+: USER-EXECUTE  OCT: 0000100 ; inline
 : GROUP-ALL     OCT: 0000070 ; inline
-: GROUP-READ    OCT: 0000040 ; inline 
+: GROUP-READ    OCT: 0000040 ; inline
-: GROUP-WRITE   OCT: 0000020 ; inline  
+: GROUP-WRITE   OCT: 0000020 ; inline
-: GROUP-EXECUTE OCT: 0000010 ; inline    
+: GROUP-EXECUTE OCT: 0000010 ; inline
 : OTHER-ALL     OCT: 0000007 ; inline
 : OTHER-READ    OCT: 0000004 ; inline
-: OTHER-WRITE   OCT: 0000002 ; inline  
+: OTHER-WRITE   OCT: 0000002 ; inline
-: OTHER-EXECUTE OCT: 0000001 ; inline    
+: OTHER-EXECUTE OCT: 0000001 ; inline
 
-GENERIC: uid? ( obj -- ? )
+: uid? ( obj -- ? ) UID file-mode? ;
-GENERIC: gid? ( obj -- ? )
+: gid? ( obj -- ? ) GID file-mode? ;
-GENERIC: sticky? ( obj -- ? )
+: sticky? ( obj -- ? ) STICKY file-mode? ;
-GENERIC: user-read? ( obj -- ? )
+: user-read? ( obj -- ? ) USER-READ file-mode? ;
-GENERIC: user-write? ( obj -- ? )
+: user-write? ( obj -- ? ) USER-WRITE file-mode? ;
-GENERIC: user-execute? ( obj -- ? )
+: user-execute? ( obj -- ? ) USER-EXECUTE file-mode? ;
-GENERIC: group-read? ( obj -- ? )
+: group-read? ( obj -- ? ) GROUP-READ file-mode? ;
-GENERIC: group-write? ( obj -- ? )
+: group-write? ( obj -- ? ) GROUP-WRITE file-mode? ;
-GENERIC: group-execute? ( obj -- ? )
+: group-execute? ( obj -- ? ) GROUP-EXECUTE file-mode? ;
-GENERIC: other-read? ( obj -- ? )
+: other-read? ( obj -- ? ) OTHER-READ file-mode? ;
-GENERIC: other-write? ( obj -- ? )
+: other-write? ( obj -- ? ) OTHER-WRITE file-mode? ;
-GENERIC: other-execute? ( obj -- ? )
+: other-execute? ( obj -- ? ) OTHER-EXECUTE file-mode? ;
 
 : any-read? ( obj -- ? )
     { [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ;
@@ -287,56 +291,17 @@ GENERIC: other-execute? ( obj -- ? )
 : any-execute? ( obj -- ? )
     { [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ;
 
-M: integer uid? ( integer -- ? ) UID mask? ;
-M: integer gid? ( integer -- ? ) GID mask? ;
-M: integer sticky? ( integer -- ? ) STICKY mask? ;
-M: integer user-read? ( integer -- ? ) USER-READ mask? ;
-M: integer user-write? ( integer -- ? ) USER-WRITE mask? ;
-M: integer user-execute? ( integer -- ? ) USER-EXECUTE mask? ;
-M: integer group-read? ( integer -- ? ) GROUP-READ mask? ;
-M: integer group-write? ( integer -- ? ) GROUP-WRITE mask? ;
-M: integer group-execute? ( integer -- ? ) GROUP-EXECUTE mask? ;
-M: integer other-read? ( integer -- ? ) OTHER-READ mask? ;
-M: integer other-write? ( integer -- ? ) OTHER-WRITE mask? ; 
-M: integer other-execute? ( integer -- ? ) OTHER-EXECUTE mask? ;
-
-M: file-info uid? ( file-info -- ? ) permissions>> uid? ;
-M: file-info gid? ( file-info -- ? ) permissions>> gid? ;
-M: file-info sticky? ( file-info -- ? ) permissions>> sticky? ;
-M: file-info user-read? ( file-info -- ? ) permissions>> user-read? ;
-M: file-info user-write? ( file-info -- ? ) permissions>> user-write? ;
-M: file-info user-execute? ( file-info -- ? ) permissions>> user-execute? ;
-M: file-info group-read? ( file-info -- ? ) permissions>> group-read? ;
-M: file-info group-write? ( file-info -- ? ) permissions>> group-write? ;
-M: file-info group-execute? ( file-info -- ? ) permissions>> group-execute? ;
-M: file-info other-read? ( file-info -- ? ) permissions>> other-read? ;
-M: file-info other-write? ( file-info -- ? ) permissions>> other-write? ;
-M: file-info other-execute? ( file-info -- ? ) permissions>> other-execute? ;
-
-M: string uid? ( path -- ? ) UID file-mode? ;
-M: string gid? ( path -- ? ) GID file-mode? ;
-M: string sticky? ( path -- ? ) STICKY file-mode? ;
-M: string user-read? ( path -- ? ) USER-READ file-mode? ;
-M: string user-write? ( path -- ? ) USER-WRITE file-mode? ;
-M: string user-execute? ( path -- ? ) USER-EXECUTE file-mode? ;
-M: string group-read? ( path -- ? ) GROUP-READ file-mode? ;
-M: string group-write? ( path -- ? ) GROUP-WRITE file-mode? ;
-M: string group-execute? ( path -- ? ) GROUP-EXECUTE file-mode? ;
-M: string other-read? ( path -- ? ) OTHER-READ file-mode? ;
-M: string other-write? ( path -- ? ) OTHER-WRITE file-mode? ; 
-M: string other-execute? ( path -- ? ) OTHER-EXECUTE file-mode? ;
-
 : set-uid ( path ? -- ) UID swap chmod-set-bit ;
 : set-gid ( path ? -- ) GID swap chmod-set-bit ;
 : set-sticky ( path ? -- ) STICKY swap chmod-set-bit ;
 : set-user-read ( path ? -- ) USER-READ swap chmod-set-bit ;
-: set-user-write ( path ? -- ) USER-WRITE swap chmod-set-bit ; 
+: set-user-write ( path ? -- ) USER-WRITE swap chmod-set-bit ;
 : set-user-execute ( path ? -- ) USER-EXECUTE swap chmod-set-bit ;
 : set-group-read ( path ? -- ) GROUP-READ swap chmod-set-bit ;
-: set-group-write ( path ? -- ) GROUP-WRITE swap chmod-set-bit ; 
+: set-group-write ( path ? -- ) GROUP-WRITE swap chmod-set-bit ;
 : set-group-execute ( path ? -- ) GROUP-EXECUTE swap chmod-set-bit ;
 : set-other-read ( path ? -- ) OTHER-READ swap chmod-set-bit ;
-: set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ; 
+: set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ;
 : set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ;
 
 : set-file-permissions ( path n -- )
@@ -383,10 +348,10 @@ M: integer set-file-user ( path uid -- )
 
 M: string set-file-user ( path string -- )
     user-id f set-file-ids ;
-    
+
 M: integer set-file-group ( path gid -- )
     f swap set-file-ids ;
-    
+
 M: string set-file-group ( path string -- )
     group-id
     f swap set-file-ids ;

basis/opengl/gl/extensions/extensions.factor

@@ -1,6 +1,6 @@
-USING: alien alien.syntax alien.syntax.private combinators
+USING: alien alien.syntax alien.parser combinators
 kernel parser sequences system words namespaces hashtables init
-math arrays assocs continuations lexer ;
+math arrays assocs continuations lexer fry locals ;
 IN: opengl.gl.extensions
 
 ERROR: unknown-gl-platform ;
@@ -30,20 +30,22 @@ reset-gl-function-number-counter
 : gl-function-pointer ( names n -- funptr )
     gl-function-context 2array dup +gl-function-pointers+ get-global at
     [ 2nip ] [
-        >r [ gl-function-address ] map [ ] find nip
+        [
-        dup [ "OpenGL function not available" throw ] unless
+            [ gl-function-address ] map [ ] find nip
-        dup r>
+            dup [ "OpenGL function not available" throw ] unless
+            dup
+        ] dip
         +gl-function-pointers+ get-global set-at
     ] if* ;
 
 : indirect-quot ( function-ptr-quot return types abi -- quot )
-    [ alien-indirect ] 3curry compose ;
+    '[ @  _ _ _ alien-indirect ] ;
 
-: define-indirect ( abi return function-ptr-quot function-name parameters -- )
+:: define-indirect ( abi return function-ptr-quot function-name parameters -- )
-    [ pick ] dip parse-arglist
+    function-name create-in dup reset-generic
-    rot create-in
+    function-ptr-quot return
-    [ swapd roll indirect-quot ] 2dip
+    parameters return parse-arglist [ abi indirect-quot ] dip
-    -rot define-declared ;
+    define-declared ;
 
 : GL-FUNCTION:
     gl-function-calling-convention

basis/regexp/regexp-tests.factor

@@ -271,9 +271,9 @@ IN: regexp-tests
 
 [ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match >string ] unit-test
 
-[ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
+! [ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
 
-[ 1 ] [ "hello" ".+?" <regexp> match length ] unit-test
+! [ 1 ] [ "hello" ".+?" <regexp> match length ] unit-test
 
 [ { "1" "2" "3" "4" } ]
 [ "1ABC2DEF3GHI4" R/ [A-Z]+/ re-split [ >string ] map ] unit-test
@@ -295,7 +295,7 @@ IN: regexp-tests
 
 [ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
 [ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
-[ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
+! [ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
 [ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
 [ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> first-match >string ] unit-test
 [ "a" ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match >string ] unit-test

basis/smtp/smtp-tests.factor

@@ -1,6 +1,7 @@
-USING: smtp tools.test io.streams.string io.sockets threads
+USING: smtp tools.test io.streams.string io.sockets
-smtp.server kernel sequences namespaces logging accessors
+io.sockets.secure threads smtp.server kernel sequences
-assocs sorting smtp.private concurrency.promises ;
+namespaces logging accessors assocs sorting smtp.private
+concurrency.promises system ;
 IN: smtp.tests
 
 \ send-email must-infer
@@ -77,10 +78,10 @@ IN: smtp.tests
 [ ] [ "p" get mock-smtp-server ] unit-test
 
 [ ] [
-    [
+    <secure-config> f >>verify [
         "localhost" "p" get ?promise <inet> smtp-server set
         no-auth smtp-auth set
-        smtp-tls? on
+        os unix? [ smtp-tls? on ] when
 
         <email>
             "Hi guys\nBye guys" >>body
@@ -91,5 +92,5 @@ IN: smtp.tests
             } >>to
             "Doug <erg@factorcode.org>" >>from
         send-email
-    ] with-scope
+    ] with-secure-context
 ] unit-test

basis/ui/cocoa/cocoa.factor

@@ -33,16 +33,13 @@ M: pasteboard set-clipboard-contents
     <clipboard> selection set-global ;
 
 : world>NSRect ( world -- NSRect )
-    dup window-loc>> first2 rot rect-dim first2 <NSRect> ;
+    [ window-loc>> ] [ dim>> ] bi [ first2 ] bi@ <NSRect> ;
 
 : gadget-window ( world -- )
-    [
+    dup <FactorView>
-        dup <FactorView>
+    2dup swap world>NSRect <ViewWindow>
-        dup rot world>NSRect <ViewWindow>
+    [ [ -> release ] [ install-window-delegate ] bi* ] [ <handle> ] 2bi
-        dup install-window-delegate
+    >>handle drop ;
-        over -> release
-        <handle>
-    ] keep (>>handle) ;
 
 M: cocoa-ui-backend set-title ( string world -- )
     handle>> window>> swap <NSString> -> setTitle: ;

basis/ui/cocoa/views/views-tests.factor

@@ -0,0 +1,15 @@
+IN: ui.cocoa.views.tests
+USING: ui.cocoa.views tools.test kernel math.geometry.rect
+namespaces ;
+
+[ t ] [
+    T{ rect
+        { loc { 0 0 } }
+        { dim { 1000 1000 } }
+    } "world" set
+
+    T{ rect
+        { loc { 1.5 2.25 } }
+        { dim { 13.0 14.0 } }
+    } dup "world" get rect>NSRect "world" get NSRect>rect =
+] unit-test

basis/ui/cocoa/views/views.factor

@@ -77,18 +77,22 @@ IN: ui.cocoa.views
     dup event-modifiers swap button ;
 
 : send-button-down$ ( view event -- )
-    [ mouse-event>gesture <button-down> ]
+    [ nip mouse-event>gesture <button-down> ]
-    [ mouse-location rot window send-button-down ] 2bi ;
+    [ mouse-location ]
+    [ drop window ]
+    2tri send-button-down ;
 
 : send-button-up$ ( view event -- )
-    [ mouse-event>gesture <button-up> ] 2keep
+    [ nip mouse-event>gesture <button-up> ]
-    mouse-location rot window send-button-up ;
+    [ mouse-location ]
+    [ drop window ]
+    2tri send-button-up ;
 
 : send-wheel$ ( view event -- )
-    [
+    [ nip [ -> deltaX ] [ -> deltaY ] bi [ sgn neg ] bi@ 2array ]
-        dup -> deltaX sgn neg over -> deltaY sgn neg 2array -rot
+    [ mouse-location ]
-        mouse-location
+    [ drop window ]
-    ] [ drop window ] 2bi send-wheel ;
+    2tri send-wheel ;
 
 : send-action$ ( view event gesture -- junk )
     [ drop window ] dip send-action f ;
@@ -103,21 +107,18 @@ IN: ui.cocoa.views
     [ CF>string NSStringPboardType = ] [ t ] if* ;
 
 : valid-service? ( gadget send-type return-type -- ? )
-    over string-or-nil? over string-or-nil? and [
+    over string-or-nil? over string-or-nil? and
-        drop [ gadget-selection? ] [ drop t ] if
+    [ drop [ gadget-selection? ] [ drop t ] if ] [ 3drop f ] if ;
-    ] [
-        3drop f
-    ] if ;
 
 : NSRect>rect ( NSRect world -- rect )
-    [ dup NSRect-x over NSRect-y ] dip
+    [ [ [ NSRect-x ] [ NSRect-y ] bi ] [ dim>> second ] bi* swap - 2array ]
-    rect-dim second swap - 2array
+    [ drop [ NSRect-w ] [ NSRect-h ] bi 2array ]
-    over NSRect-w rot NSRect-h 2array
+    2bi <rect> ;
-    <rect> ;
 
 : rect>NSRect ( rect world -- NSRect )
-    over rect-loc first2 rot rect-dim second swap -
+    [ [ rect-loc first2 ] [ dim>> second ] bi* swap - ]
-    rot rect-dim first2 <NSRect> ;
+    [ drop rect-dim first2 ]
+    2bi <NSRect> ;
 
 CLASS: {
     { +superclass+ "NSOpenGLView" }
@@ -342,7 +343,7 @@ CLASS: {
 
 { "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }
     [
-        rot drop
+        [ drop ] 2dip
         SUPER-> initWithFrame:pixelFormat:
         dup dup add-resize-observer
     ]
@@ -351,9 +352,10 @@ CLASS: {
 { "dealloc" "void" { "id" "SEL" }
     [
         drop
-        dup unregister-window
+        [ unregister-window ]
-        dup remove-observer
+        [ remove-observer ]
-        SUPER-> dealloc
+        [ SUPER-> dealloc ]
+        tri
     ]
 } ;
 

basis/ui/freetype/freetype.factor

@@ -97,14 +97,15 @@ SYMBOL: dpi
     dup handle>> init-descent
     dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
 
-: set-char-size ( handle size -- )
+: set-char-size ( open-font size -- open-font )
-    0 swap 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
+    [ dup handle>> 0 ] dip
+    6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
 
-: <font> ( handle -- font )
+: <font> ( font -- open-font )
     font new
         H{ } clone >>widths
         over first2 open-face >>handle
-        dup handle>> rot third set-char-size
+        swap third set-char-size
         init-font ;
 
 M: freetype-renderer open-font ( font -- open-font )
@@ -120,7 +121,7 @@ M: freetype-renderer open-font ( font -- open-font )
     ] cache nip ;
 
 M: freetype-renderer string-width ( open-font string -- w )
-    0 -rot [ char-width + ] with each ;
+    [ 0 ] 2dip [ char-width + ] with each ;
 
 M: freetype-renderer string-height ( open-font string -- h )
     drop height>> ;
@@ -165,8 +166,9 @@ M: freetype-renderer string-height ( open-font string -- h )
     ] with-malloc ;
 
 : glyph-texture-loc ( glyph font -- loc )
-    over glyph-hori-bearing-x ft-floor -rot
+    [ drop glyph-hori-bearing-x ft-floor ]
-    ascent>> swap glyph-hori-bearing-y - ft-floor 2array ;
+    [ ascent>> swap glyph-hori-bearing-y - ft-floor ]
+    2bi 2array ;
 
 : glyph-texture-size ( glyph -- dim )
     [ glyph-bitmap-width next-power-of-2 ]

basis/ui/gadgets/buttons/buttons-docs.factor

@@ -71,3 +71,5 @@ ARTICLE: "ui.gadgets.buttons" "Button gadgets"
 { $subsection button-paint }
 "Button constructors take " { $emphasis "label specifiers" } " as input. A label specifier is either a string, an array of strings, a gadget or " { $link f } "."
 { $see-also <command-button> "ui-commands" } ;
+
+ABOUT: "ui.gadgets.buttons"

basis/ui/gadgets/editors/editors-docs.factor

@@ -20,22 +20,12 @@ HELP: <editor>
 { $values { "editor" "a new " { $link editor } } }
 { $description "Creates a new " { $link editor } " with an empty document." } ;
 
-! 'editor-caret' is now an old accessor, but it's documented as a word here. Maybe move this description somewhere else.
-
-! HELP: editor-caret ( editor -- caret )
-! { $values { "editor" editor } { "caret" model } }
-! { $description "Outputs a " { $link model } " holding the current caret location." } ;
-
 { editor-caret* editor-mark* } related-words
 
 HELP: editor-caret*
 { $values { "editor" editor } { "loc" "a pair of integers" } }
 { $description "Outputs the current caret location as a line/column number pair." } ;
 
-! HELP: editor-mark ( editor -- mark )
-! { $values { "editor" editor } { "mark" model } }
-! { $description "Outputs a " { $link model } " holding the current mark location." } ;
-
 HELP: editor-mark*
 { $values { "editor" editor } { "loc" "a pair of integers" } }
 { $description "Outputs the current mark location as a line/column number pair." } ;

basis/ui/gadgets/editors/editors.factor

@@ -6,7 +6,8 @@ io.styles math.vectors sorting colors combinators assocs
 math.order fry calendar alarms ui.clipboards ui.commands
 ui.gadgets ui.gadgets.borders ui.gadgets.buttons
 ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.theme
-ui.gadgets.wrappers ui.render ui.gestures math.geometry.rect ;
+ui.gadgets.menus ui.gadgets.wrappers ui.render ui.gestures
+math.geometry.rect ;
 IN: ui.gadgets.editors
 
 TUPLE: editor < gadget
@@ -137,11 +138,8 @@ M: editor ungraft*
     f >>focused?
     relayout-1 ;
 
-: (offset>x) ( font col# str -- x )
-    swap head-slice string-width ;
-
 : offset>x ( col# line# editor -- x )
-    [ editor-line ] keep editor-font* -rot (offset>x) ;
+    [ editor-line ] keep editor-font* spin head-slice string-width ;
 
 : loc>x ( loc editor -- x ) [ first2 swap ] dip offset>x ;
 
@@ -515,6 +513,13 @@ editor "selection" f {
     { T{ key-down f { S+ C+ } "END" } select-end-of-document }
 } define-command-map
 
+: editor-menu ( editor -- )
+    { cut com-copy paste } show-commands-menu ;
+
+editor "misc" f {
+    { T{ button-down f f 3 } editor-menu }
+} define-command-map
+
 ! Multi-line editors
 TUPLE: multiline-editor < editor ;
 

basis/ui/gadgets/gadgets-tests.factor

@@ -152,13 +152,6 @@ M: mock-gadget ungraft*
     { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
 ] with-string-writer print
 
-[ { { 10 30 } } ] [
-    <gadget> { 0 1 } >>orientation
-    { { 10 20 } }
-    { { 100 30 } }
-    orient
-] unit-test
-
 \ <gadget> must-infer
 \ unparent must-infer
 \ add-gadget must-infer

basis/ui/gadgets/gadgets.factor

@@ -86,15 +86,12 @@ M: gadget children-on nip children>> ;
 
 : pick-up ( point gadget -- child/f )
     2dup (pick-up) dup
-    [ nip [ rect-loc v- ] keep pick-up ] [ rot 2drop ] if ;
+    [ nip [ rect-loc v- ] keep pick-up ] [ drop nip ] if ;
 
 : max-dim ( dims -- dim ) { 0 0 } [ vmax ] reduce ;
 
 : dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
 
-: orient ( gadget seq1 seq2 -- seq )
-    rot orientation>> '[ _ set-axis ] 2map ;
-
 : each-child ( gadget quot -- )
     [ children>> ] dip each ; inline
 

basis/ui/gadgets/grids/grids.factor

@@ -18,14 +18,14 @@ grid
 : <grid> ( children -- grid )
     grid new-grid ;
 
-: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
+:: grid-child ( grid i j -- gadget ) i j grid grid>> nth nth ;
 
 :: grid-add ( grid child i j -- grid )
     grid i j grid-child unparent
     grid child add-gadget
     child i j grid grid>> nth set-nth ;
 
-: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add ;
+: grid-remove ( grid i j -- grid ) [ <gadget> ] 2dip grid-add ;
 
 : pref-dim-grid ( grid -- dims )
     grid>> [ [ pref-dim ] map ] map ;

basis/ui/gadgets/labelled/labelled.factor

@@ -48,9 +48,10 @@ TUPLE: closable-gadget < frame content ;
     [ closable-gadget? ] find-parent ;
 
 : <closable-gadget> ( gadget title quot -- gadget )
-    closable-gadget new-frame
+    [
-        -rot <title-bar> @top grid-add
+        [ closable-gadget new-frame ] dip
-        swap >>content
+        [ >>content ] [ @center grid-add ] bi
-        dup content>> @center grid-add ;
+    ] 2dip
+    <title-bar> @top grid-add ;
     
 M: closable-gadget focusable-child* content>> ;

basis/ui/gadgets/menus/menus-docs.factor

@@ -3,9 +3,22 @@ kernel ;
 IN: ui.gadgets.menus
 
 HELP: <commands-menu>
-{ $values { "hook" { $quotation "( button -- )" } } { "target" object } { "commands" "a sequence of commands" } { "gadget" "a new " { $link gadget } } }
+{ $values { "target" object } { "commands" "a sequence of commands" } { "hook" { $quotation "( button -- )" } }  { "menu" "a new " { $link gadget } } }
 { $description "Creates a popup menu of commands which are to be invoked on " { $snippet "target" } ". The " { $snippet "hook" } " quotation is run before a command is invoked." } ;
 
 HELP: show-menu
-{ $values { "gadget" gadget } { "owner" gadget } }
+{ $values { "owner" gadget } { "menu" gadget } }
-{ $description "Displays a popup menu in the " { $link world } " containing " { $snippet "owner" } " at the current mouse location." } ;
+{ $description "Displays a popup menu in the " { $link world } " containing " { $snippet "owner" } " at the current mouse location. The popup menu can be any gadget." } ;
+
+HELP: show-commands-menu
+{ $values { "target" gadget } { "commands" "a sequence of commands" } }
+{ $description "Displays a popup menu with the given commands. The commands act on the target gadget. This is just a convenience word that combines " { $link <commands-menu> } " with " { $link show-menu } "." }
+{ $notes "Useful for right-click context menus." } ;
+
+ARTICLE: "ui.gadgets.menus" "Popup menus"
+"The " { $vocab-link "ui.gadgets.menus" } " vocabulary implements popup menus."
+{ $subsection <commands-menu> }
+{ $subsection show-menu }
+{ $subsection show-commands-menu } ;
+
+ABOUT: "ui.gadgets.menus"

basis/ui/gadgets/menus/menus.factor

@@ -1,10 +1,10 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays ui.commands ui.gadgets ui.gadgets.buttons
+USING: locals accessors arrays ui.commands ui.gadgets
-ui.gadgets.worlds ui.gestures generic hashtables kernel math
+ui.gadgets.buttons ui.gadgets.worlds ui.gestures generic
-models namespaces opengl sequences math.vectors
+hashtables kernel math models namespaces opengl sequences
-ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors
+math.vectors ui.gadgets.theme ui.gadgets.packs
-math.geometry.rect ;
+ui.gadgets.borders colors math.geometry.rect ;
 IN: ui.gadgets.menus
 
 : menu-loc ( world menu -- loc )
@@ -12,9 +12,9 @@ IN: ui.gadgets.menus
 
 TUPLE: menu-glass < gadget ;
 
-: <menu-glass> ( menu world -- glass )
+: <menu-glass> ( world menu -- glass )
+    tuck menu-loc >>loc
     menu-glass new-gadget
-    [ over menu-loc >>loc ] dip
     swap add-gadget ;
 
 M: menu-glass layout* gadget-child prefer ;
@@ -22,30 +22,35 @@ M: menu-glass layout* gadget-child prefer ;
 : hide-glass ( world -- )
     [ [ unparent ] when* f ] change-glass drop ;
 
-: show-glass ( gadget world -- )
+: show-glass ( world gadget -- )
-    dup hide-glass
+    [ [ hide-glass ] [ hand-clicked set-global ] bi* ]
-    swap [ hand-clicked set-global ] [ >>glass ] bi
+    [ add-gadget drop ]
-    dup glass>> add-gadget drop ;
+    [ >>glass drop ]
+    2tri ;
 
-: show-menu ( gadget owner -- )
+: show-menu ( owner menu -- )
-    find-world [ <menu-glass> ] keep show-glass ;
+    [ find-world dup ] dip <menu-glass> show-glass ;
 
 \ menu-glass H{
     { T{ button-down } [ find-world [ hide-glass ] when* ] }
     { T{ drag } [ update-clicked drop ] }
 } set-gestures
 
-: <menu-item> ( hook target command -- button )
+:: <menu-item> ( target hook command -- button )
-    dup command-name -rot command-button-quot
+    command command-name [
-    swapd
+        hook call
-    [ hand-clicked get find-world hide-glass ]
+        target command command-button-quot call
-    3append <roll-button> ;
+        hand-clicked get find-world hide-glass
+    ] <roll-button> ;
 
 : menu-theme ( gadget -- gadget )
     light-gray solid-interior
     faint-boundary ;
 
-: <commands-menu> ( hook target commands -- gadget )
+: <commands-menu> ( target hook commands -- menu )
     [ <filled-pile> ] 3dip
-        [ <menu-item> add-gadget ] with with each
+    [ <menu-item> add-gadget ] with with each
     5 <border> menu-theme ;
+
+: show-commands-menu ( target commands -- )
+    [ dup [ ] ] dip <commands-menu> show-menu ;

basis/ui/gadgets/packs/packs-tests.factor

@@ -1,6 +1,7 @@
 IN: ui.gadgets.packs.tests
 USING: ui.gadgets.packs ui.gadgets.labels ui.gadgets ui.render
-kernel namespaces tools.test math.parser sequences math.geometry.rect ;
+kernel namespaces tools.test math.parser sequences math.geometry.rect
+accessors ;
 
 [ t ] [
     { 0 0 } { 100 100 } <rect> clip set
@@ -11,3 +12,10 @@ kernel namespaces tools.test math.parser sequences math.geometry.rect ;
 
     visible-children [ label? ] all?
 ] unit-test
+
+[ { { 10 30 } } ] [
+    { { 10 20 } }
+    { { 100 30 } }
+    <gadget> { 0 1 } >>orientation
+    orient
+] unit-test

basis/ui/gadgets/packs/packs.factor

@@ -1,28 +1,30 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: sequences ui.gadgets kernel math math.functions
-math.vectors namespaces math.order accessors math.geometry.rect ;
+math.vectors math.order math.geometry.rect namespaces accessors
+fry ;
 IN: ui.gadgets.packs
 
 TUPLE: pack < gadget
-    { align initial: 0 }
+{ align initial: 0 } { fill initial: 0 } { gap initial: { 0 0 } } ;
-    { fill  initial: 0 }
-    { gap   initial: { 0 0 } } ;
 
 : packed-dim-2 ( gadget sizes -- list )
-    [ over rect-dim over v- rot fill>> v*n v+ ] with map ;
+    swap [ dim>> ] [ fill>> ] bi '[ _ over v- _ v*n v+ ] map ;
+
+: orient ( seq1 seq2 gadget -- seq )
+    orientation>> '[ _ set-axis ] 2map ;
 
 : packed-dims ( gadget sizes -- seq )
-    2dup packed-dim-2 swap orient ;
+    [ packed-dim-2 ] [ nip ] [ drop ] 2tri orient ;
 
 : gap-locs ( gap sizes -- seq )
     { 0 0 } [ v+ over v+ ] accumulate 2nip ;
 
 : aligned-locs ( gadget sizes -- seq )
-    [ [ dup align>> swap rect-dim ] dip v- n*v ] with map ;
+    [ [ [ align>> ] [ dim>> ] bi ] dip v- n*v ] with map ;
 
 : packed-locs ( gadget sizes -- seq )
-    over gap>> over gap-locs [ dupd aligned-locs ] dip orient ;
+    [ aligned-locs ] [ [ gap>> ] dip gap-locs ] [ drop ] 2tri orient ;
 
 : round-dims ( seq -- newseq )
     { 0 0 } swap
@@ -45,12 +47,14 @@ TUPLE: pack < gadget
 
 : <shelf> ( -- pack ) { 1 0 } <pack> ;
 
-: gap-dims ( gap sizes -- seeq )
+: gap-dims ( sizes gadget -- seeq )
-    [ dim-sum ] keep length 1 [-] rot n*v v+ ;
+    [ [ dim-sum ] [ length 1 [-] ] bi ] [ gap>> ] bi* n*v v+ ;
 
 : pack-pref-dim ( gadget sizes -- dim )
-    over gap>> over gap-dims [ max-dim ] dip
+    [ nip max-dim ]
-    rot orientation>> set-axis ;
+    [ swap gap-dims ]
+    [ drop orientation>> ]
+    2tri set-axis ;
 
 M: pack pref-dim*
     dup children>> pref-dims pack-pref-dim ;

basis/ui/gadgets/panes/panes.factor

@@ -3,10 +3,10 @@
 USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
 ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.paragraphs
 ui.gadgets.incremental ui.gadgets.packs ui.gadgets.theme
-ui.clipboards ui.gestures ui.traverse ui.render hashtables io
+ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render
-kernel namespaces sequences io.styles strings quotations math
+hashtables io kernel namespaces sequences io.styles strings
-opengl combinators math.vectors sorting splitting
+quotations math opengl combinators math.vectors sorting
-io.streams.nested assocs ui.gadgets.presentations
+splitting io.streams.nested assocs ui.gadgets.presentations
 ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
 classes.tuple models continuations destructors accessors
 math.geometry.rect fry ;
@@ -398,6 +398,8 @@ M: f sloppy-pick-up*
     dup request-focus
     com-copy-selection ;
 
+: pane-menu ( pane -- ) { com-copy } show-commands-menu ;
+
 pane H{
     { T{ button-down } [ begin-selection ] }
     { T{ button-down f { S+ } 1 } [ select-to-caret ] }
@@ -405,4 +407,5 @@ pane H{
     { T{ button-up } [ end-selection ] }
     { T{ drag } [ extend-selection ] }
     { T{ copy-action } [ com-copy ] }
+    { T{ button-down f f 3 } [ pane-menu ] }
 } set-gestures

basis/ui/gadgets/paragraphs/paragraphs.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2005, 2007 Slava Pestov
+! Copyright (C) 2005, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays ui.gadgets ui.gadgets.labels ui.render kernel math
+USING: accessors arrays ui.gadgets ui.gadgets.labels ui.render
-namespaces sequences math.order math.geometry.rect ;
+kernel math namespaces sequences math.order math.geometry.rect
+locals ;
 IN: ui.gadgets.paragraphs
 
 ! A word break gadget
@@ -46,12 +47,19 @@ SYMBOL: margin
     dup line-height [ max ] change
     y get + max-y [ max ] change ;
 
-: wrap-step ( quot child -- )
+:: wrap-step ( quot child -- )
-    dup pref-dim [
+    child pref-dim
-        over word-break-gadget? [
+    [
-            dup first overrun? [ wrap-line ] when
+        child
-        ] unless drop wrap-pos rot call
+        [
-    ] keep first2 advance-y advance-x ; inline
+            word-break-gadget?
+            [ drop ] [ first overrun? [ wrap-line ] when ] if
+        ]
+        [ wrap-pos quot call ] bi
+    ]
+    [ first advance-x ]
+    [ second advance-y ]
+    tri ; inline
 
 : wrap-dim ( -- dim ) max-x get max-y get 2array ;
 

basis/ui/gadgets/presentations/presentations.factor

@@ -36,12 +36,13 @@ M: presentation ungraft*
     call-next-method ;
 
 : <operations-menu> ( presentation -- menu )
-    dup dup hook>> curry
+    [ object>> ]
-    swap object>>
+    [ dup hook>> curry ]
-    dup object-operations <commands-menu> ;
+    [ object>> object-operations ]
+    tri <commands-menu> ;
 
 : operations-menu ( presentation -- )
-    dup <operations-menu> swap show-menu ;
+    dup <operations-menu> show-menu ;
 
 presentation H{
     { T{ button-down f f 3 } [ operations-menu ] }

basis/ui/gadgets/sliders/sliders.factor

@@ -26,10 +26,11 @@ TUPLE: slider < frame elevator thumb saved line ;
 : slider-max*  ( gadget -- n ) model>> range-max-value*    ;
 
 : thumb-dim ( slider -- h )
-    dup slider-page over slider-max 1 max / 1 min
+    [
-    over elevator-length * min-thumb-dim max
+        [ [ slider-page ] [ slider-max 1 max ] bi / 1 min ]
-    over elevator>> rect-dim
+        [ elevator-length ] bi * min-thumb-dim max
-    rot orientation>> v. min ;
+    ]
+    [ [ elevator>> dim>> ] [ orientation>> ] bi v. ] bi min ;
 
 : slider-scale ( slider -- n )
     #! A scaling factor such that if x is a slider co-ordinate,
@@ -109,8 +110,8 @@ elevator H{
 : layout-thumb-dim ( slider -- )
     dup dup thumb-dim (layout-thumb)
     [
-        [ dup rect-dim ] dip
+        [ [ rect-dim ] dip ] [ drop orientation>> ] 2bi set-axis
-        rot orientation>> set-axis [ ceiling ] map
+        [ ceiling ] map
     ] dip (>>dim) ;
 
 : layout-thumb ( slider -- )

basis/ui/gadgets/worlds/worlds.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs continuations kernel math models
-namespaces opengl sequences io combinators math.vectors
+namespaces opengl sequences io combinators fry math.vectors
 ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
 debugger math.geometry.rect ;
 IN: ui.gadgets.worlds
@@ -67,9 +67,7 @@ M: world children-on nip children>> ;
 : draw-world? ( world -- ? )
     #! We don't draw deactivated worlds, or those with 0 size.
     #! On Windows, the latter case results in GL errors.
-    dup active?>>
+    [ active?>> ] [ handle>> ] [ dim>> [ 0 > ] all? ] tri and and ;
-    over handle>>
-    rot rect-dim [ 0 > ] all? and and ;
 
 TUPLE: world-error error world ;
 
@@ -127,5 +125,4 @@ M: world handle-gesture ( gesture gadget -- ? )
     ] [ 2drop f ] if ;
 
 : close-global ( world global -- )
-    dup get-global find-world rot eq?
+    [ get-global find-world eq? ] keep '[ f _ set-global ] when ;
-    [ f swap set-global ] [ drop ] if ;

basis/ui/operations/operations.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays definitions kernel ui.commands
 ui.gestures sequences strings math words generic namespaces make
-hashtables help.markup quotations assocs ;
+hashtables help.markup quotations assocs fry ;
 IN: ui.operations
 
 SYMBOL: +keyboard+
@@ -63,7 +63,7 @@ SYMBOL: operations
         t >>listener? ;
 
 : modify-operations ( operations hook translator -- operations )
-    rot [ modify-operation ] with with map ;
+    '[ [ _ _ ] dip modify-operation ] map ;
 
 : operations>commands ( object hook translator -- pairs )
     [ object-operations ] 2dip modify-operations

basis/ui/render/render.factor

@@ -227,7 +227,7 @@ HOOK: free-fonts font-renderer ( world -- )
     dup string? [
         string-width
     ] [
-        0 -rot [ string-width max ] with each
+        [ 0 ] 2dip [ string-width max ] with each
     ] if ;
 
 : text-dim ( open-font text -- dim )

basis/ui/tools/deploy/deploy.factor

@@ -117,5 +117,7 @@ deploy-gadget "toolbar" f {
     dup com-revert ;
     
 : deploy-tool ( vocab -- )
-    vocab-name dup <deploy-gadget> 10 <border>
+    vocab-name
-    "Deploying \"" rot "\"" 3append open-window ;
+    [ <deploy-gadget> 10 <border> ]
+    [ "Deploying \"" swap "\"" 3append ] bi
+    open-window ;

basis/ui/tools/interactor/interactor.factor

@@ -81,14 +81,15 @@ M: interactor model-changed
 : interactor-continue ( obj interactor -- )
     mailbox>> mailbox-put ;
 
-: clear-input ( interactor -- ) model>> clear-doc ;
+: clear-input ( interactor -- )
+    #! The with-datastack is a kludge to make it infer. Stupid.
+    model>> 1array [ clear-doc ] with-datastack drop ;
 
 : interactor-finish ( interactor -- )
-    #! The spawn is a kludge to make it infer. Stupid.
     [ editor-string ] keep
     [ interactor-input. ] 2keep
     [ add-interactor-history ] keep
-    '[ _ clear-input ] "Clearing input" spawn drop ;
+    clear-input ;
 
 : interactor-eof ( interactor -- )
     dup interactor-busy? [

basis/ui/traverse/traverse.factor

@@ -59,15 +59,15 @@ TUPLE: node value children ;
 DEFER: (gadget-subtree)
 
 : traverse-child ( frompath topath gadget -- )
-    [ -rot ] keep [
+    [ 2nip ] 3keep
-        [ rest-slice ] 2dip traverse-step (gadget-subtree)
+    [ [ rest-slice ] 2dip traverse-step (gadget-subtree) ]
-    ] make-node ;
+    make-node ;
 
 : (gadget-subtree) ( frompath topath gadget -- )
     {
         { [ dup not ] [ 3drop ] }
         { [ pick empty? pick empty? and ] [ 2nip , ] }
-        { [ pick empty? ] [ rot drop traverse-to-path ] }
+        { [ pick empty? ] [ traverse-to-path drop ] }
         { [ over empty? ] [ nip traverse-from-path ] }
         { [ pick first pick first = ] [ traverse-child ] }
         [ traverse-middle ]

basis/ui/ui-docs.factor

@@ -95,6 +95,7 @@ ARTICLE: "gadgets" "Pre-made UI gadgets"
 { $subsection "ui.gadgets.sliders" }
 { $subsection "ui.gadgets.scrollers" }
 { $subsection "gadgets-editors" }
+{ $subsection "ui.gadgets.menus" }
 { $subsection "ui.gadgets.panes" }
 { $subsection "ui.gadgets.presentations" }
 { $subsection "ui.gadgets.lists" } ;

basis/ui/windows/windows.factor

@@ -296,8 +296,10 @@ SYMBOL: nc-buttons
     key-modifiers swap message>button
     [ <button-down> ] [ <button-up> ] if ;
 
-: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
+:: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
-    [ drop mouse-event>gesture ] dip >lo-hi rot window ;
+    uMsg mouse-event>gesture
+    lParam >lo-hi
+    hWnd window ;
 
 : set-capture ( hwnd -- )
     mouse-captured get [
@@ -435,7 +437,7 @@ M: windows-ui-backend do-events
     style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
 
 : make-RECT ( world -- RECT )
-    dup window-loc>> dup rot rect-dim v+
+    [ window-loc>> dup ] [ rect-dim ] bi v+
     "RECT" <c-object>
     over first over set-RECT-right
     swap second over set-RECT-bottom

basis/ui/x11/x11.factor

@@ -95,8 +95,10 @@ M: world key-up-event
     [ key-up-event>gesture ] dip world-focus propagate-gesture ;
 
 : mouse-event>gesture ( event -- modifiers button loc )
-    dup event-modifiers over XButtonEvent-button
+    [ event-modifiers ]
-    rot mouse-event-loc ;
+    [ XButtonEvent-button ]
+    [ mouse-event-loc ]
+    tri ;
 
 M: world button-down-event
     [ mouse-event>gesture [ <button-down> ] dip ] dip
@@ -222,8 +224,8 @@ M: x-clipboard paste-clipboard
     utf8 encode dup length XChangeProperty drop ;
 
 M: x11-ui-backend set-title ( string world -- )
-    handle>> window>> swap dpy get -rot
+    handle>> window>> swap
-    3dup set-title-old set-title-new ;
+    [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
 
 M: x11-ui-backend set-fullscreen* ( ? world -- )
     handle>> window>> "XClientMessageEvent" <c-object>

basis/unix/statfs/netbsd/netbsd.factor

@@ -4,5 +4,3 @@ USING: alien.syntax kernel unix.stat math unix
 combinators system io.backend accessors alien.c-types
 io.encodings.utf8 alien.strings unix.types unix.statfs io.files ;
 IN: unix.statfs.netbsd
-
-

basis/x11/glx/glx.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 !
 ! based on glx.h from xfree86, and some of glxtokens.h
-USING: alien alien.c-types alien.syntax alien.syntax.private x11.xlib
+USING: alien alien.c-types alien.syntax x11.xlib
 namespaces make kernel sequences parser words ;
 IN: x11.glx
 

extra/boids/boids.factor

@@ -1,81 +1,44 @@
 
-USING: kernel namespaces
+USING: kernel
-       math
+       namespaces
-       math.constants
+       arrays
-       math.functions
-       math.order
-       math.vectors
-       math.trig
-       math.ranges
-       combinators arrays sequences random vars
-       combinators.lib
-       combinators.short-circuit
        accessors
+       strings
+       sequences
+       locals
+       threads
+       math
+       math.functions
+       math.trig
+       math.order
+       math.ranges
+       math.vectors
+       random
+       calendar
+       opengl.gl
+       opengl
+       ui
+       ui.gadgets
+       ui.gadgets.tracks
+       ui.gadgets.frames
+       ui.gadgets.grids
+       ui.render
+       multi-methods
+       multi-method-syntax
+       combinators.short-circuit.smart       
+       processing.shapes
        flatland ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 IN: boids
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-TUPLE: boid < <vel> ;
-
-C: <boid> boid
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: boids
-VAR: world-size
-VAR: time-slice
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: cohesion-weight
-VAR: alignment-weight
-VAR: separation-weight
-
-VAR: cohesion-view-angle
-VAR: alignment-view-angle
-VAR: separation-view-angle
-
-VAR: cohesion-radius
-VAR: alignment-radius
-VAR: separation-radius
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-variables ( -- )
-  1.0 >cohesion-weight
-  1.0 >alignment-weight
-  1.0 >separation-weight
-
-  75 >cohesion-radius
-  50 >alignment-radius
-  25 >separation-radius
-
-  180 >cohesion-view-angle
-  180 >alignment-view-angle
-  180 >separation-view-angle
-
-  10 >time-slice ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! random-boid and random-boids
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: random-pos ( -- pos ) world-size> [ random ] map ;
-
-: random-vel ( -- vel ) 2 [ drop -10 10 [a,b] random ] map ;
-
-: random-boid ( -- boid ) random-pos random-vel <boid> ;
-
-: random-boids ( n -- boids ) [ drop random-boid ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : constrain ( n a b -- n ) rot min max ;
 
 : angle-between ( vec vec -- angle )
-  2dup v. -rot norm swap norm * / -1 1 constrain acos rad>deg ;
+  [ v. ] [ [ norm ] bi@ * ] 2bi / -1 1 constrain acos rad>deg ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -86,19 +49,47 @@ VAR: separation-radius
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+: in-radius? ( self other radius -- ? ) [ distance       ] dip     <= ;
+: in-view?   ( self other angle  -- ? ) [ relative-angle ] dip 2 / <= ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : vsum ( vector-of-vectors -- vec ) { 0 0 } [ v+ ] reduce ;
 
 : vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ;
 
 : average-position ( boids -- pos ) [ pos>> ] map vaverage ;
-
 : average-velocity ( boids -- vel ) [ vel>> ] map vaverage ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: in-range? ( self other radius -- ? ) >r distance r> <= ;
+TUPLE: <boid> < <vel> ;
 
-: in-view? ( self other angle -- ? ) >r relative-angle r> 2 / <= ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <behaviour>
+  { weight     initial: 1.0 }
+  { view-angle initial: 180 }
+  { radius                  } ;
+
+TUPLE: <cohesion>   < <behaviour> { radius initial: 75 } ;
+TUPLE: <alignment>  < <behaviour> { radius initial: 50 } ;
+TUPLE: <separation> < <behaviour> { radius initial: 25 } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: within-neighborhood? ( SELF OTHER BEHAVIOUR -- ? )
+
+  SELF OTHER
+    {
+      [ BEHAVIOUR radius>>     in-radius? ]
+      [ BEHAVIOUR view-angle>> in-view?   ]
+      [ eq? not                           ]
+    }
+  && ;
+
+:: neighborhood ( SELF OTHERS BEHAVIOUR -- boids )
+  OTHERS [| OTHER | SELF OTHER BEHAVIOUR within-neighborhood? ] filter ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -106,127 +97,264 @@ VAR: separation-radius
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-! average_position(neighbors) - self_position
+GENERIC: force* ( sequence <boid> <behaviour> -- force )
 
-: within-cohesion-neighborhood? ( self other -- ? )
+:: cohesion-force ( OTHERS SELF BEHAVIOUR -- force )
-  { [ cohesion-radius> in-range? ]
+  OTHERS average-position SELF pos>> v- normalize* BEHAVIOUR weight>> v*n ;
-    [ cohesion-view-angle> in-view? ]
-    [ eq? not ] }
-  2&& ;
 
-: cohesion-neighborhood ( self -- boids )
+:: alignment-force ( OTHERS SELF BEHAVIOUR -- force )
-  boids> [ within-cohesion-neighborhood? ] with filter ;
+  OTHERS average-velocity normalize* BEHAVIOUR weight>> v*n ;
 
-: cohesion-force ( self -- force )
+:: separation-force ( OTHERS SELF BEHAVIOUR -- force )
-  dup cohesion-neighborhood
+  SELF pos>> OTHERS average-position v- normalize* BEHAVIOUR weight>> v*n ;
-  dup empty?
+
-  [ 2drop { 0 0 } ]
+METHOD: force* ( sequence <boid> <cohesion>   -- force ) cohesion-force   ;
-  [ average-position swap pos>> v- normalize* cohesion-weight> v*n ]
+METHOD: force* ( sequence <boid> <alignment>  -- force ) alignment-force  ;
+METHOD: force* ( sequence <boid> <separation> -- force ) separation-force ;
+
+:: force ( OTHERS SELF BEHAVIOUR -- force )
+  SELF OTHERS BEHAVIOUR neighborhood
+    [ { 0 0 } ]
+    [ SELF BEHAVIOUR force* ]
+  if-empty ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: random-boids ( count -- boids )
+  [
+    drop
+    <boid> new
+      2 [ drop         1000 random ] map >>pos
+      2 [ drop -10 10 [a,b] random ] map >>vel
+  ]
+  map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: draw-boid ( boid -- )
+  glPushMatrix
+    dup pos>> gl-translate-2d
+        vel>> first2 rect> arg rad>deg 0 0 1 glRotated
+    { { 0 5 } { 0 -5 } { 20 0 } } triangle
+    fill-mode
+  glPopMatrix ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gadget->sky ( gadget -- sky ) { 0 0 } swap dim>> <rectangle> boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax
+
+TUPLE: <boids-gadget> < gadget paused boids behaviours time-slice ;
+
+M:  <boids-gadget> pref-dim*    ( <boids-gadget> -- dim ) drop { 600 400 } ;
+M:  <boids-gadget> ungraft*     ( <boids-gadget> --     ) t >>paused drop  ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <boids-gadget> draw-gadget* ( BOIDS-GADGET -- )
+
+  [let | SKY        [ BOIDS-GADGET gadget->sky   ]
+         BOIDS      [ BOIDS-GADGET boids>>       ]
+         TIME-SLICE [ BOIDS-GADGET time-slice>>  ]
+         BEHAVIOURS [ BOIDS-GADGET behaviours>>  ] |
+
+    BOIDS
+
+      [| SELF |
+
+        [wlet | force-due-to [| BEHAVIOUR | BOIDS SELF BEHAVIOUR force ] |
+
+          ! F = m a. M is 1. So F = a.
+            
+          [let | ACCEL [ BEHAVIOURS [ force-due-to ] map vsum ] |
+
+            [let | POS [ SELF pos>> SELF vel>> TIME-SLICE v*n v+ ]
+                   VEL [ SELF vel>> ACCEL      TIME-SLICE v*n v+ ] |
+
+              [let | POS [ POS SKY wrap   ]
+                     VEL [ VEL normalize* ] |
+                    
+                T{ <boid> f POS VEL } ] ] ] ]
+
+      ]
+      
+    map
+
+    BOIDS-GADGET (>>boids)
+
+    origin get
+      [ BOIDS-GADGET boids>> [ draw-boid ] each ]
+    with-translation ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-boids-thread ( GADGET -- )
+  GADGET f >>paused drop
+  [
+    [
+      GADGET paused>>
+        [ f ]
+        [ GADGET relayout-1 25 milliseconds sleep t ]
+      if
+    ]
+    loop
+  ]
+  in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: default-behaviours ( -- seq )
+  { <cohesion> <alignment> <separation> } [ new ] map ;
+
+: boids-gadget ( -- gadget )
+  <boids-gadget> new-gadget
+    100 random-boids   >>boids
+    default-behaviours >>behaviours
+    10                 >>time-slice
+    t                  >>clipped? ;
+
+: run-boids ( -- ) boids-gadget dup "Boids" open-window start-boids-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: math.parser
+       ui.gadgets.labels
+       ui.gadgets.buttons
+       ui.gadgets.packs ;
+
+: truncate-number ( n -- n ) 10 * round 10 / ;
+
+:: make-behaviour-control ( NAME BEHAVIOUR -- gadget )
+  [let | NAME-LABEL  [ NAME           <label> reverse-video-theme ]
+         VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
+
+    [wlet | update-value-label [ ! ( -- )
+              BEHAVIOUR weight>> truncate-number number>string
+              VALUE-LABEL
+              set-label-string ] |
+
+      update-value-label
+      
+    <pile> 1 >>fill
+      { 1 0 } <track>
+        NAME-LABEL  0.5 track-add
+        VALUE-LABEL 0.5 track-add
+      add-gadget
+      
+      "+0.1"
+      [
+        drop
+        BEHAVIOUR [ 0.1 + ] change-weight drop
+        update-value-label
+      ]
+      <bevel-button> add-gadget
+      
+      "-0.1"
+      [
+        drop
+        BEHAVIOUR weight>> 0.1 >
+        [
+          BEHAVIOUR [ 0.1 - ] change-weight drop
+          update-value-label
+        ]
+        when
+      ]
+      <bevel-button> add-gadget ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: make-population-control ( BOIDS-GADGET -- gadget )
+  [let | VALUE-LABEL [ 20 32 <string> <label> reverse-video-theme ] |
+
+    [wlet | update-value-label [ ( -- )
+              BOIDS-GADGET boids>> length number>string
+              VALUE-LABEL
+              set-label-string ] |
+
+      update-value-label
+      
+      <pile> 1 >>fill
+    
+        { 1 0 } <track>
+          "Population: " <label> reverse-video-theme 0.5 track-add
+          VALUE-LABEL                                0.5 track-add
+        add-gadget
+
+        "Add 10"
+        [
+          drop
+          BOIDS-GADGET
+            BOIDS-GADGET boids>> 10 random-boids append
+          >>boids
+          drop
+          update-value-label
+        ]
+        <bevel-button>
+        add-gadget
+
+        "Sub 10"
+        [
+          drop
+          BOIDS-GADGET boids>> length 10 >
+          [
+            BOIDS-GADGET
+              BOIDS-GADGET boids>> 10 tail
+            >>boids
+            drop
+            update-value-label
+          ]
+          when
+        ]
+        <bevel-button>
+        add-gadget ] ] ( gadget -- gadget ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: pause-toggle ( BOIDS-GADGET -- )
+  BOIDS-GADGET paused>>
+    [ BOIDS-GADGET start-boids-thread ]
+    [ BOIDS-GADGET t >>paused drop    ]
   if ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+:: randomize-boids ( BOIDS-GADGET -- )
+  BOIDS-GADGET   BOIDS-GADGET boids>> length random-boids   >>boids drop ;
 
-! self_position - average_position(neighbors)
+: boids-app ( -- )
 
-: within-separation-neighborhood? ( self other -- ? )
+  [let | BOIDS-GADGET [ boids-gadget ] |
-  { [ separation-radius> in-range? ]
-    [ separation-view-angle> in-view? ]
-    [ eq? not ] }
-  2&& ;
 
-: separation-neighborhood ( self -- boids )
+    <frame>
-  boids> [ within-separation-neighborhood? ] with filter ;
 
-: separation-force ( self -- force )
+      <shelf>
-  dup separation-neighborhood
+
-  dup empty?
+        1 >>fill
-  [ 2drop { 0 0 } ]
+
-  [ average-position swap pos>> swap v- normalize* separation-weight> v*n ]
+        "Pause" [ drop BOIDS-GADGET pause-toggle ] <bevel-button> add-gadget
-  if ;
+
+        "Randomize"
+        [ drop BOIDS-GADGET randomize-boids ] <bevel-button> add-gadget
+
+        BOIDS-GADGET make-population-control add-gadget
+    
+        "Cohesion:   " BOIDS-GADGET behaviours>> first  make-behaviour-control 
+        "Alignment:  " BOIDS-GADGET behaviours>> second make-behaviour-control
+        "Separation: " BOIDS-GADGET behaviours>> third  make-behaviour-control
+
+        [ add-gadget ] tri@
+
+      @top grid-add
+
+      BOIDS-GADGET @center grid-add
+
+    "Boids" open-window
+
+    BOIDS-GADGET start-boids-thread ] ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-! average_velocity(neighbors)
+: boids-main ( -- ) [ boids-app ] with-ui ;
-
-: within-alignment-neighborhood? ( self other -- ? )
-  { [ alignment-radius> in-range? ]
-    [ alignment-view-angle> in-view? ]
-    [ eq? not ] }
-  2&& ;
-
-: alignment-neighborhood ( self -- boids )
-  boids> [ within-alignment-neighborhood? ] with filter ;
-
-: alignment-force ( self -- force )
-  alignment-neighborhood
-  dup empty?
-  [ drop { 0 0 } ]
-  [ average-velocity normalize* alignment-weight> v*n ]
-  if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! F = m a
-!
-! We let m be equal to 1 so then this is simply: F = a
-
-: acceleration ( boid -- acceleration )
-  { separation-force alignment-force cohesion-force } map-exec-with vsum ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! iterate-boid
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: world-width ( -- w ) world-size> first ;
-
-: world-height ( -- w ) world-size> second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: below? ( n a b -- ? ) drop < ;
-
-: above? ( n a b -- ? ) nip > ;
-
-: wrap ( n a b -- n )
-  {
-    { [ 3dup below? ] [ 2nip     ] }
-    { [ 3dup above? ] [ drop nip ] }
-    { [ t           ] [ 2drop    ] }
-  }
-  cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: wrap-x ( x -- x ) 0 world-width 1- wrap ;
-
-: wrap-y ( y -- y ) 0 world-height 1- wrap ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: new-pos ( boid -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ;
-
-: new-vel ( boid -- vel )
-  [ vel>> ] [ acceleration time-slice> v*n ] bi v+ normalize* ;
-
-: wrap-pos ( pos -- pos ) { [ wrap-x ] [ wrap-y ] } parallel-call ;
-
-: iterate-boid ( self -- self ) [ new-pos wrap-pos ] [ new-vel ] bi <boid> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: iterate-boids ( -- ) boids> [ iterate-boid ] map >boids ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-boids ( -- ) 100 random-boids >boids ;
-
-: init-world-size ( -- ) { 100 100 } >world-size ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: randomize ( -- ) boids> length random-boids >boids ;
-
-: inc* ( variable -- ) dup  get 0.1 +  0 1 constrain  swap set ;
-
-: dec* ( variable -- ) dup  get 0.1 -  0 1 constrain  swap set ;
 
+MAIN: boids-main

extra/boids/ui/authors.txt

@@ -1 +0,0 @@
-Eduardo Cavazos

extra/boids/ui/deploy.factor

@@ -1,15 +0,0 @@
-USING: tools.deploy.config ;
-H{
-    { deploy-math? t }
-    { deploy-word-props? f }
-    { deploy-c-types? f }
-    { deploy-ui? t }
-    { deploy-io 2 }
-    { deploy-threads? t }
-    { deploy-word-defs? f }
-    { deploy-compiler? t }
-    { deploy-unicode? f }
-    { deploy-name "Boids" }
-    { "stop-after-last-window?" t }
-    { deploy-reflection 1 }
-}

extra/boids/ui/tags.txt

@@ -1 +0,0 @@
-demos

extra/boids/ui/ui.factor

@@ -1,176 +0,0 @@
-
-USING: combinators.short-circuit kernel namespaces
-       math
-       math.trig
-       math.functions
-       math.vectors
-       math.parser
-       hashtables sequences threads
-       colors
-       opengl
-       opengl.gl
-       ui
-       ui.gadgets
-       ui.gadgets.handler
-       ui.gadgets.slate
-       ui.gadgets.theme
-       ui.gadgets.frames
-       ui.gadgets.labels
-       ui.gadgets.buttons
-       ui.gadgets.packs
-       ui.gadgets.grids
-       ui.gestures
-       assocs.lib vars rewrite-closures boids accessors
-       math.geometry.rect
-       newfx
-       processing.shapes ;
-
-IN: boids.ui
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! draw-boid
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-boid ( boid -- )
-  glPushMatrix
-    dup pos>> gl-translate-2d
-        vel>> first2 rect> arg rad>deg 0 0 1 glRotated
-    { { 0 5 } { 0 -5 } { 20 0 } } triangle
-    fill-mode
-  glPopMatrix ;
-
-: draw-boids ( -- ) boids> [ draw-boid ] each ;
-
-: boid-color ( -- color ) T{ rgba f 1.0 0 0 0.3 } ;
-
-: display ( -- )
-  boid-color >fill-color
-  draw-boids ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: slate
-
-VAR: loop
-
-: run ( -- )
-  slate> rect-dim >world-size
-  iterate-boids
-  slate> relayout-1
-  yield
-  loop> [ run ] when ;
-
-: button* ( string quot -- button ) closed-quot <bevel-button> ;
-
-: toggle-loop ( -- ) loop> [ loop off ] [ loop on [ run ] in-thread ] if ;
-
-VARS: population-label cohesion-label alignment-label separation-label ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: update-population-label ( -- )
-  "Population: " boids> length number>string append
-  20 32 pad-right population-label> set-label-string ;
-
-: add-10-boids ( -- )
-  boids> 10 random-boids append >boids update-population-label ;
-
-: sub-10-boids ( -- )
-  boids> 10 tail >boids update-population-label ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: truncate-value ( n -- n ) 10 * round 10 / ;
-
-: update-cohesion-label ( -- )
-  "Cohesion: " cohesion-weight> truncate-value number>string append
-  20 32 pad-right cohesion-label> set-label-string ;
-
-: update-alignment-label ( -- )
-  "Alignment: " alignment-weight> truncate-value number>string append
-  20 32 pad-right alignment-label> set-label-string ;
-
-: update-separation-label ( -- )
-  "Separation: " separation-weight> truncate-value number>string append
-  20 32 pad-right separation-label> set-label-string ;
-
-: inc-cohesion-weight ( -- ) cohesion-weight inc* update-cohesion-label ;
-: dec-cohesion-weight ( -- ) cohesion-weight dec* update-cohesion-label ;
-
-: inc-alignment-weight ( -- ) alignment-weight inc* update-alignment-label ;
-: dec-alignment-weight ( -- ) alignment-weight dec* update-alignment-label ;
-
-: inc-separation-weight ( -- ) separation-weight inc* update-separation-label ;
-: dec-separation-weight ( -- ) separation-weight dec* update-separation-label ;
-
-: boids-window* ( -- )
-  init-variables init-world-size init-boids loop on
-
-  "" <label> reverse-video-theme >population-label update-population-label
-  "" <label> reverse-video-theme >cohesion-label   update-cohesion-label
-  "" <label> reverse-video-theme >alignment-label  update-alignment-label
-  "" <label> reverse-video-theme >separation-label update-separation-label
-
-  <frame>
-
-    <shelf>
-
-       1 >>fill
-
-      "ESC - Pause" [ drop toggle-loop ] button* add-gadget
-    
-      "1 - Randomize" [ drop randomize ] button* add-gadget
-    
-      <pile> 1 >>fill
-        population-label> add-gadget
-        "3 - Add 10" [ drop add-10-boids ] button* add-gadget
-        "2 - Sub 10" [ drop sub-10-boids ] button* add-gadget
-      add-gadget
-    
-      <pile> 1 >>fill
-        cohesion-label> add-gadget
-        "q - +0.1" [ drop inc-cohesion-weight ] button* add-gadget
-        "a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget
-      add-gadget
-
-      <pile> 1 >>fill
-        alignment-label> add-gadget
-        "w - +0.1" [ drop inc-alignment-weight ] button* add-gadget
-        "s - -0.1" [ drop dec-alignment-weight ] button* add-gadget
-      add-gadget
-
-      <pile> 1 >>fill
-        separation-label> add-gadget
-        "e - +0.1" [ drop inc-separation-weight ] button* add-gadget
-        "d - -0.1" [ drop dec-separation-weight ] button* add-gadget
-      add-gadget
-
-    @top grid-add
-
-    C[ display ] <slate>
-      dup                    >slate
-      t                      >>clipped?
-      { 600 400 }            >>pdim
-      C[ [ run ] in-thread ] >>graft
-      C[ loop off ]          >>ungraft
-    @center grid-add
-
-  <handler> 
-    H{ } clone
-      T{ key-down f f "1"   } C[ drop randomize             ] is
-      T{ key-down f f "2"   } C[ drop sub-10-boids          ] is
-      T{ key-down f f "3"   } C[ drop add-10-boids          ] is
-      T{ key-down f f "q"   } C[ drop inc-cohesion-weight   ] is
-      T{ key-down f f "a"   } C[ drop dec-cohesion-weight   ] is
-      T{ key-down f f "w"   } C[ drop inc-alignment-weight  ] is
-      T{ key-down f f "s"   } C[ drop dec-alignment-weight  ] is
-      T{ key-down f f "e"   } C[ drop inc-separation-weight ] is
-      T{ key-down f f "d"   } C[ drop dec-separation-weight ] is
-      T{ key-down f f "ESC" } C[ drop toggle-loop           ] is
-    >>table
-
-  "Boids" open-window ;
-
-: boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;
-
-MAIN: boids-window

extra/contributors/contributors.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io.files io.launcher io.styles io.encodings.ascii io
+USING: io.files io.launcher io.styles io.encodings.ascii
-hashtables kernel sequences sequences.lib assocs system sorting
+prettyprint io hashtables kernel sequences assocs system sorting
 math.parser sets ;
 IN: contributors
 
@@ -16,15 +16,8 @@ IN: contributors
     { } map>assoc ;
 
 : contributors ( -- )
-    changelog patch-counts sort-values <reversed>
+    changelog patch-counts
-    standard-table-style [
+    sort-values <reversed>
-        [
+    simple-table. ;
-            [
-                first2 swap
-                [ write ] with-cell
-                [ number>string write ] with-cell
-            ] with-row
-        ] each
-    ] tabular-output ;
 
 MAIN: contributors

extra/flatland/flatland.factor

@@ -176,3 +176,45 @@ METHOD: height ( <extent> -- height ) \\ top>>   bottom>> bi - ;
 ! METHOD: to-extent ( <rectangle> -- <extent> )
 !   { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: to-the-left-of?  ( sequence <rectangle> -- ? ) \\ x left  bi* < ;
+METHOD: to-the-right-of? ( sequence <rectangle> -- ? ) \\ x right bi* > ;
+
+METHOD: below? ( sequence <rectangle> -- ? ) \\ y bottom bi* < ;
+METHOD: above? ( sequence <rectangle> -- ? ) \\ y top    bi* > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Some support for the' 'rect' class from math.geometry.rect'
+
+! METHOD: width  ( rect -- width  ) dim>> first  ;
+! METHOD: height ( rect -- height ) dim>> second ;
+
+! METHOD: left  ( rect -- left  ) loc>> x
+! METHOD: right ( rect -- right ) [ loc>> x ] [ width ] bi + ;
+
+! METHOD: to-the-left-of?  ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* < ;
+! METHOD: to-the-right-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: locals combinators ; 
+
+:: wrap ( POINT RECT -- POINT )
+    
+  {
+      { [ POINT RECT to-the-left-of?  ] [ RECT right ] }
+      { [ POINT RECT to-the-right-of? ] [ RECT left  ] }
+      { [ t                           ] [ POINT x    ] }
+  }
+  cond
+
+  {
+      { [ POINT RECT below? ] [ RECT top    ] }
+      { [ POINT RECT above? ] [ RECT bottom ] }
+      { [ t                 ] [ POINT y     ] }
+  }
+  cond
+
+  2array ;

extra/webapps/ip/ip.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors furnace.actions http.server
-http.server.dispatchers html.forms io.servers.connection
+http.server.dispatchers html.forms io.sockets
 namespaces prettyprint ;
 IN: webapps.ip