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

db4
Aaron Schaefer 2008-12-01 17:29:36 -05:00
commit 0ef3ff4058
32 changed files with 540 additions and 511 deletions

View File

@ -201,10 +201,10 @@ M: byte-array byte-length length ;
1 swap malloc-array ; inline 1 swap malloc-array ; inline
: malloc-byte-array ( byte-array -- alien ) : malloc-byte-array ( byte-array -- alien )
dup length dup malloc [ -rot memcpy ] keep ; dup length [ nip malloc dup ] 2keep memcpy ;
: memory>byte-array ( alien len -- byte-array ) : memory>byte-array ( alien len -- byte-array )
dup <byte-array> [ -rot memcpy ] keep ; [ nip <byte-array> dup ] 2keep memcpy ;
: byte-array>memory ( byte-array base -- ) : byte-array>memory ( byte-array base -- )
swap dup length memcpy ; swap dup length memcpy ;

View File

@ -38,7 +38,7 @@ C-UNION: barx
[ 120 ] [ "barx" heap-size ] unit-test [ 120 ] [ "barx" heap-size ] unit-test
"help" vocab [ "help" vocab [
"help" "help" lookup "help" set "print-topic" "help" lookup "help" set
[ ] [ \ foox-x "help" get execute ] unit-test [ ] [ \ foox-x "help" get execute ] unit-test
[ ] [ \ set-foox-x "help" get execute ] unit-test [ ] [ \ set-foox-x "help" get execute ] unit-test
] when ] when

View File

@ -59,9 +59,9 @@ SYMBOL: bootstrap-time
"math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global "math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
"" "exclude" set-global "" "exclude" set-global
parse-command-line (command-line) parse-command-line
"-no-crossref" cli-args member? [ do-crossref ] unless do-crossref
! Set dll paths ! Set dll paths
os wince? [ "windows.ce" require ] when os wince? [ "windows.ce" require ] when
@ -92,12 +92,7 @@ SYMBOL: bootstrap-time
[ [
boot boot
do-init-hooks do-init-hooks
[ handle-command-line
parse-command-line
run-user-init
"run" get run
output-stream get [ stream-flush ] when*
] [ print-error 1 exit ] recover
] set-boot-quot ] set-boot-quot
millis swap - bootstrap-time set-global millis swap - bootstrap-time set-global

View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2007 Slava Pestov ! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel cocoa cocoa.messages cocoa.classes USING: kernel cocoa cocoa.messages cocoa.classes
cocoa.application sequences splitting core-foundation ; cocoa.application sequences splitting core-foundation ;
@ -29,6 +29,6 @@ IN: cocoa.dialogs
"/" split1-last [ <NSString> ] bi@ ; "/" split1-last [ <NSString> ] bi@ ;
: save-panel ( path -- paths ) : save-panel ( path -- paths )
<NSSavePanel> dup [ <NSSavePanel> dup ] dip
rot split-path -> runModalForDirectory:file: NSOKButton = split-path -> runModalForDirectory:file: NSOKButton =
[ -> filename CF>string ] [ drop f ] if ; [ -> filename CF>string ] [ drop f ] if ;

View File

@ -160,7 +160,7 @@ objc>alien-types get [ swap ] assoc-map
assoc-union alien>objc-types set-global assoc-union alien>objc-types set-global
: objc-struct-type ( i string -- ctype ) : objc-struct-type ( i string -- ctype )
2dup CHAR: = -rot index-from swap subseq [ CHAR: = ] 2keep index-from swap subseq
dup c-types get key? [ dup c-types get key? [
"Warning: no such C type: " write dup print "Warning: no such C type: " write dup print
drop "void*" drop "void*"

View File

@ -34,5 +34,6 @@ IN: cocoa.windows
dup 0 -> setReleasedWhenClosed: ; dup 0 -> setReleasedWhenClosed: ;
: window-content-rect ( window -- rect ) : window-content-rect ( window -- rect )
NSWindow over -> frame rot -> styleMask [ NSWindow ] dip
[ -> frame ] [ -> styleMask ] bi
-> contentRectForFrameRect:styleMask: ; -> contentRectForFrameRect:styleMask: ;

View File

@ -1,4 +1,5 @@
USING: help.markup help.syntax parser vocabs.loader strings ; USING: help.markup help.syntax parser vocabs.loader strings
command-line.private ;
IN: command-line IN: command-line
HELP: run-bootstrap-init HELP: run-bootstrap-init
@ -7,7 +8,10 @@ HELP: run-bootstrap-init
HELP: run-user-init HELP: run-user-init
{ $description "Runs the startup initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-rc" } " on Unix and " { $snippet "factor-rc" } " on Windows." } ; { $description "Runs the startup initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-rc" } " on Unix and " { $snippet "factor-rc" } " on Windows." } ;
HELP: cli-param HELP: load-vocab-roots
{ $description "Loads the newline-separated list of additional vocabulary roots from the file named " { $snippet ".factor-roots" } " on Unix and " { $snippet "factor-roots" } " on Windows." } ;
HELP: param
{ $values { "param" string } } { $values { "param" string } }
{ $description "Process a command-line switch." { $description "Process a command-line switch."
$nl $nl
@ -17,10 +21,13 @@ $nl
$nl $nl
"Otherwise, sets the global variable named by the parameter to " { $link t } "." } ; "Otherwise, sets the global variable named by the parameter to " { $link t } "." } ;
HELP: cli-args HELP: (command-line)
{ $values { "args" "a sequence of strings" } } { $values { "args" "a sequence of strings" } }
{ $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ; { $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ;
HELP: command-line
{ $var-description "The command line parameters which follow the name of the script on the command line." } ;
HELP: main-vocab-hook HELP: main-vocab-hook
{ $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ; { $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ;
@ -35,9 +42,6 @@ HELP: ignore-cli-args?
{ $values { "?" "a boolean" } } { $values { "?" "a boolean" } }
{ $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ; { $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ;
HELP: parse-command-line
{ $description "Called on startup to process command line arguments. This sets global variables with " { $link cli-param } ", runs source files, and evaluates the string given by the " { $snippet "-e" } " switch, if there is one." } ;
ARTICLE: "runtime-cli-args" "Command line switches for the VM" ARTICLE: "runtime-cli-args" "Command line switches for the VM"
"A handful of command line switches are processed by the VM and not the library. They control low-level features." "A handful of command line switches are processed by the VM and not the library. They control low-level features."
{ $table { $table
@ -64,9 +68,12 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
} }
"Bootstrap can load various optional components:" "Bootstrap can load various optional components:"
{ $table { $table
{ { $snippet "math" } "Rational and complex number support." }
{ { $snippet "threads" } "Thread support." }
{ { $snippet "compiler" } "The compiler." } { { $snippet "compiler" } "The compiler." }
{ { $snippet "tools" } "Terminal-based developer tools." } { { $snippet "tools" } "Terminal-based developer tools." }
{ { $snippet "help" } "The help system." } { { $snippet "help" } "The help system." }
{ { $snippet "help.handbook" } "The help handbook." }
{ { $snippet "ui" } "The graphical user interface." } { { $snippet "ui" } "The graphical user interface." }
{ { $snippet "ui.tools" } "Graphical developer tools." } { { $snippet "ui.tools" } "Graphical developer tools." }
{ { $snippet "io" } "Non-blocking I/O and networking." } { { $snippet "io" } "Non-blocking I/O and networking." }
@ -86,7 +93,6 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage"
{ { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link POSTPONE: MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } ", " { $vocab-link "ui" } " or " { $vocab-link "none" } "." } } { { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link POSTPONE: MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } ", " { $vocab-link "ui" } " or " { $vocab-link "none" } "." } }
{ { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } } { { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } }
{ { $snippet "-quiet" } { "If set, " { $link run-file } " and " { $link require } " will not print load messages." } } { { $snippet "-quiet" } { "If set, " { $link run-file } " and " { $link require } " will not print load messages." } }
{ { $snippet "-script" } { "Equivalent to " { $snippet "-quiet -run=none" } "." $nl "On Unix systems, Factor can be used for scripting - just create an executable text file whose first line is:" { $code "#! /usr/local/bin/factor -script" } "The space after " { $snippet "#!" } " is necessary because of Factor syntax." } }
} ; } ;
ARTICLE: "factor-boot-rc" "Bootstrap initialization file" ARTICLE: "factor-boot-rc" "Bootstrap initialization file"
@ -102,11 +108,18 @@ $nl
"A word to run this file from an existing Factor session:" "A word to run this file from an existing Factor session:"
{ $subsection run-user-init } ; { $subsection run-user-init } ;
ARTICLE: "factor-roots" "Additional vocabulary roots file"
"The vocabulary roots file is named " { $snippet "factor-roots" } " on Windows and " { $snippet ".factor-roots" } " on Unix. If it exists, it is loaded every time Factor starts. It contains a newline-separated list of " { $link "vocabs.roots" } "."
$nl
"A word to run this file from an existing Factor session:"
{ $subsection load-vocab-roots } ;
ARTICLE: "rc-files" "Running code on startup" ARTICLE: "rc-files" "Running code on startup"
"Factor looks for two files in your home directory." "Factor looks for three optional files in your home directory."
{ $subsection "factor-boot-rc" } { $subsection "factor-boot-rc" }
{ $subsection "factor-rc" } { $subsection "factor-rc" }
"The " { $snippet "-no-user-init" } " command line switch will inhibit the running of these files." { $subsection "factor-roots" }
"The " { $snippet "-no-user-init" } " command line switch will inhibit loading running of these files."
$nl $nl
"If you are unsure where the files should be located, evaluate the following code:" "If you are unsure where the files should be located, evaluate the following code:"
{ $code { $code
@ -122,8 +135,16 @@ $nl
"100 dpi set-global" "100 dpi set-global"
} ; } ;
ARTICLE: "cli" "Command line usage" ARTICLE: "cli" "Command line arguments"
"Zero or more command line arguments may be passed to the Factor runtime. Command line arguments starting with a dash (" { $snippet "-" } ") is interpreted as switches. All other arguments are taken to be file names to be run by " { $link run-file } "." "Factor command line usage:"
{ $code "factor [system switches...] [script args...]" }
"Zero or more system switches can be passed in, followed by an optional script file name. If the script file is specified, it will be run on startup, any arguments after the script file are stored in a variable, with no further processing by Factor itself:"
{ $subsection command-line }
"Instead of running a script, it is also possible to run a vocabulary; this invokes the vocabulary's " { $link POSTPONE: MAIN: } " word:"
{ $code "factor [system switches...] -run=<vocab name>" }
"If no script file or " { $snippet "-run=" } " switch is specified, Factor will start " { $link "listener" } " or " { $link "ui-tools" } ", depending on the operating system."
$nl
"As stated above, arguments in the first part of the command line, before the optional script name, are interpreted by to the Factor system. These arguments all start with a dash (" { $snippet "-" } ")."
$nl $nl
"Switches can take one of the following three forms:" "Switches can take one of the following three forms:"
{ $list { $list
@ -134,9 +155,9 @@ $nl
{ $subsection "runtime-cli-args" } { $subsection "runtime-cli-args" }
{ $subsection "bootstrap-cli-args" } { $subsection "bootstrap-cli-args" }
{ $subsection "standard-cli-args" } { $subsection "standard-cli-args" }
"The list of command line arguments can be obtained and inspected directly:" "The raw list of command line arguments can also be obtained and inspected directly:"
{ $subsection cli-args } { $subsection (command-line) }
"There is a way to override the default vocabulary to run on startup:" "There is a way to override the default vocabulary to run on startup, if no script name or " { $snippet "-run" } " switch is specified:"
{ $subsection main-vocab-hook } ; { $subsection main-vocab-hook } ;
ABOUT: "cli" ABOUT: "cli"

View File

@ -1,12 +0,0 @@
USING: namespaces tools.test kernel command-line ;
IN: command-line.tests
[
[ f ] [ "-no-user-init" cli-arg ] unit-test
[ f ] [ "user-init" get ] unit-test
[ f ] [ "-user-init" cli-arg ] unit-test
[ t ] [ "user-init" get ] unit-test
[ "sdl.factor" ] [ "sdl.factor" cli-arg ] unit-test
] with-scope

View File

@ -1,10 +1,15 @@
! Copyright (C) 2003, 2008 Slava Pestov. ! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: init continuations debugger hashtables io kernel USING: init continuations debugger hashtables io
kernel.private namespaces parser sequences strings system io.encodings.utf8 io.files kernel kernel.private namespaces
splitting io.files eval ; parser sequences strings system splitting eval vocabs.loader ;
IN: command-line IN: command-line
SYMBOL: script
SYMBOL: command-line
: (command-line) ( -- args ) 10 getenv sift ;
: rc-path ( name -- path ) : rc-path ( name -- path )
os windows? [ "." prepend ] unless os windows? [ "." prepend ] unless
home prepend-path ; home prepend-path ;
@ -19,17 +24,33 @@ IN: command-line
"factor-rc" rc-path ?run-file "factor-rc" rc-path ?run-file
] when ; ] when ;
: cli-var-param ( name value -- ) swap set-global ; : load-vocab-roots ( -- )
"user-init" get [
"factor-roots" rc-path dup exists? [
utf8 file-lines [ add-vocab-root ] each
] [ drop ] if
] when ;
: cli-bool-param ( name -- ) "no-" ?head not cli-var-param ; <PRIVATE
: cli-param ( param -- ) : var-param ( name value -- ) swap set-global ;
"=" split1 [ cli-var-param ] [ cli-bool-param ] if* ;
: cli-arg ( argument -- argument ) : bool-param ( name -- ) "no-" ?head not var-param ;
"-" ?head [ cli-param f ] when ;
: cli-args ( -- args ) 10 getenv ; : param ( param -- )
"=" split1 [ var-param ] [ bool-param ] if* ;
: run-script ( file -- )
t "quiet" set-global run-file ;
PRIVATE>
: parse-command-line ( args -- )
[ command-line off script off ] [
unclip "-" ?head
[ param parse-command-line ]
[ script set command-line set ] if
] if-empty ;
SYMBOL: main-vocab-hook SYMBOL: main-vocab-hook
@ -53,14 +74,17 @@ SYMBOL: main-vocab-hook
: ignore-cli-args? ( -- ? ) : ignore-cli-args? ( -- ? )
os macosx? "run" get "ui" = and ; os macosx? "run" get "ui" = and ;
: script-mode ( -- ) : script-mode ( -- ) ;
t "quiet" set-global
"none" "run" set-global ;
: parse-command-line ( -- ) : handle-command-line ( -- )
cli-args [ cli-arg ] filter [
"script" get [ script-mode ] when (command-line) parse-command-line
ignore-cli-args? [ drop ] [ [ run-file ] each ] if load-vocab-roots
"e" get [ eval ] when* ; run-user-init
"e" get [ eval ] when*
ignore-cli-args? not script get and
[ run-script ] [ "run" get run ] if*
output-stream get [ stream-flush ] when*
] [ print-error 1 exit ] recover ;
[ default-cli-args ] "command-line" add-init-hook [ default-cli-args ] "command-line" add-init-hook

View File

@ -4,7 +4,7 @@ USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces make assocs init accessors math sequences namespaces make assocs init accessors
continuations combinators core-foundation continuations combinators core-foundation
core-foundation.run-loop core-foundation.run-loop.thread core-foundation.run-loop core-foundation.run-loop.thread
io.encodings.utf8 destructors ; io.encodings.utf8 destructors locals arrays ;
IN: core-foundation.fsevents IN: core-foundation.fsevents
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline : kFSEventStreamCreateFlagUseCFTypes 2 ; inline
@ -105,15 +105,14 @@ FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef
"FSEventStreamContext" <c-object> "FSEventStreamContext" <c-object>
[ set-FSEventStreamContext-info ] keep ; [ set-FSEventStreamContext-info ] keep ;
: <FSEventStream> ( callback info paths latency flags -- event-stream ) :: <FSEventStream> ( callback info paths latency flags -- event-stream )
>r >r >r >r >r
f ! allocator f ! allocator
r> ! callback callback
r> make-FSEventStreamContext info make-FSEventStreamContext
r> <CFStringArray> ! paths paths <CFStringArray>
FSEventStreamEventIdSinceNow ! sinceWhen FSEventStreamEventIdSinceNow ! sinceWhen
r> ! latency latency
r> ! flags flags
FSEventStreamCreate ; FSEventStreamCreate ;
: kCFRunLoopCommonModes ( -- string ) : kCFRunLoopCommonModes ( -- string )
@ -161,13 +160,11 @@ SYMBOL: event-stream-callbacks
: remove-event-source-callback ( id -- ) : remove-event-source-callback ( id -- )
event-stream-callbacks get delete-at ; event-stream-callbacks get delete-at ;
: >event-triple ( n eventPaths eventFlags eventIds -- triple ) :: >event-triple ( n eventPaths eventFlags eventIds -- triple )
[ n eventPaths void*-nth utf8 alien>string
>r >r >r dup dup n eventFlags int-nth
r> void*-nth utf8 alien>string , n eventIds longlong-nth
r> int-nth , 3array ;
r> longlong-nth ,
] { } make ;
: master-event-source-callback ( -- alien ) : master-event-source-callback ( -- alien )
"void" "void"

View File

@ -307,7 +307,7 @@ FUNCTION: bool check_sse2 ( ) ;
: sse2? ( -- ? ) : sse2? ( -- ? )
check_sse2 ; check_sse2 ;
"-no-sse2" cli-args member? [ "-no-sse2" (command-line) member? [
[ optimized-recompile-hook ] recompile-hook [ optimized-recompile-hook ] recompile-hook
[ { check_sse2 } compile ] with-variable [ { check_sse2 } compile ] with-variable

View File

@ -36,7 +36,7 @@ M: tuple-class group-words
: define-consult ( group class quot -- ) : define-consult ( group class quot -- )
[ register-protocol ] [ register-protocol ]
[ rot group-words -rot [ consult-method ] 2curry each ] [ [ group-words ] 2dip [ consult-method ] 2curry each ]
3bi ; 3bi ;
: CONSULT: : CONSULT:

View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax io kernel math namespaces parser USING: help.markup help.syntax io kernel math namespaces parser
prettyprint sequences vocabs.loader namespaces stack-checker prettyprint sequences vocabs.loader namespaces stack-checker
help ; help command-line multiline ;
IN: help.cookbook IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook" ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
@ -263,11 +263,30 @@ ARTICLE: "cookbook-application" "Application cookbook"
ARTICLE: "cookbook-scripts" "Scripting cookbook" ARTICLE: "cookbook-scripts" "Scripting cookbook"
"Factor can be used for command-line scripting on Unix-like systems." "Factor can be used for command-line scripting on Unix-like systems."
$nl $nl
"A text file can begin with a comment like the following, and made executable:" "To run a script, simply pass it as an argument to the Factor executable:"
{ $code "#! /usr/bin/env factor -script" } { $code "./factor cleanup.factor" }
"Running the text file will run it through Factor, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "." "The script may access command line arguments by inspecting the value of the " { $link command-line } " variable. It can also get its own path from the " { $link script } " variable."
$nl $nl
"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch suppresses compiler messages, and exits Factor when the script finishes." "Here is an example implementing a simplified version of the Unix " { $snippet "ls" } " command in Factor:"
{ $code
<" USING: command-line namespaces io io.files io.files.listing
sequences kernel ;
command-line get [
current-directory get directory.
] [
dup length 1 = [ first directory. ] [
[ [ nl write ":" print ] [ directory. ] bi ] each
] if
] if-empty">
}
"You can put it in a file named " { $snippet "ls.factor" } ", and then run it, to list the " { $snippet "/usr/bin" } " directory for example:"
{ $code "./factor ls.factor /usr/bin" }
"It is also possible to make executable scripts. A Factor file can begin with a comment like the following:"
{ $code "#! /usr/bin/env factor" }
"If the text file is made executable, then it can be run, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "."
$nl
"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result."
{ $references { $references
{ } { }
"cli" "cli"

View File

@ -49,10 +49,8 @@ SYMBOL: +editable+
] [ keys ] if ; ] [ keys ] if ;
: describe* ( obj mirror keys -- ) : describe* ( obj mirror keys -- )
rot summary. [ summary. ] 2dip
[ [ drop ] [
drop
] [
dup enum? [ +sequence+ on ] when dup enum? [ +sequence+ on ] when
standard-table-style [ standard-table-style [
swap [ -rot describe-row ] curry each-index swap [ -rot describe-row ] curry each-index

View File

@ -19,7 +19,7 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
FD_SETSIZE 8 * <bit-array> >>write-fdset ; FD_SETSIZE 8 * <bit-array> >>write-fdset ;
: clear-nth ( n seq -- ? ) : clear-nth ( n seq -- ? )
[ nth ] [ f -rot set-nth ] 2bi ; [ nth ] [ [ f ] 2dip set-nth ] 2bi ;
:: check-fd ( fd fdset mx quot -- ) :: check-fd ( fd fdset mx quot -- )
fd munge fdset clear-nth [ fd mx quot call ] when ; inline fd munge fdset clear-nth [ fd mx quot call ] when ; inline

View File

@ -114,7 +114,7 @@ SYMBOL: receive-buffer
] call ; ] call ;
M: unix (receive) ( datagram -- packet sockaddr ) M: unix (receive) ( datagram -- packet sockaddr )
dup do-receive dup [ rot drop ] [ dup do-receive dup [ [ drop ] 2dip ] [
2drop [ +input+ wait-for-port ] [ (receive) ] bi 2drop [ +input+ wait-for-port ] [ (receive) ] bi
] if ; ] if ;

View File

@ -14,8 +14,8 @@ M: complex imaginary-part imaginary>> ;
M: complex absq >rect [ sq ] bi@ + ; M: complex absq >rect [ sq ] bi@ + ;
: 2>rect ( x y -- xr yr xi yi ) : 2>rect ( x y -- xr yr xi yi )
[ [ real-part ] bi@ ] 2keep [ [ real-part ] bi@ ]
[ imaginary-part ] bi@ ; inline [ [ imaginary-part ] bi@ ] 2bi ; inline
M: complex hashcode* M: complex hashcode*
nip >rect [ hashcode ] bi@ bitxor ; nip >rect [ hashcode ] bi@ bitxor ;
@ -28,21 +28,21 @@ M: complex equal?
M: complex number= M: complex number=
2>rect number= [ number= ] [ 2drop f ] if ; 2>rect number= [ number= ] [ 2drop f ] if ;
: *re ( x y -- xr*yr xi*ri ) 2>rect * >r * r> ; inline : *re ( x y -- xr*yr xi*ri ) 2>rect [ * ] 2bi@ ; inline
: *im ( x y -- xi*yr xr*yi ) 2>rect >r * swap r> * ; inline : *im ( x y -- xi*yr xr*yi ) 2>rect [ * swap ] dip * ; inline
M: complex + 2>rect + >r + r> (rect>) ; M: complex + 2>rect [ + ] 2bi@ (rect>) ;
M: complex - 2>rect - >r - r> (rect>) ; M: complex - 2>rect [ - ] 2bi@ (rect>) ;
M: complex * 2dup *re - -rot *im + (rect>) ; M: complex * [ *re - ] [ *im + ] 2bi (rect>) ;
: complex/ ( x y -- r i m ) : complex/ ( x y -- r i m )
dup absq >r 2dup *re + -rot *im - r> ; inline [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline
M: complex / complex/ tuck / >r / r> (rect>) ; M: complex / complex/ tuck [ / ] 2bi@ (rect>) ;
M: complex abs absq >float fsqrt ; M: complex abs absq >float fsqrt ;
M: complex sqrt >polar swap fsqrt swap 2.0 / polar> ; M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ;
IN: syntax IN: syntax

View File

@ -92,16 +92,6 @@ PRIVATE>
: 0^ ( x -- z ) : 0^ ( x -- z )
dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
PRIVATE>
: ^ ( x y -- z )
{
{ [ over zero? ] [ nip 0^ ] }
{ [ dup integer? ] [ integer^ ] }
{ [ 2dup real^? ] [ fpow ] }
[ ^complex ]
} cond ; inline
: (^mod) ( n x y -- z ) : (^mod) ( n x y -- z )
1 swap [ 1 swap [
[ dupd * pick mod ] when [ sq over mod ] dip [ dupd * pick mod ] when [ sq over mod ] dip
@ -114,6 +104,16 @@ PRIVATE>
swap [ /mod [ over * swapd - ] dip ] keep (gcd) swap [ /mod [ over * swapd - ] dip ] keep (gcd)
] if ; ] if ;
PRIVATE>
: ^ ( x y -- z )
{
{ [ over zero? ] [ nip 0^ ] }
{ [ dup integer? ] [ integer^ ] }
{ [ 2dup real^? ] [ fpow ] }
[ ^complex ]
} cond ; inline
: gcd ( x y -- a d ) : gcd ( x y -- a d )
[ 0 1 ] 2dip (gcd) dup 0 < [ neg ] when ; foldable [ 0 1 ] 2dip (gcd) dup 0 < [ neg ] when ; foldable
@ -177,9 +177,9 @@ M: complex log >polar swap flog swap rect> ;
GENERIC: cos ( x -- y ) foldable GENERIC: cos ( x -- y ) foldable
M: complex cos M: complex cos
>float-rect 2dup >float-rect
fcosh swap fcos * -rot [ [ fcos ] [ fcosh ] bi* * ]
fsinh swap fsin neg * rect> ; [ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ;
M: real cos fcos ; M: real cos fcos ;
@ -188,9 +188,9 @@ M: real cos fcos ;
GENERIC: cosh ( x -- y ) foldable GENERIC: cosh ( x -- y ) foldable
M: complex cosh M: complex cosh
>float-rect 2dup >float-rect
fcos swap fcosh * -rot [ [ fcosh ] [ fcos ] bi* * ]
fsin swap fsinh * rect> ; [ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ;
M: real cosh fcosh ; M: real cosh fcosh ;
@ -199,9 +199,9 @@ M: real cosh fcosh ;
GENERIC: sin ( x -- y ) foldable GENERIC: sin ( x -- y ) foldable
M: complex sin M: complex sin
>float-rect 2dup >float-rect
fcosh swap fsin * -rot [ [ fsin ] [ fcosh ] bi* * ]
fsinh swap fcos * rect> ; [ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ;
M: real sin fsin ; M: real sin fsin ;
@ -210,9 +210,9 @@ M: real sin fsin ;
GENERIC: sinh ( x -- y ) foldable GENERIC: sinh ( x -- y ) foldable
M: complex sinh M: complex sinh
>float-rect 2dup >float-rect
fcos swap fsinh * -rot [ [ fsinh ] [ fcos ] bi* * ]
fsin swap fcosh * rect> ; [ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
M: real sinh fsinh ; M: real sinh fsinh ;

View File

@ -22,9 +22,9 @@ INSTANCE: range immutable-sequence
: twiddle 2dup > -1 1 ? ; inline : twiddle 2dup > -1 1 ? ; inline
: (a, dup roll + -rot ; inline : (a, dup [ + ] curry 2dip ; inline
: ,b) dup neg rot + swap ; inline : ,b) dup [ - ] curry dip ; inline
: [a,b] ( a b -- range ) twiddle <range> ; inline : [a,b] ( a b -- range ) twiddle <range> ; inline

View File

@ -54,7 +54,6 @@ TR: convert-separators "/\\" ".." ;
[ monitor-thread ] "Vocabulary monitor" spawn drop ; [ monitor-thread ] "Vocabulary monitor" spawn drop ;
[ [
"-no-monitors" cli-args member? [ "-no-monitors" (command-line) member?
start-monitor-thread [ start-monitor-thread ] unless
] unless
] "tools.vocabs.monitor" add-init-hook ] "tools.vocabs.monitor" add-init-hook

View File

@ -110,8 +110,8 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
swap [ swapd set-at ] curry assoc-each ; swap [ swapd set-at ] curry assoc-each ;
: assoc-union ( assoc1 assoc2 -- union ) : assoc-union ( assoc1 assoc2 -- union )
2dup [ assoc-size ] bi@ + pick new-assoc [ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
[ rot update ] keep [ swap update ] keep ; [ dupd update ] bi@ ;
: assoc-combine ( seq -- union ) : assoc-combine ( seq -- union )
H{ } clone [ dupd update ] reduce ; H{ } clone [ dupd update ] reduce ;

View File

@ -23,7 +23,7 @@ PREDICATE: intersection-class < class
M: intersection-class update-class define-intersection-predicate ; M: intersection-class update-class define-intersection-predicate ;
: define-intersection-class ( class participants -- ) : define-intersection-class ( class participants -- )
[ f f rot intersection-class define-class ] [ [ f f ] dip intersection-class define-class ]
[ drop update-classes ] [ drop update-classes ]
2bi ; 2bi ;

View File

@ -248,7 +248,9 @@ M: tuple-class update-class
3bi ; 3bi ;
: tuple-class-unchanged? ( class superclass slots -- ? ) : tuple-class-unchanged? ( class superclass slots -- ? )
rot tuck [ superclass = ] [ "slots" word-prop = ] 2bi* and ; [ over ] dip
[ [ superclass ] dip = ]
[ [ "slots" word-prop ] dip = ] 2bi* and ;
: valid-superclass? ( class -- ? ) : valid-superclass? ( class -- ? )
[ tuple-class? ] [ tuple eq? ] bi or ; [ tuple-class? ] [ tuple eq? ] bi or ;

View File

@ -12,12 +12,12 @@ ARTICLE: "vocabs.roots" "Vocabulary roots"
{ { $snippet "extra" } " - additional contributed libraries." } { { $snippet "extra" } " - additional contributed libraries." }
{ { $snippet "work" } " - a root for vocabularies which are not intended to be contributed back to Factor." } { { $snippet "work" } " - a root for vocabularies which are not intended to be contributed back to Factor." }
} }
"Your own vocabularies should go into " { $snippet "extra" } " or " { $snippet "work" } ", depending on whether or not you intend to contribute them back to the Factor project. If you wish to work on vocabularies outside of the Factor source directory, create a " { $link "factor-boot-rc" } " file like the following:" "You can store your own vocabularies in the " { $snippet "work" } " directory. You can also store code outside of the Factor source tree by making Factor aware of it first. There are two ways of doing this."
{ $code $nl
"USING: namespaces sequences vocabs.loader ;" "You can list additional vocabulary roots in a file that Factor reads at startup:"
"\"/home/jane/sources/\" vocab-roots get push" { $subsection "factor-roots" }
} "Or you can add them dynamically using a word:"
"See " { $link "rc-files" } " for details." ; { $subsection add-vocab-root } ;
ARTICLE: "vocabs.loader" "Vocabulary loader" ARTICLE: "vocabs.loader" "Vocabulary loader"
"The vocabulary loader is defined in the " { $vocab-link "vocabs.loader" } " vocabulary." "The vocabulary loader is defined in the " { $vocab-link "vocabs.loader" } " vocabulary."
@ -57,6 +57,11 @@ HELP: vocab-main
HELP: vocab-roots HELP: vocab-roots
{ $var-description "A sequence of pathname strings to search for vocabularies." } ; { $var-description "A sequence of pathname strings to search for vocabularies." } ;
HELP: add-vocab-root
{ $values { "path" "a pathname string" } }
{ $description "Adds a directory pathname to the list of vocabulary roots." }
{ $see-also "factor-roots" } ;
HELP: find-vocab-root HELP: find-vocab-root
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } } { $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
{ $description "Searches for a vocabulary in the vocabulary roots." } ; { $description "Searches for a vocabulary in the vocabulary roots." } ;

View File

@ -3,7 +3,7 @@
USING: namespaces make sequences io.files kernel assocs words USING: namespaces make sequences io.files kernel assocs words
vocabs definitions parser continuations io hashtables sorting vocabs definitions parser continuations io hashtables sorting
source-files arrays combinators strings system math.parser source-files arrays combinators strings system math.parser
compiler.errors splitting init accessors ; compiler.errors splitting init accessors sets ;
IN: vocabs.loader IN: vocabs.loader
SYMBOL: vocab-roots SYMBOL: vocab-roots
@ -15,6 +15,9 @@ V{
"resource:work" "resource:work"
} clone vocab-roots set-global } clone vocab-roots set-global
: add-vocab-root ( root -- )
vocab-roots get adjoin ;
: vocab-dir ( vocab -- dir ) : vocab-dir ( vocab -- dir )
vocab-name { { CHAR: . CHAR: / } } substitute ; vocab-name { { CHAR: . CHAR: / } } substitute ;

View File

@ -221,7 +221,7 @@ M: word subwords drop f ;
"( gensym )" f <word> ; "( gensym )" f <word> ;
: define-temp ( quot -- word ) : define-temp ( quot -- word )
gensym dup rot define ; [ gensym dup ] dip define ;
: reveal ( word -- ) : reveal ( word -- )
dup [ name>> ] [ vocabulary>> ] bi dup vocab-words dup [ name>> ] [ vocabulary>> ] bi dup vocab-words

View File

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

View File

@ -1 +0,0 @@
Eduardo Cavazos

View File

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

View File

@ -1 +0,0 @@
demos

View File

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

View File

@ -176,3 +176,45 @@ METHOD: height ( <extent> -- height ) \\ top>> bottom>> bi - ;
! METHOD: to-extent ( <rectangle> -- <extent> ) ! METHOD: to-extent ( <rectangle> -- <extent> )
! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ; ! { [ 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 ;