diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor new file mode 100644 index 0000000000..193893fabc --- /dev/null +++ b/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* ; + +: 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 ; diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor index 880c6f8413..17294aed87 100644 --- a/basis/alien/structs/fields/fields.factor +++ b/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 -- ) - rot offset>> prefix define-inline ; +: define-struct-slot-word ( word quot spec -- ) + 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 ; diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor index 37cbd12801..586bb97402 100644 --- a/basis/alien/syntax/syntax-docs.factor +++ b/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" } } diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 3a45edd03f..a204b1621c 100644 --- a/basis/alien/syntax/syntax.factor +++ b/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 - ; - -: 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 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 diff --git a/basis/cocoa/pasteboard/pasteboard.factor b/basis/cocoa/pasteboard/pasteboard.factor index d266c2452f..9302097adf 100644 --- a/basis/cocoa/pasteboard/pasteboard.factor +++ b/basis/cocoa/pasteboard/pasteboard.factor @@ -20,7 +20,7 @@ IN: cocoa.pasteboard : set-pasteboard-string ( str pasteboard -- ) NSStringPboardType dup 1array pick set-pasteboard-types - >r swap r> -> setString:forType: drop ; + [ swap ] dip -> setString:forType: drop ; : pasteboard-error ( error -- f ) "Pasteboard does not hold a string" diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index fd18c7fa89..40f21d25b8 100644 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/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 ; diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index d03688b2be..cd113b5c64 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -74,7 +74,7 @@ PRIVATE> -> autorelease ; : ( class dim -- view ) - >r -> alloc 0 0 r> first2 + [ -> alloc 0 0 ] dip first2 -> 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: - dup NSPoint-x swap NSPoint-y - r> -> frame NSRect-h swap - 2array ; + [ + -> locationInWindow f -> convertPoint:fromView: + [ NSPoint-x ] [ NSPoint-y ] bi + ] [ drop -> frame NSRect-h ] 2bi + swap - 2array ; USE: opengl.gl USE: alien.syntax diff --git a/basis/compiler/alien/alien.factor b/basis/compiler/alien/alien.factor index e414d6e29b..4a41014ab2 100644 --- a/basis/compiler/alien/alien.factor +++ b/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. diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index f0b8279cb4..2161c8b091 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/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 - r> '[ alloc-parameter _ execute ] each-parameter ; - inline + [ alien-parameters flatten-value-types ] + [ '[ alloc-parameter _ execute ] ] + bi* 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 ) diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index 06abec5968..0302218652 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/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 - add-dlsym-literals - r> r> rt-dlsym rel-fixup ; + [ literal-table get length [ add-dlsym-literals ] dip ] dip + 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 ; diff --git a/basis/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor index 43374d3127..11e624110c 100644 --- a/basis/concurrency/conditions/conditions.factor +++ b/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 - t swap resume-with - ] 2curry r> later ; + [ + [ self swap push-front* ] keep '[ + _ _ + [ 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 ; diff --git a/basis/concurrency/count-downs/count-downs.factor b/basis/concurrency/count-downs/count-downs.factor index c4bc92c688..d79cfbf1c9 100644 --- a/basis/concurrency/count-downs/count-downs.factor +++ b/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 ; diff --git a/basis/concurrency/distributed/distributed-tests.factor b/basis/concurrency/distributed/distributed-tests.factor index 528e1956b8..1087823aa0 100644 --- a/basis/concurrency/distributed/distributed-tests.factor +++ b/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 diff --git a/basis/concurrency/exchangers/exchangers.factor b/basis/concurrency/exchangers/exchangers.factor index 6b44886eda..97b3c14fe4 100644 --- a/basis/concurrency/exchangers/exchangers.factor +++ b/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 ; diff --git a/basis/concurrency/flags/flags-tests.factor b/basis/concurrency/flags/flags-tests.factor index 0f78183aba..a666293316 100644 --- a/basis/concurrency/flags/flags-tests.factor +++ b/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 [ ] | [ 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 [ ] | 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 [ ] | [ 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 [ ] | [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop f wait-for-flag diff --git a/basis/concurrency/flags/flags.factor b/basis/concurrency/flags/flags.factor index ec260961d0..c65171a3f0 100644 --- a/basis/concurrency/flags/flags.factor +++ b/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 ; diff --git a/basis/concurrency/futures/futures.factor b/basis/concurrency/futures/futures.factor index 132342aff1..a1f4f57af6 100644 --- a/basis/concurrency/futures/futures.factor +++ b/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 ) [ - [ [ >r call r> fulfill ] 2curry "Future" ] keep + [ '[ @ _ fulfill ] "Future" ] keep mailbox>> spawn-linked-to drop ] keep ; inline diff --git a/basis/concurrency/locks/locks-tests.factor b/basis/concurrency/locks/locks-tests.factor index 7696e6c1eb..8f82aa88ba 100644 --- a/basis/concurrency/locks/locks-tests.factor +++ b/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 ] | @@ -27,7 +27,7 @@ threads sequences calendar accessors ; v ] ; -:: lock-test-1 ( -- ) +:: lock-test-1 ( -- v ) [let | v [ V{ } clone ] l [ ] c [ 2 ] | @@ -79,7 +79,7 @@ threads sequences calendar accessors ; [ ] [ dup [ [ ] with-read-lock ] with-write-lock ] unit-test -:: rw-lock-test-1 ( -- ) +:: rw-lock-test-1 ( -- v ) [let | l [ ] c [ 1 ] c' [ 1 ] @@ -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 [ ] c [ 1 ] c' [ 2 ] @@ -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 [ ] | [ 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 [ ] | - [ - l [ 1 seconds sleep ] with-lock - ] "Lock holder" spawn drop - - [ - l 1/10 seconds [ ] with-lock-timeout - ] "Lock timeout-er" spawn-linked drop - - receive - ] ; - [ dup [ 1 seconds [ ] with-write-lock-timeout diff --git a/basis/concurrency/locks/locks.factor b/basis/concurrency/locks/locks.factor index 8c1392dbfb..0094f3323d 100644 --- a/basis/concurrency/locks/locks.factor +++ b/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 -- ) - >r >r pick rot r> call ! use up timeout acquire - swap r> curry [ ] cleanup ; inline +:: do-lock ( lock timeout quot acquire release -- ) + lock timeout acquire call + 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 -- ) diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index 39b21e0943..63707041a2 100644 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/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 [ ] [ supervisor>> ] bi mailbox-put ; : ( quot name mailbox -- thread' ) - >r linked-thread new-thread r> >>supervisor ; + [ linked-thread new-thread ] dip >>supervisor ; : spawn-linked-to ( quot name mailbox -- thread ) [ (spawn) ] keep ; diff --git a/basis/concurrency/messaging/messaging-docs.factor b/basis/concurrency/messaging/messaging-docs.factor index 6c9e530d9b..25538cd594 100644 --- a/basis/concurrency/messaging/messaging-docs.factor +++ b/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\"" diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index 9aeb24ed72..7a00f62e9e 100644 --- a/basis/concurrency/messaging/messaging.factor +++ b/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 r> send ; + [ ] 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? - [ >r tag>> r> tag>> = ] - [ 2drop f ] if ; + over reply? [ [ tag>> ] bi@ = ] [ 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 dup r> send - [ synchronous-reply? ] curry receive-if + [ dup ] dip send + '[ _ synchronous-reply? ] receive-if data>> ] if ; diff --git a/basis/concurrency/promises/promises.factor b/basis/concurrency/promises/promises.factor index 382697e04f..2ff338c4e3 100644 --- a/basis/concurrency/promises/promises.factor +++ b/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 ; diff --git a/basis/concurrency/semaphores/semaphores.factor b/basis/concurrency/semaphores/semaphores.factor index 1b55c7afa5..59518f4c8d 100644 --- a/basis/concurrency/semaphores/semaphores.factor +++ b/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 -- ) - pick rot acquire-timeout swap - [ release ] curry [ ] cleanup ; inline +:: with-semaphore-timeout ( semaphore timeout quot -- ) + semaphore timeout acquire-timeout + quot [ semaphore release ] [ ] cleanup ; inline : with-semaphore ( semaphore quot -- ) - over acquire swap [ release ] curry [ ] cleanup ; inline + swap dup acquire '[ _ release ] [ ] cleanup ; inline diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index c51c3783d4..05fe3a8093 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/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 ; diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index a120c8437d..dcff476166 100644 --- a/basis/dlists/dlists.factor +++ b/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>> - f rot (>>next) - f over set-prev-when - swap (>>front) + [ + [ empty-dlist ] unless* + [ f ] change-next drop + f over set-prev-when + ] 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>> - f rot (>>prev) - f over set-next-when - swap (>>back) + [ + [ empty-dlist ] unless* + [ f ] change-prev drop + f over set-next-when + ] change-back drop ] keep normalize-front ; diff --git a/basis/furnace/sessions/sessions.factor b/basis/furnace/sessions/sessions.factor index cde95f2831..8b7e1ab83f 100644 --- a/basis/furnace/sessions/sessions.factor +++ b/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 diff --git a/basis/io/pipes/pipes.factor b/basis/io/pipes/pipes.factor index ca4046fe07..3a7fa5a2e0 100644 --- a/basis/io/pipes/pipes.factor +++ b/basis/io/pipes/pipes.factor @@ -15,9 +15,10 @@ HOOK: (pipe) io-backend ( -- pipe ) : ( encoding -- stream ) [ - >r (pipe) |dispose - [ in>> ] [ out>> ] bi - r> + [ + (pipe) |dispose + [ in>> ] [ out>> ] bi + ] dip ] with-destructors ; r [ ?reader ] [ ?writer ] bi* - r> with-streams* + [ [ ?reader ] [ ?writer ] bi* ] dip with-streams* ] with-destructors ; : ( n -- pipes ) @@ -48,8 +48,8 @@ PRIVATE> : run-pipeline ( seq -- results ) [ length dup zero? [ drop { } ] [ 1- ] if ] keep [ - >r [ first in>> ] [ second out>> ] bi - r> run-pipeline-element + [ [ first in>> ] [ second out>> ] bi ] dip + run-pipeline-element ] 2parallel-map ; { diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index d1fb059b77..de95a3a583 100644 --- a/basis/io/unix/files/files.factor +++ b/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 ? -- ) - [ dup stat-mode ] 2dip + +: chmod-set-bit ( path mask ? -- ) + [ 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-EXECUTE OCT: 0000100 ; inline +: USER-WRITE OCT: 0000200 ; inline +: USER-EXECUTE OCT: 0000100 ; inline : GROUP-ALL OCT: 0000070 ; inline -: GROUP-READ OCT: 0000040 ; inline -: GROUP-WRITE OCT: 0000020 ; inline -: GROUP-EXECUTE OCT: 0000010 ; inline +: GROUP-READ OCT: 0000040 ; inline +: GROUP-WRITE OCT: 0000020 ; inline +: GROUP-EXECUTE OCT: 0000010 ; inline : OTHER-ALL OCT: 0000007 ; inline : OTHER-READ OCT: 0000004 ; inline -: OTHER-WRITE OCT: 0000002 ; inline -: OTHER-EXECUTE OCT: 0000001 ; inline +: OTHER-WRITE OCT: 0000002 ; inline +: OTHER-EXECUTE OCT: 0000001 ; inline -GENERIC: uid? ( obj -- ? ) -GENERIC: gid? ( obj -- ? ) -GENERIC: sticky? ( obj -- ? ) -GENERIC: user-read? ( obj -- ? ) -GENERIC: user-write? ( obj -- ? ) -GENERIC: user-execute? ( obj -- ? ) -GENERIC: group-read? ( obj -- ? ) -GENERIC: group-write? ( obj -- ? ) -GENERIC: group-execute? ( obj -- ? ) -GENERIC: other-read? ( obj -- ? ) -GENERIC: other-write? ( obj -- ? ) -GENERIC: other-execute? ( obj -- ? ) +: uid? ( obj -- ? ) UID file-mode? ; +: gid? ( obj -- ? ) GID file-mode? ; +: sticky? ( obj -- ? ) STICKY file-mode? ; +: user-read? ( obj -- ? ) USER-READ file-mode? ; +: user-write? ( obj -- ? ) USER-WRITE file-mode? ; +: user-execute? ( obj -- ? ) USER-EXECUTE file-mode? ; +: group-read? ( obj -- ? ) GROUP-READ file-mode? ; +: group-write? ( obj -- ? ) GROUP-WRITE file-mode? ; +: group-execute? ( obj -- ? ) GROUP-EXECUTE file-mode? ; +: other-read? ( obj -- ? ) OTHER-READ file-mode? ; +: other-write? ( obj -- ? ) OTHER-WRITE file-mode? ; +: 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 ; diff --git a/basis/opengl/gl/extensions/extensions.factor b/basis/opengl/gl/extensions/extensions.factor index 02b1a9a623..ea37829d0e 100644 --- a/basis/opengl/gl/extensions/extensions.factor +++ b/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 - dup r> + [ + [ gl-function-address ] map [ ] find nip + 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 -- ) - [ pick ] dip parse-arglist - rot create-in - [ swapd roll indirect-quot ] 2dip - -rot define-declared ; +:: define-indirect ( abi return function-ptr-quot function-name parameters -- ) + function-name create-in dup reset-generic + function-ptr-quot return + parameters return parse-arglist [ abi indirect-quot ] dip + define-declared ; : GL-FUNCTION: gl-function-calling-convention diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 27936eea1c..74f06ed65b 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -271,9 +271,9 @@ IN: regexp-tests [ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" first-match >string ] unit-test -[ t ] [ "a:b" ".+:?" matches? ] unit-test +! [ t ] [ "a:b" ".+:?" matches? ] unit-test -[ 1 ] [ "hello" ".+?" match length ] unit-test +! [ 1 ] [ "hello" ".+?" 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)" first-match ] unit-test [ "a" ] [ "ac" "a(?!b)" first-match >string ] unit-test -[ t ] [ "fxxbar" "(?!foo).{3}bar" matches? ] unit-test +! [ t ] [ "fxxbar" "(?!foo).{3}bar" matches? ] unit-test [ f ] [ "foobar" "(?!foo).{3}bar" matches? ] unit-test [ "a" ] [ "ab" "a(?=b)(?=b)" first-match >string ] unit-test [ "a" ] [ "ba" "a(?<=b)(?<=b)" first-match >string ] unit-test diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor index 7bc7630a40..e3638bd969 100644 --- a/basis/smtp/smtp-tests.factor +++ b/basis/smtp/smtp-tests.factor @@ -1,6 +1,7 @@ -USING: smtp tools.test io.streams.string io.sockets threads -smtp.server kernel sequences namespaces logging accessors -assocs sorting smtp.private concurrency.promises ; +USING: smtp tools.test io.streams.string io.sockets +io.sockets.secure threads smtp.server kernel sequences +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 [ ] [ - [ + f >>verify [ "localhost" "p" get ?promise smtp-server set no-auth smtp-auth set - smtp-tls? on + os unix? [ smtp-tls? on ] when "Hi guys\nBye guys" >>body @@ -91,5 +92,5 @@ IN: smtp.tests } >>to "Doug " >>from send-email - ] with-scope + ] with-secure-context ] unit-test diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index 5d3b8db19d..a9b3b03b75 100644 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -33,16 +33,13 @@ M: pasteboard set-clipboard-contents selection set-global ; : world>NSRect ( world -- NSRect ) - dup window-loc>> first2 rot rect-dim first2 ; + [ window-loc>> ] [ dim>> ] bi [ first2 ] bi@ ; : gadget-window ( world -- ) - [ - dup - dup rot world>NSRect - dup install-window-delegate - over -> release - - ] keep (>>handle) ; + dup + 2dup swap world>NSRect + [ [ -> release ] [ install-window-delegate ] bi* ] [ ] 2bi + >>handle drop ; M: cocoa-ui-backend set-title ( string world -- ) handle>> window>> swap -> setTitle: ; diff --git a/basis/ui/cocoa/views/views-tests.factor b/basis/ui/cocoa/views/views-tests.factor new file mode 100644 index 0000000000..fc64534cfb --- /dev/null +++ b/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 diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor index 1e35fcf4b2..128fdceeb4 100644 --- a/basis/ui/cocoa/views/views.factor +++ b/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 ] - [ mouse-location rot window send-button-down ] 2bi ; + [ nip mouse-event>gesture ] + [ mouse-location ] + [ drop window ] + 2tri send-button-down ; : send-button-up$ ( view event -- ) - [ mouse-event>gesture ] 2keep - mouse-location rot window send-button-up ; + [ nip mouse-event>gesture ] + [ mouse-location ] + [ drop window ] + 2tri send-button-up ; : send-wheel$ ( view event -- ) - [ - dup -> deltaX sgn neg over -> deltaY sgn neg 2array -rot - mouse-location - ] [ drop window ] 2bi send-wheel ; + [ nip [ -> deltaX ] [ -> deltaY ] bi [ sgn neg ] bi@ 2array ] + [ mouse-location ] + [ drop window ] + 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 [ - drop [ gadget-selection? ] [ drop t ] if - ] [ - 3drop f - ] if ; + over string-or-nil? over string-or-nil? and + [ drop [ gadget-selection? ] [ drop t ] if ] [ 3drop f ] if ; : NSRect>rect ( NSRect world -- rect ) - [ dup NSRect-x over NSRect-y ] dip - rect-dim second swap - 2array - over NSRect-w rot NSRect-h 2array - ; + [ [ [ NSRect-x ] [ NSRect-y ] bi ] [ dim>> second ] bi* swap - 2array ] + [ drop [ NSRect-w ] [ NSRect-h ] bi 2array ] + 2bi ; : rect>NSRect ( rect world -- NSRect ) - over rect-loc first2 rot rect-dim second swap - - rot rect-dim first2 ; + [ [ rect-loc first2 ] [ dim>> second ] bi* swap - ] + [ drop rect-dim first2 ] + 2bi ; 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 - dup remove-observer - SUPER-> dealloc + [ unregister-window ] + [ remove-observer ] + [ SUPER-> dealloc ] + tri ] } ; diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor index 41d000af26..a4ef77e661 100644 --- a/basis/ui/freetype/freetype.factor +++ b/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 -- ) - 0 swap 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ; +: set-char-size ( open-font size -- open-font ) + [ dup handle>> 0 ] dip + 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ; -: ( handle -- 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 - ascent>> swap glyph-hori-bearing-y - ft-floor 2array ; + [ drop glyph-hori-bearing-x ft-floor ] + [ ascent>> swap glyph-hori-bearing-y - ft-floor ] + 2bi 2array ; : glyph-texture-size ( glyph -- dim ) [ glyph-bitmap-width next-power-of-2 ] diff --git a/basis/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor index 4a428404c1..086ef2ca81 100644 --- a/basis/ui/gadgets/buttons/buttons-docs.factor +++ b/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 "ui-commands" } ; + +ABOUT: "ui.gadgets.buttons" diff --git a/basis/ui/gadgets/editors/editors-docs.factor b/basis/ui/gadgets/editors/editors-docs.factor index 0cf60ff5e8..d749b8905c 100644 --- a/basis/ui/gadgets/editors/editors-docs.factor +++ b/basis/ui/gadgets/editors/editors-docs.factor @@ -20,22 +20,12 @@ HELP: { $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." } ; diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 46c2bd1d43..ad81d18f92 100644 --- a/basis/ui/gadgets/editors/editors.factor +++ b/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 ; diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor index c3a7216910..01d695c281 100644 --- a/basis/ui/gadgets/gadgets-tests.factor +++ b/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 } } ] [ - { 0 1 } >>orientation - { { 10 20 } } - { { 100 30 } } - orient -] unit-test - \ must-infer \ unparent must-infer \ add-gadget must-infer diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 51c8f07225..baf025d116 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/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 diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor index 386457551f..eab8833120 100644 --- a/basis/ui/gadgets/grids/grids.factor +++ b/basis/ui/gadgets/grids/grids.factor @@ -18,14 +18,14 @@ 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 ) -rot grid-add ; +: grid-remove ( grid i j -- grid ) [ ] 2dip grid-add ; : pref-dim-grid ( grid -- dims ) grid>> [ [ pref-dim ] map ] map ; diff --git a/basis/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor index e4343e6280..108c5ae461 100644 --- a/basis/ui/gadgets/labelled/labelled.factor +++ b/basis/ui/gadgets/labelled/labelled.factor @@ -48,9 +48,10 @@ TUPLE: closable-gadget < frame content ; [ closable-gadget? ] find-parent ; : ( gadget title quot -- gadget ) - closable-gadget new-frame - -rot @top grid-add - swap >>content - dup content>> @center grid-add ; + [ + [ closable-gadget new-frame ] dip + [ >>content ] [ @center grid-add ] bi + ] 2dip + @top grid-add ; M: closable-gadget focusable-child* content>> ; diff --git a/basis/ui/gadgets/menus/menus-docs.factor b/basis/ui/gadgets/menus/menus-docs.factor index 303eb0a13e..d7297217ed 100644 --- a/basis/ui/gadgets/menus/menus-docs.factor +++ b/basis/ui/gadgets/menus/menus-docs.factor @@ -3,9 +3,22 @@ kernel ; IN: ui.gadgets.menus HELP: -{ $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 } } -{ $description "Displays a popup menu in the " { $link world } " containing " { $snippet "owner" } " at the current mouse location." } ; +{ $values { "owner" gadget } { "menu" gadget } } +{ $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 } " 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 } +{ $subsection show-menu } +{ $subsection show-commands-menu } ; + +ABOUT: "ui.gadgets.menus" diff --git a/basis/ui/gadgets/menus/menus.factor b/basis/ui/gadgets/menus/menus.factor index cbcfdb14d8..2aef0b8417 100644 --- a/basis/ui/gadgets/menus/menus.factor +++ b/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 -ui.gadgets.worlds ui.gestures generic hashtables kernel math -models namespaces opengl sequences math.vectors -ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors -math.geometry.rect ; +USING: locals accessors arrays ui.commands ui.gadgets +ui.gadgets.buttons ui.gadgets.worlds ui.gestures generic +hashtables kernel math models namespaces opengl sequences +math.vectors ui.gadgets.theme ui.gadgets.packs +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 world -- 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 -- ) - dup hide-glass - swap [ hand-clicked set-global ] [ >>glass ] bi - dup glass>> add-gadget drop ; +: show-glass ( world gadget -- ) + [ [ hide-glass ] [ hand-clicked set-global ] bi* ] + [ add-gadget drop ] + [ >>glass drop ] + 2tri ; -: show-menu ( gadget owner -- ) - find-world [ ] keep show-glass ; +: show-menu ( owner menu -- ) + [ find-world dup ] dip show-glass ; \ menu-glass H{ { T{ button-down } [ find-world [ hide-glass ] when* ] } { T{ drag } [ update-clicked drop ] } } set-gestures -: ( hook target command -- button ) - dup command-name -rot command-button-quot - swapd - [ hand-clicked get find-world hide-glass ] - 3append ; +:: ( target hook command -- button ) + command command-name [ + hook call + target command command-button-quot call + hand-clicked get find-world hide-glass + ] ; : menu-theme ( gadget -- gadget ) light-gray solid-interior faint-boundary ; -: ( hook target commands -- gadget ) +: ( target hook commands -- menu ) [ ] 3dip - [ add-gadget ] with with each + [ add-gadget ] with with each 5 menu-theme ; + +: show-commands-menu ( target commands -- ) + [ dup [ ] ] dip show-menu ; diff --git a/basis/ui/gadgets/packs/packs-tests.factor b/basis/ui/gadgets/packs/packs-tests.factor index 065267d7be..8b52a2ad2f 100644 --- a/basis/ui/gadgets/packs/packs-tests.factor +++ b/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 } 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 } } + { 0 1 } >>orientation + orient +] unit-test diff --git a/basis/ui/gadgets/packs/packs.factor b/basis/ui/gadgets/packs/packs.factor index 5965e8b568..86dc6ea354 100644 --- a/basis/ui/gadgets/packs/packs.factor +++ b/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 } - { fill initial: 0 } - { gap initial: { 0 0 } } ; +{ align initial: 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 : ( -- pack ) { 1 0 } ; -: gap-dims ( gap sizes -- seeq ) - [ dim-sum ] keep length 1 [-] rot n*v v+ ; +: gap-dims ( sizes gadget -- seeq ) + [ [ dim-sum ] [ length 1 [-] ] bi ] [ gap>> ] bi* n*v v+ ; : pack-pref-dim ( gadget sizes -- dim ) - over gap>> over gap-dims [ max-dim ] dip - rot orientation>> set-axis ; + [ nip max-dim ] + [ swap gap-dims ] + [ drop orientation>> ] + 2tri set-axis ; M: pack pref-dim* dup children>> pref-dims pack-pref-dim ; diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index 9a30cee777..79a47380b6 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/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 -kernel namespaces sequences io.styles strings quotations math -opengl combinators math.vectors sorting splitting -io.streams.nested assocs ui.gadgets.presentations +ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render +hashtables io kernel namespaces sequences io.styles strings +quotations math opengl combinators math.vectors sorting +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 diff --git a/basis/ui/gadgets/paragraphs/paragraphs.factor b/basis/ui/gadgets/paragraphs/paragraphs.factor index 216f21af27..6e26a2989f 100644 --- a/basis/ui/gadgets/paragraphs/paragraphs.factor +++ b/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 -namespaces sequences math.order math.geometry.rect ; +USING: accessors arrays ui.gadgets ui.gadgets.labels ui.render +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 -- ) - dup pref-dim [ - over word-break-gadget? [ - dup first overrun? [ wrap-line ] when - ] unless drop wrap-pos rot call - ] keep first2 advance-y advance-x ; inline +:: wrap-step ( quot child -- ) + child pref-dim + [ + child + [ + 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 ; diff --git a/basis/ui/gadgets/presentations/presentations.factor b/basis/ui/gadgets/presentations/presentations.factor index e39069ed7b..33ef3bbe3a 100644 --- a/basis/ui/gadgets/presentations/presentations.factor +++ b/basis/ui/gadgets/presentations/presentations.factor @@ -36,12 +36,13 @@ M: presentation ungraft* call-next-method ; : ( presentation -- menu ) - dup dup hook>> curry - swap object>> - dup object-operations ; + [ object>> ] + [ dup hook>> curry ] + [ object>> object-operations ] + tri ; : operations-menu ( presentation -- ) - dup swap show-menu ; + dup show-menu ; presentation H{ { T{ button-down f f 3 } [ operations-menu ] } diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 968972a869..9e13e5ad7c 100644 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/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 - over elevator>> rect-dim - rot orientation>> v. min ; + [ + [ [ slider-page ] [ slider-max 1 max ] bi / 1 min ] + [ elevator-length ] bi * min-thumb-dim max + ] + [ [ 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 - rot orientation>> set-axis [ ceiling ] map + [ [ rect-dim ] dip ] [ drop orientation>> ] 2bi set-axis + [ ceiling ] map ] dip (>>dim) ; : layout-thumb ( slider -- ) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 98c3258911..68a2a18210 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/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?>> - over handle>> - rot rect-dim [ 0 > ] all? and and ; + [ active?>> ] [ handle>> ] [ dim>> [ 0 > ] all? ] tri 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? - [ f swap set-global ] [ drop ] if ; + [ get-global find-world eq? ] keep '[ f _ set-global ] when ; diff --git a/basis/ui/operations/operations.factor b/basis/ui/operations/operations.factor index 660ae1f43d..bcfca946dd 100644 --- a/basis/ui/operations/operations.factor +++ b/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 diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index 55b8a82ac1..4ce36dc3bd 100755 --- a/basis/ui/render/render.factor +++ b/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 ) diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor index 5a99d1174b..127269b325 100644 --- a/basis/ui/tools/deploy/deploy.factor +++ b/basis/ui/tools/deploy/deploy.factor @@ -117,5 +117,7 @@ deploy-gadget "toolbar" f { dup com-revert ; : deploy-tool ( vocab -- ) - vocab-name dup 10 - "Deploying \"" rot "\"" 3append open-window ; + vocab-name + [ 10 ] + [ "Deploying \"" swap "\"" 3append ] bi + open-window ; diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor index 0676619b07..51425b124d 100644 --- a/basis/ui/tools/interactor/interactor.factor +++ b/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? [ diff --git a/basis/ui/traverse/traverse.factor b/basis/ui/traverse/traverse.factor index 5135c3da6e..7a012aa3e0 100644 --- a/basis/ui/traverse/traverse.factor +++ b/basis/ui/traverse/traverse.factor @@ -59,15 +59,15 @@ TUPLE: node value children ; DEFER: (gadget-subtree) : traverse-child ( frompath topath gadget -- ) - [ -rot ] keep [ - [ rest-slice ] 2dip traverse-step (gadget-subtree) - ] make-node ; + [ 2nip ] 3keep + [ [ rest-slice ] 2dip traverse-step (gadget-subtree) ] + 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 ] diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index de2df4ee6e..738d259cad 100644 --- a/basis/ui/ui-docs.factor +++ b/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" } ; diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 6e1ce8f77f..cb63833edd 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -296,8 +296,10 @@ SYMBOL: nc-buttons key-modifiers swap message>button [ ] [ ] if ; -: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world ) - [ drop mouse-event>gesture ] dip >lo-hi rot window ; +:: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world ) + 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" over first over set-RECT-right swap second over set-RECT-bottom diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index b9889c75d4..b5c71bc3fb 100644 --- a/basis/ui/x11/x11.factor +++ b/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 - rot mouse-event-loc ; + [ event-modifiers ] + [ XButtonEvent-button ] + [ mouse-event-loc ] + tri ; M: world button-down-event [ mouse-event>gesture [ ] 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 - 3dup set-title-old set-title-new ; + handle>> window>> swap + [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ; M: x11-ui-backend set-fullscreen* ( ? world -- ) handle>> window>> "XClientMessageEvent" diff --git a/basis/unix/statfs/netbsd/netbsd.factor b/basis/unix/statfs/netbsd/netbsd.factor index 30f258ca8d..5617ca7533 100644 --- a/basis/unix/statfs/netbsd/netbsd.factor +++ b/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 - - diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index eefb93772a..7a2012f0ea 100644 --- a/basis/x11/glx/glx.factor +++ b/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 diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index 857abcf5d3..b0d5bda508 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -1,81 +1,44 @@ -USING: kernel namespaces - math - math.constants - math.functions - math.order - math.vectors - math.trig - math.ranges - combinators arrays sequences random vars - combinators.lib - combinators.short-circuit +USING: kernel + namespaces + arrays 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 < ; - -C: 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 ; - -: 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: < ; -: in-view? ( self other angle -- ? ) >r relative-angle r> 2 / <= ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: + { weight initial: 1.0 } + { view-angle initial: 180 } + { radius } ; + +TUPLE: < { radius initial: 75 } ; +TUPLE: < { radius initial: 50 } ; +TUPLE: < { 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 -- force ) -: within-cohesion-neighborhood? ( self other -- ? ) - { [ cohesion-radius> in-range? ] - [ cohesion-view-angle> in-view? ] - [ eq? not ] } - 2&& ; +:: cohesion-force ( OTHERS SELF BEHAVIOUR -- force ) + OTHERS average-position SELF pos>> v- normalize* BEHAVIOUR weight>> v*n ; -: cohesion-neighborhood ( self -- boids ) - boids> [ within-cohesion-neighborhood? ] with filter ; +:: alignment-force ( OTHERS SELF BEHAVIOUR -- force ) + OTHERS average-velocity normalize* BEHAVIOUR weight>> v*n ; -: cohesion-force ( self -- force ) - dup cohesion-neighborhood - dup empty? - [ 2drop { 0 0 } ] - [ average-position swap pos>> v- normalize* cohesion-weight> v*n ] +:: separation-force ( OTHERS SELF BEHAVIOUR -- force ) + SELF pos>> OTHERS average-position v- normalize* BEHAVIOUR weight>> v*n ; + +METHOD: force* ( sequence -- force ) cohesion-force ; +METHOD: force* ( sequence -- force ) alignment-force ; +METHOD: force* ( sequence -- force ) separation-force ; + +:: force ( OTHERS SELF BEHAVIOUR -- force ) + SELF OTHERS BEHAVIOUR neighborhood + [ { 0 0 } ] + [ SELF BEHAVIOUR force* ] + if-empty ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: random-boids ( count -- boids ) + [ + drop + 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>> boa ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax + +TUPLE: < gadget paused boids behaviours time-slice ; + +M: pref-dim* ( -- dim ) drop { 600 400 } ; +M: ungraft* ( -- ) t >>paused drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M:: 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{ 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 ) + { } [ new ] map ; + +: boids-gadget ( -- 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