steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2008-12-01 13:24:32 -06:00
parent 52c5b53e27 43889cb587
commit 3b14c1970a
6 changed files with 351 additions and 374 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

490
extra/boids/boids.factor
View File

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

1
extra/boids/ui/authors.txt
View File

@ -1 +0,0 @@
Eduardo Cavazos

15
extra/boids/ui/deploy.factor
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 }
}

1
extra/boids/ui/tags.txt
View File

@ -1 +0,0 @@
demos

176
extra/boids/ui/ui.factor
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

42
extra/flatland/flatland.factor
View File

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