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

Conflicts:
	basis/unix/statfs/netbsd/netbsd.factor
db4
Doug Coleman 2008-12-01 14:07:56 -06:00
commit 72db24ad65
82 changed files with 745 additions and 784 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -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?
[ >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 <synchronous> dup r> send
[ synchronous-reply? ] curry receive-if
[ <synchronous> dup ] dip send
'[ _ synchronous-reply? ] receive-if
data>>
] if ;

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -15,9 +15,10 @@ HOOK: (pipe) io-backend ( -- pipe )
: <pipe> ( encoding -- stream )
[
>r (pipe) |dispose
[ in>> <input-port> ] [ out>> <output-port> ] bi
r> <encoder-duplex>
[
(pipe) |dispose
[ 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*
r> with-streams*
[ [ ?reader ] [ ?writer ] bi* ] dip 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
r> run-pipeline-element
[ [ first in>> ] [ second out>> ] bi ] dip
run-pipeline-element
] 2parallel-map ;
{

View File

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

View File

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

View File

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

View File

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

View File

@ -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 rot world>NSRect <ViewWindow>
dup install-window-delegate
over -> release
<handle>
] keep (>>handle) ;
dup <FactorView>
2dup swap world>NSRect <ViewWindow>
[ [ -> release ] [ install-window-delegate ] bi* ] [ <handle> ] 2bi
>>handle drop ;
M: cocoa-ui-backend set-title ( string world -- )
handle>> window>> swap <NSString> -> setTitle: ;

View File

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

View File

@ -77,18 +77,22 @@ IN: ui.cocoa.views
dup event-modifiers swap button ;
: send-button-down$ ( view event -- )
[ mouse-event>gesture <button-down> ]
[ mouse-location rot window send-button-down ] 2bi ;
[ nip mouse-event>gesture <button-down> ]
[ mouse-location ]
[ drop window ]
2tri send-button-down ;
: send-button-up$ ( view event -- )
[ mouse-event>gesture <button-up> ] 2keep
mouse-location rot window send-button-up ;
[ nip mouse-event>gesture <button-up> ]
[ 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
<rect> ;
[ [ [ NSRect-x ] [ NSRect-y ] bi ] [ dim>> second ] bi* swap - 2array ]
[ drop [ NSRect-w ] [ NSRect-h ] bi 2array ]
2bi <rect> ;
: rect>NSRect ( rect world -- NSRect )
over rect-loc first2 rot rect-dim second swap -
rot rect-dim first2 <NSRect> ;
[ [ rect-loc first2 ] [ dim>> second ] bi* swap - ]
[ 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
dup remove-observer
SUPER-> dealloc
[ unregister-window ]
[ remove-observer ]
[ SUPER-> dealloc ]
tri
]
} ;

View File

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

View File

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

View File

@ -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." } ;

View File

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

View File

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

View File

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

View File

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

View File

@ -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
swap >>content
dup content>> @center grid-add ;
[
[ closable-gadget new-frame ] dip
[ >>content ] [ @center grid-add ] bi
] 2dip
<title-bar> @top grid-add ;
M: closable-gadget focusable-child* content>> ;

View File

@ -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 } }
{ $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 <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"

View File

@ -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-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 -- )
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 [ <menu-glass> ] keep show-glass ;
: show-menu ( owner menu -- )
[ 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 )
dup command-name -rot command-button-quot
swapd
[ hand-clicked get find-world hide-glass ]
3append <roll-button> ;
:: <menu-item> ( target hook command -- button )
command command-name [
hook call
target command command-button-quot call
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 ;

View File

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

View File

@ -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
: <shelf> ( -- pack ) { 1 0 } <pack> ;
: 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 ;

View File

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

View File

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

View File

@ -36,12 +36,13 @@ M: presentation ungraft*
call-next-method ;
: <operations-menu> ( presentation -- menu )
dup dup hook>> curry
swap object>>
dup object-operations <commands-menu> ;
[ object>> ]
[ dup hook>> curry ]
[ 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 ] }

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -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 )
[ 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" <c-object>
over first over set-RECT-right
swap second over set-RECT-bottom

View File

@ -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 [ <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
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" <c-object>

View File

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

View File

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

View File

@ -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 < <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-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 <boid> <cohesion> -- force ) cohesion-force ;
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 -- ? )
{ [ separation-radius> in-range? ]
[ separation-view-angle> in-view? ]
[ eq? not ] }
2&& ;
[let | BOIDS-GADGET [ boids-gadget ] |
: separation-neighborhood ( self -- boids )
boids> [ within-separation-neighborhood? ] with filter ;
<frame>
: separation-force ( self -- force )
dup separation-neighborhood
dup empty?
[ 2drop { 0 0 } ]
[ average-position swap pos>> swap v- normalize* separation-weight> v*n ]
if ;
<shelf>
1 >>fill
"Pause" [ drop BOIDS-GADGET pause-toggle ] <bevel-button> add-gadget
"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)
: 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 ;
: boids-main ( -- ) [ boids-app ] with-ui ;
MAIN: boids-main

View File

@ -1 +0,0 @@
Eduardo Cavazos

View File

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

View File

@ -1 +0,0 @@
demos

View File

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

View File

@ -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
hashtables kernel sequences sequences.lib assocs system sorting
USING: io.files io.launcher io.styles io.encodings.ascii
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>
standard-table-style [
[
[
first2 swap
[ write ] with-cell
[ number>string write ] with-cell
] with-row
] each
] tabular-output ;
changelog patch-counts
sort-values <reversed>
simple-table. ;
MAIN: contributors

View File

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

View File

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