--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+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
+ processing.shapes
+ flatland ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IN: boids
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: constrain ( n a b -- n ) rot min max ;
+
+: angle-between ( vec vec -- angle )
+ [ v. ] [ [ norm ] bi@ * ] 2bi / -1 1 constrain acos rad>deg ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ;
+
+: relative-angle ( self other -- angle )
+ over vel>> -rot relative-position angle-between ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <boid> < <vel> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+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 ]
+ }
+ 2&& ;
+
+:: neighborhood ( SELF OTHERS BEHAVIOUR -- boids )
+ OTHERS [| OTHER | SELF OTHER BEHAVIOUR within-neighborhood? ] filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: normalize* ( u -- v ) { 0.001 0.001 } v+ normalize ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: force* ( sequence <boid> <behaviour> -- force )
+
+:: cohesion-force ( OTHERS SELF BEHAVIOUR -- force )
+ OTHERS average-position SELF pos>> v- normalize* BEHAVIOUR weight>> v*n ;
+
+:: alignment-force ( OTHERS SELF BEHAVIOUR -- force )
+ OTHERS average-velocity normalize* BEHAVIOUR 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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-system ( 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) ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <boids-gadget> draw-gadget* ( BOIDS-GADGET -- )
+ origin get
+ [ BOIDS-GADGET boids>> [ draw-boid ] each ]
+ with-translation ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-boids-thread ( GADGET -- )
+ GADGET f >>paused drop
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 1 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 ;
+
+: boids-app ( -- )
+
+ [let | BOIDS-GADGET [ boids-gadget ] |
+
+ <frame>
+
+ <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 ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: boids-main ( -- ) [ boids-app ] with-ui ;
+
+MAIN: boids-main
\ No newline at end of file
--- /dev/null
+Artificial life program simulating simulating the flocking behaviour of birds
--- /dev/null
+
+USING: kernel namespaces combinators
+ ui.gestures accessors ui.gadgets.frame-buffer ;
+
+IN: processing.gadget
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: processing-gadget < frame-buffer button-down button-up key-down key-up ;
+
+: <processing-gadget> ( -- gadget ) processing-gadget new-frame-buffer ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: mouse-pressed-value
+SYMBOL: key-pressed-value
+
+SYMBOL: button-value
+SYMBOL: key-value
+
+: key-pressed? ( -- ? ) key-pressed-value get ;
+: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
+
+: key ( -- key ) key-value get ;
+: button ( -- val ) button-value get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: processing-gadget handle-gesture ( gesture gadget -- ? )
+ swap
+ {
+ {
+ [ dup key-down? ]
+ [
+ sym>> key-value set
+ key-pressed-value on
+ key-down>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ {
+ [ dup key-up? ]
+ [
+ key-pressed-value off
+ drop
+ key-up>> dup [ call ] [ drop ] if
+ t
+ ] }
+ {
+ [ dup button-down? ]
+ [
+ #>> button-value set
+ mouse-pressed-value on
+ button-down>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ {
+ [ dup button-up? ]
+ [
+ mouse-pressed-value off
+ drop
+ button-up>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ { [ t ] [ 2drop t ] }
+ }
+ cond ;
--- /dev/null
+
+USING: kernel arrays sequences math math.order qualified
+ sequences.lib circular processing ui newfx processing.shapes ;
+
+IN: processing.gallery.trails
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Example 33-15 from the Processing book
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: point-list ( n -- seq ) [ drop 0 0 2array ] map <circular> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dot ( pos percent -- ) 1 swap - 25 * 5 max circle ;
+
+: step ( seq -- )
+
+ no-stroke
+ { 1 0.4 } fill
+
+ 0 background
+
+ mouse push-circular
+ [ dot ]
+ each-percent ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: go* ( -- )
+
+ 500 500 size*
+
+ [
+ 100 point-list
+ [ step ]
+ curry
+ draw
+ ] setup
+
+ run ;
+
+: go ( -- ) [ go* ] with-ui ;
+
+MAIN: go
--- /dev/null
+
+USING: kernel namespaces threads combinators sequences arrays
+ math math.functions math.ranges random
+ opengl.gl opengl.glu vars multi-methods generalizations shuffle
+ ui
+ ui.gestures
+ ui.gadgets
+ combinators
+ combinators.lib
+ combinators.cleave
+ rewrite-closures bake bake.fry accessors newfx
+ processing.gadget math.geometry.rect
+ processing.shapes
+ colors ;
+
+IN: processing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
+
+: 1random ( b -- num ) 0 swap 2random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chance ( fraction -- ? ) 0 1 2random > ;
+
+: percent-chance ( percent -- ? ) 100 / chance ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : at-fraction ( seq fraction -- val ) over length 1- * nth-at ;
+
+: at-fraction ( seq fraction -- val ) over length 1- * at ;
+
+: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: canonical-color-value ( obj -- color )
+
+METHOD: canonical-color-value { number } dup dup 1 rgba boa ;
+
+METHOD: canonical-color-value { array }
+ dup length
+ {
+ { 2 [ first2 >r dup dup r> rgba boa ] }
+ { 3 [ first3 1 rgba boa ] }
+ { 4 [ first4 rgba boa ] }
+ }
+ case ;
+
+! METHOD: canonical-color-value { rgba }
+! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave 4array ;
+
+METHOD: canonical-color-value { color } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fill ( value -- ) canonical-color-value >fill-color ;
+: stroke ( value -- ) canonical-color-value >stroke-color ;
+
+! : no-fill ( -- ) 0 fill-color> set-fourth ;
+! : no-stroke ( -- ) 0 stroke-color> set-fourth ;
+
+: no-fill ( -- ) fill-color> 0 >>alpha drop ;
+: no-stroke ( -- ) stroke-color> 0 >>alpha drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: stroke-weight ( w -- ) glLineWidth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
+! GL_POLYGON glBegin
+! glVertex2d
+! glVertex2d
+! glVertex2d
+! glVertex2d
+! glEnd ;
+
+! : quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
+
+! 8 ndup
+
+! GL_FRONT_AND_BACK GL_FILL glPolygonMode
+! fill-color> set-color
+
+! quad-vertices
+
+! GL_FRONT_AND_BACK GL_LINE glPolygonMode
+! stroke-color> set-color
+
+! quad-vertices ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : ellipse-disk ( x y width height -- )
+! glPushMatrix
+! >r >r
+! 0 glTranslated
+! r> r> 1 glScaled
+! gluNewQuadric
+! dup 0 0.5 20 1 gluDisk
+! gluDeleteQuadric
+! glPopMatrix ;
+
+! : ellipse-center ( x y width height -- )
+
+! 4dup
+
+! GL_FRONT_AND_BACK GL_FILL glPolygonMode
+! stroke-color> set-color
+
+! ellipse-disk
+
+! GL_FRONT_AND_BACK GL_FILL glPolygonMode
+! fill-color> set-color
+
+! [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
+
+! ellipse-disk ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! SYMBOL: CENTER
+! SYMBOL: RADIUS
+! SYMBOL: CORNER
+! SYMBOL: CORNERS
+
+! SYMBOL: ellipse-mode-value
+
+! : ellipse-mode ( val -- ) ellipse-mode-value set ;
+
+! : ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ;
+
+! : ellipse-corner ( x y width height -- )
+! [ drop nip 2 / + ] 4keep
+! [ nip rot drop 2 / + ] 4keep
+! [ >r >r 2drop r> r> ] 4keep
+! 4drop
+! ellipse-center ;
+
+! : ellipse-corners ( x1 y1 x2 y2 -- )
+! [ drop nip + 2 / ] 4keep
+! [ nip rot drop + 2 / ] 4keep
+! [ drop nip - abs 1+ ] 4keep
+! [ nip rot drop - abs 1+ ] 4keep
+! 4drop
+! ellipse-center ;
+
+! : ellipse ( a b c d -- )
+! ellipse-mode-value get
+! {
+! { CENTER [ ellipse-center ] }
+! { RADIUS [ ellipse-radius ] }
+! { CORNER [ ellipse-corner ] }
+! { CORNERS [ ellipse-corners ] }
+! }
+! case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: background ( value -- )
+
+METHOD: background { number }
+ dup dup 1 glClearColor
+ GL_COLOR_BUFFER_BIT glClear ;
+
+METHOD: background { array }
+ dup length
+ {
+ { 2 [ first2 >r dup dup r> glClearColor GL_COLOR_BUFFER_BIT glClear ] }
+ { 3 [ first3 1 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
+ { 4 [ first4 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
+ }
+ case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: translate ( x y -- ) 0 glTranslated ;
+
+: rotate ( angle -- ) 0 0 1 glRotated ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mouse ( -- point ) hand-loc get ;
+
+: mouse-x ( -- x ) mouse first ;
+: mouse-y ( -- y ) mouse second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: frame-rate-value
+
+: frame-rate ( fps -- ) 1000 swap / >frame-rate-value ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! VAR: slate
+
+VAR: loop-flag
+
+: defaults ( -- )
+ 0.8 background
+ ! CENTER ellipse-mode
+ 60 frame-rate ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: size-val
+
+: size ( seq -- ) size-val set ;
+
+: size* ( width height -- ) 2array size-val set ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: setup-action
+SYMBOL: draw-action
+
+! : setup ( quot -- ) closed-quot setup-action set ;
+! : draw ( quot -- ) closed-quot draw-action set ;
+
+: setup ( quot -- ) setup-action set ;
+: draw ( quot -- ) draw-action set ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: key-down-action
+SYMBOL: key-up-action
+
+: key-down ( quot -- ) closed-quot key-down-action set ;
+: key-up ( quot -- ) closed-quot key-up-action set ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: button-down-action
+SYMBOL: button-up-action
+
+: button-down ( quot -- ) closed-quot button-down-action set ;
+: button-up ( quot -- ) closed-quot button-up-action set ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: start-processing-thread ( -- )
+ loop-flag get not
+ [
+ loop-flag on
+ [
+ [ loop-flag get ]
+ processing-gadget get frame-rate-value> '[ , relayout-1 , sleep ]
+ [ ]
+ while
+ ]
+ in-thread
+ ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-size ( -- size ) processing-gadget get rect-dim ;
+
+: width ( -- width ) get-size first ;
+: height ( -- height ) get-size second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: setup-called
+
+: setup-called? ( -- ? ) setup-called get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run ( -- )
+
+ loop-flag off
+
+ 500 sleep
+
+ <processing-gadget>
+ size-val get >>pdim
+ dup "Processing" open-window
+
+ 500 sleep
+
+ defaults
+
+ setup-called off
+
+ [
+ setup-called? not
+ [
+ setup-action get call
+ setup-called on
+ ]
+ [
+ draw-action get call
+ ]
+ if
+ ]
+ closed-quot >>action
+
+ key-down-action get >>key-down
+ key-up-action get >>key-up
+
+ button-down-action get >>button-down
+ button-up-action get >>button-up
+
+ processing-gadget set
+
+ start-processing-thread ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel namespaces arrays sequences grouping
+ alien.c-types
+ math math.vectors math.geometry.rect
+ opengl.gl opengl.glu opengl.demo-support opengl generalizations vars
+ combinators.cleave colors ;
+
+IN: processing.shapes
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: fill-color
+VAR: stroke-color
+
+T{ rgba f 0 0 0 1 } stroke-color set-global
+T{ rgba f 1 1 1 1 } fill-color set-global
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fill-mode ( -- )
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ fill-color> gl-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: stroke-mode ( -- )
+ GL_FRONT_AND_BACK GL_LINE glPolygonMode
+ stroke-color> gl-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gl-vertex-2d ( vertex -- ) first2 glVertex2d ;
+
+: gl-vertices-2d ( vertices -- ) [ gl-vertex-2d ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: point* ( x y -- ) stroke-mode GL_POINTS [ glVertex2d ] do-state ;
+: point ( point -- ) stroke-mode GL_POINTS [ gl-vertex-2d ] do-state ;
+: points ( points -- ) stroke-mode GL_POINTS [ gl-vertices-2d ] do-state ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: line** ( x y x y -- )
+ stroke-mode GL_LINES [ glVertex2d glVertex2d ] do-state ;
+
+: line* ( a b -- ) stroke-mode GL_LINES [ [ gl-vertex-2d ] bi@ ] do-state ;
+
+: lines ( seq -- ) stroke-mode GL_LINES [ gl-vertices-2d ] do-state ;
+
+: line ( seq -- ) lines ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: line-strip ( seq -- ) stroke-mode GL_LINE_STRIP [ gl-vertices-2d ] do-state ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: triangles ( seq -- )
+ [ fill-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ]
+ [ stroke-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] bi ;
+
+: triangle ( seq -- ) triangles ;
+
+: triangle* ( a b c -- ) 3array triangles ;
+
+: triangle** ( x y x y x y -- ) 6 narray 2 group triangles ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: polygon ( seq -- )
+ [ fill-mode GL_POLYGON [ gl-vertices-2d ] do-state ]
+ [ stroke-mode GL_POLYGON [ gl-vertices-2d ] do-state ] bi ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rectangle ( loc dim -- )
+ <rect>
+ { top-left top-right bottom-right bottom-left }
+ 1arr
+ polygon ;
+
+: rectangle* ( x y width height -- ) [ 2array ] 2bi@ rectangle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gl-translate-2d ( pos -- ) first2 0 glTranslated ;
+
+: gl-scale-2d ( xy -- ) first2 1 glScaled ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gl-ellipse ( center dim -- )
+ glPushMatrix
+ [ gl-translate-2d ] [ gl-scale-2d ] bi*
+ gluNewQuadric
+ dup 0 0.5 20 1 gluDisk
+ gluDeleteQuadric
+ glPopMatrix ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gl-get-line-width ( -- width )
+ GL_LINE_WIDTH 0 <double> tuck glGetDoublev *double ;
+
+: ellipse ( center dim -- )
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ [ stroke-color> gl-color gl-ellipse ]
+ [ fill-color> gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: circle ( center size -- ) dup 2array ellipse ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-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
- processing.shapes
- flatland ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-IN: boids
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: constrain ( n a b -- n ) rot min max ;
-
-: angle-between ( vec vec -- angle )
- [ v. ] [ [ norm ] bi@ * ] 2bi / -1 1 constrain acos rad>deg ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ;
-
-: relative-angle ( self other -- angle )
- over vel>> -rot relative-position angle-between ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <boid> < <vel> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-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 ]
- }
- 2&& ;
-
-:: neighborhood ( SELF OTHERS BEHAVIOUR -- boids )
- OTHERS [| OTHER | SELF OTHER BEHAVIOUR within-neighborhood? ] filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: normalize* ( u -- v ) { 0.001 0.001 } v+ normalize ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: force* ( sequence <boid> <behaviour> -- force )
-
-:: cohesion-force ( OTHERS SELF BEHAVIOUR -- force )
- OTHERS average-position SELF pos>> v- normalize* BEHAVIOUR weight>> v*n ;
-
-:: alignment-force ( OTHERS SELF BEHAVIOUR -- force )
- OTHERS average-velocity normalize* BEHAVIOUR 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 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: iterate-system ( 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) ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M:: <boids-gadget> draw-gadget* ( BOIDS-GADGET -- )
- origin get
- [ BOIDS-GADGET boids>> [ draw-boid ] each ]
- with-translation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: start-boids-thread ( GADGET -- )
- GADGET f >>paused drop
- [
- [
- GADGET paused>>
- [ f ]
- [ GADGET iterate-system GADGET relayout-1 1 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 ;
-
-: boids-app ( -- )
-
- [let | BOIDS-GADGET [ boids-gadget ] |
-
- <frame>
-
- <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 ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: boids-main ( -- ) [ boids-app ] with-ui ;
-
-MAIN: boids-main
\ No newline at end of file
+++ /dev/null
-Artificial life program simulating simulating the flocking behaviour of birds
+++ /dev/null
-
-USING: kernel namespaces combinators
- ui.gestures accessors ui.gadgets.frame-buffer ;
-
-IN: processing.gadget
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: processing-gadget < frame-buffer button-down button-up key-down key-up ;
-
-: <processing-gadget> ( -- gadget ) processing-gadget new-frame-buffer ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: mouse-pressed-value
-SYMBOL: key-pressed-value
-
-SYMBOL: button-value
-SYMBOL: key-value
-
-: key-pressed? ( -- ? ) key-pressed-value get ;
-: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
-
-: key ( -- key ) key-value get ;
-: button ( -- val ) button-value get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: processing-gadget handle-gesture ( gesture gadget -- ? )
- swap
- {
- {
- [ dup key-down? ]
- [
- sym>> key-value set
- key-pressed-value on
- key-down>> dup [ call ] [ drop ] if
- t
- ]
- }
- {
- [ dup key-up? ]
- [
- key-pressed-value off
- drop
- key-up>> dup [ call ] [ drop ] if
- t
- ] }
- {
- [ dup button-down? ]
- [
- #>> button-value set
- mouse-pressed-value on
- button-down>> dup [ call ] [ drop ] if
- t
- ]
- }
- {
- [ dup button-up? ]
- [
- mouse-pressed-value off
- drop
- button-up>> dup [ call ] [ drop ] if
- t
- ]
- }
- { [ t ] [ 2drop t ] }
- }
- cond ;
+++ /dev/null
-
-USING: kernel arrays sequences math math.order qualified
- sequences.lib circular processing ui newfx processing.shapes ;
-
-IN: processing.gallery.trails
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Example 33-15 from the Processing book
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: point-list ( n -- seq ) [ drop 0 0 2array ] map <circular> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dot ( pos percent -- ) 1 swap - 25 * 5 max circle ;
-
-: step ( seq -- )
-
- no-stroke
- { 1 0.4 } fill
-
- 0 background
-
- mouse push-circular
- [ dot ]
- each-percent ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: go* ( -- )
-
- 500 500 size*
-
- [
- 100 point-list
- [ step ]
- curry
- draw
- ] setup
-
- run ;
-
-: go ( -- ) [ go* ] with-ui ;
-
-MAIN: go
+++ /dev/null
-
-USING: kernel namespaces threads combinators sequences arrays
- math math.functions math.ranges random
- opengl.gl opengl.glu vars multi-methods generalizations shuffle
- ui
- ui.gestures
- ui.gadgets
- combinators
- combinators.lib
- combinators.cleave
- rewrite-closures bake bake.fry accessors newfx
- processing.gadget math.geometry.rect
- processing.shapes
- colors ;
-
-IN: processing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
-
-: 1random ( b -- num ) 0 swap 2random ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chance ( fraction -- ? ) 0 1 2random > ;
-
-: percent-chance ( percent -- ? ) 100 / chance ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : at-fraction ( seq fraction -- val ) over length 1- * nth-at ;
-
-: at-fraction ( seq fraction -- val ) over length 1- * at ;
-
-: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: canonical-color-value ( obj -- color )
-
-METHOD: canonical-color-value { number } dup dup 1 rgba boa ;
-
-METHOD: canonical-color-value { array }
- dup length
- {
- { 2 [ first2 >r dup dup r> rgba boa ] }
- { 3 [ first3 1 rgba boa ] }
- { 4 [ first4 rgba boa ] }
- }
- case ;
-
-! METHOD: canonical-color-value { rgba }
-! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave 4array ;
-
-METHOD: canonical-color-value { color } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fill ( value -- ) canonical-color-value >fill-color ;
-: stroke ( value -- ) canonical-color-value >stroke-color ;
-
-! : no-fill ( -- ) 0 fill-color> set-fourth ;
-! : no-stroke ( -- ) 0 stroke-color> set-fourth ;
-
-: no-fill ( -- ) fill-color> 0 >>alpha drop ;
-: no-stroke ( -- ) stroke-color> 0 >>alpha drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: stroke-weight ( w -- ) glLineWidth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
-! GL_POLYGON glBegin
-! glVertex2d
-! glVertex2d
-! glVertex2d
-! glVertex2d
-! glEnd ;
-
-! : quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
-
-! 8 ndup
-
-! GL_FRONT_AND_BACK GL_FILL glPolygonMode
-! fill-color> set-color
-
-! quad-vertices
-
-! GL_FRONT_AND_BACK GL_LINE glPolygonMode
-! stroke-color> set-color
-
-! quad-vertices ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : ellipse-disk ( x y width height -- )
-! glPushMatrix
-! >r >r
-! 0 glTranslated
-! r> r> 1 glScaled
-! gluNewQuadric
-! dup 0 0.5 20 1 gluDisk
-! gluDeleteQuadric
-! glPopMatrix ;
-
-! : ellipse-center ( x y width height -- )
-
-! 4dup
-
-! GL_FRONT_AND_BACK GL_FILL glPolygonMode
-! stroke-color> set-color
-
-! ellipse-disk
-
-! GL_FRONT_AND_BACK GL_FILL glPolygonMode
-! fill-color> set-color
-
-! [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
-
-! ellipse-disk ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! SYMBOL: CENTER
-! SYMBOL: RADIUS
-! SYMBOL: CORNER
-! SYMBOL: CORNERS
-
-! SYMBOL: ellipse-mode-value
-
-! : ellipse-mode ( val -- ) ellipse-mode-value set ;
-
-! : ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ;
-
-! : ellipse-corner ( x y width height -- )
-! [ drop nip 2 / + ] 4keep
-! [ nip rot drop 2 / + ] 4keep
-! [ >r >r 2drop r> r> ] 4keep
-! 4drop
-! ellipse-center ;
-
-! : ellipse-corners ( x1 y1 x2 y2 -- )
-! [ drop nip + 2 / ] 4keep
-! [ nip rot drop + 2 / ] 4keep
-! [ drop nip - abs 1+ ] 4keep
-! [ nip rot drop - abs 1+ ] 4keep
-! 4drop
-! ellipse-center ;
-
-! : ellipse ( a b c d -- )
-! ellipse-mode-value get
-! {
-! { CENTER [ ellipse-center ] }
-! { RADIUS [ ellipse-radius ] }
-! { CORNER [ ellipse-corner ] }
-! { CORNERS [ ellipse-corners ] }
-! }
-! case ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: background ( value -- )
-
-METHOD: background { number }
- dup dup 1 glClearColor
- GL_COLOR_BUFFER_BIT glClear ;
-
-METHOD: background { array }
- dup length
- {
- { 2 [ first2 >r dup dup r> glClearColor GL_COLOR_BUFFER_BIT glClear ] }
- { 3 [ first3 1 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
- { 4 [ first4 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
- }
- case ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: translate ( x y -- ) 0 glTranslated ;
-
-: rotate ( angle -- ) 0 0 1 glRotated ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: mouse ( -- point ) hand-loc get ;
-
-: mouse-x ( -- x ) mouse first ;
-: mouse-y ( -- y ) mouse second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: frame-rate-value
-
-: frame-rate ( fps -- ) 1000 swap / >frame-rate-value ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! VAR: slate
-
-VAR: loop-flag
-
-: defaults ( -- )
- 0.8 background
- ! CENTER ellipse-mode
- 60 frame-rate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: size-val
-
-: size ( seq -- ) size-val set ;
-
-: size* ( width height -- ) 2array size-val set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: setup-action
-SYMBOL: draw-action
-
-! : setup ( quot -- ) closed-quot setup-action set ;
-! : draw ( quot -- ) closed-quot draw-action set ;
-
-: setup ( quot -- ) setup-action set ;
-: draw ( quot -- ) draw-action set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: key-down-action
-SYMBOL: key-up-action
-
-: key-down ( quot -- ) closed-quot key-down-action set ;
-: key-up ( quot -- ) closed-quot key-up-action set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: button-down-action
-SYMBOL: button-up-action
-
-: button-down ( quot -- ) closed-quot button-down-action set ;
-: button-up ( quot -- ) closed-quot button-up-action set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start-processing-thread ( -- )
- loop-flag get not
- [
- loop-flag on
- [
- [ loop-flag get ]
- processing-gadget get frame-rate-value> '[ , relayout-1 , sleep ]
- [ ]
- while
- ]
- in-thread
- ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-size ( -- size ) processing-gadget get rect-dim ;
-
-: width ( -- width ) get-size first ;
-: height ( -- height ) get-size second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: setup-called
-
-: setup-called? ( -- ? ) setup-called get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: run ( -- )
-
- loop-flag off
-
- 500 sleep
-
- <processing-gadget>
- size-val get >>pdim
- dup "Processing" open-window
-
- 500 sleep
-
- defaults
-
- setup-called off
-
- [
- setup-called? not
- [
- setup-action get call
- setup-called on
- ]
- [
- draw-action get call
- ]
- if
- ]
- closed-quot >>action
-
- key-down-action get >>key-down
- key-up-action get >>key-up
-
- button-down-action get >>button-down
- button-up-action get >>button-up
-
- processing-gadget set
-
- start-processing-thread ;
\ No newline at end of file
+++ /dev/null
-
-USING: kernel namespaces arrays sequences grouping
- alien.c-types
- math math.vectors math.geometry.rect
- opengl.gl opengl.glu opengl.demo-support opengl generalizations vars
- combinators.cleave colors ;
-
-IN: processing.shapes
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: fill-color
-VAR: stroke-color
-
-T{ rgba f 0 0 0 1 } stroke-color set-global
-T{ rgba f 1 1 1 1 } fill-color set-global
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fill-mode ( -- )
- GL_FRONT_AND_BACK GL_FILL glPolygonMode
- fill-color> gl-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: stroke-mode ( -- )
- GL_FRONT_AND_BACK GL_LINE glPolygonMode
- stroke-color> gl-color ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-vertex-2d ( vertex -- ) first2 glVertex2d ;
-
-: gl-vertices-2d ( vertices -- ) [ gl-vertex-2d ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: point* ( x y -- ) stroke-mode GL_POINTS [ glVertex2d ] do-state ;
-: point ( point -- ) stroke-mode GL_POINTS [ gl-vertex-2d ] do-state ;
-: points ( points -- ) stroke-mode GL_POINTS [ gl-vertices-2d ] do-state ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: line** ( x y x y -- )
- stroke-mode GL_LINES [ glVertex2d glVertex2d ] do-state ;
-
-: line* ( a b -- ) stroke-mode GL_LINES [ [ gl-vertex-2d ] bi@ ] do-state ;
-
-: lines ( seq -- ) stroke-mode GL_LINES [ gl-vertices-2d ] do-state ;
-
-: line ( seq -- ) lines ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: line-strip ( seq -- ) stroke-mode GL_LINE_STRIP [ gl-vertices-2d ] do-state ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: triangles ( seq -- )
- [ fill-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ]
- [ stroke-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] bi ;
-
-: triangle ( seq -- ) triangles ;
-
-: triangle* ( a b c -- ) 3array triangles ;
-
-: triangle** ( x y x y x y -- ) 6 narray 2 group triangles ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: polygon ( seq -- )
- [ fill-mode GL_POLYGON [ gl-vertices-2d ] do-state ]
- [ stroke-mode GL_POLYGON [ gl-vertices-2d ] do-state ] bi ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: rectangle ( loc dim -- )
- <rect>
- { top-left top-right bottom-right bottom-left }
- 1arr
- polygon ;
-
-: rectangle* ( x y width height -- ) [ 2array ] 2bi@ rectangle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-translate-2d ( pos -- ) first2 0 glTranslated ;
-
-: gl-scale-2d ( xy -- ) first2 1 glScaled ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-ellipse ( center dim -- )
- glPushMatrix
- [ gl-translate-2d ] [ gl-scale-2d ] bi*
- gluNewQuadric
- dup 0 0.5 20 1 gluDisk
- gluDeleteQuadric
- glPopMatrix ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gl-get-line-width ( -- width )
- GL_LINE_WIDTH 0 <double> tuck glGetDoublev *double ;
-
-: ellipse ( center dim -- )
- GL_FRONT_AND_BACK GL_FILL glPolygonMode
- [ stroke-color> gl-color gl-ellipse ]
- [ fill-color> gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: circle ( center size -- ) dup 2array ellipse ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
projects / factor.git / commitdiff