Merge branch 'master' of git://factorcode.org/git/factor
Conflicts: basis/unix/statfs/netbsd/netbsd.factordb4
Doug Coleman
commit
72db24ad65
basis
alien
cocoa
compiler
alien
codegen
concurrency
conditions
count-downs
distributed
exchangers
futures
mailboxes
promises
semaphores
cpu/x86/assembler
dlists
furnace/sessions
io
pipes
unix/files
opengl/gl/extensions
regexp
ui
freetype
gadgets
buttons
grids
labelled
panes
paragraphs
presentations
sliders
worlds
operations
render
tools
deploy
interactor
traverse
windows
x11
unix/statfs/netbsd
x11/glx
extra
contributors
flatland
webapps/ip
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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\""
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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: ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
]
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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>> ;
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ] }
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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? [
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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" } ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -1 +0,0 @@
|
|||
Eduardo Cavazos
|
||||
|
|
@ -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 }
|
||||
}
|
||||
|
|
@ -1 +0,0 @@
|
|||
demos
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue