From a5a17537359c24b7f05fa44d4d3581ff2824d8ee Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 2 Jan 2006 18:42:24 +0000 Subject: [PATCH] files moved from x11/ --- contrib/x11/examples/automata.factor | 105 +++++++++ contrib/x11/examples/boids.factor | 282 +++++++++++++++++++++++++ contrib/x11/examples/example-01.factor | 12 ++ contrib/x11/examples/example-02.factor | 48 +++++ contrib/x11/examples/example-03.factor | 38 ++++ 5 files changed, 485 insertions(+) create mode 100644 contrib/x11/examples/automata.factor create mode 100644 contrib/x11/examples/boids.factor create mode 100644 contrib/x11/examples/example-01.factor create mode 100644 contrib/x11/examples/example-02.factor create mode 100644 contrib/x11/examples/example-03.factor diff --git a/contrib/x11/examples/automata.factor b/contrib/x11/examples/automata.factor new file mode 100644 index 0000000000..b9255503d6 --- /dev/null +++ b/contrib/x11/examples/automata.factor @@ -0,0 +1,105 @@ +! Ed Cavazos - wayo.cavazos@gmail.com + +IN: automata + +USING: parser kernel hashtables namespaces sequences lists math io + threads strings arrays prettyprint xlib x ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! set-rule +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: rule + +8 rule set + +SYMBOL: char-0 + +48 char-0 set + +: rule-keys ( -- { ... } ) + { { 0 0 0 } + { 0 0 1 } + { 0 1 0 } + { 0 1 1 } + { 1 0 0 } + { 1 0 1 } + { 1 1 0 } + { 1 1 1 } } ; + +: rule-values ( n -- { ... } ) + >bin 8 char-0 get pad-left + >array + [ 48 - ] map ; + +: set-rule ( n -- ) + rule-values rule-keys [ rule get set-hash ] 2each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! step +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: 3nth ( n seq -- slice ) >r dup 3 + r> ; + +: next-chunk ( << slice: a b c >> - value ) + >array rule get hash ; + +: (step) ( line -- new-line ) + dup length 2 - [ swap 3nth next-chunk ] map-with ; + +: step-line ( line -- new-line ) + >r { 0 } r> { 0 } append append + (step) ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Display the rule +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! SYMBOL: win + +: setup-window + ":0.0" initialize-x + create-window win set + { 400 400 } resize-window + map-window + flush-dpy ; + +: random-line ( -- line ) + 0 400 + [ drop 2 random-int ] + map ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! show-line +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: show-point ( { x y } p -- ) +1 = [ draw-point ] [ drop ] if ; + +: (show-line) ( { x y } line -- ) + [ >r dup r> show-point { 1 0 } v+ ] each drop ; + +: show-line ( y line -- ) + >r >r 0 r> 2array r> (show-line) ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Go +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: run-rule + clear-window + 0 random-line + 400 + [ drop + 2dup show-line >r + 1 + + r> step-line ] each + flush-dpy ; + +: random-gallery + 255 random-int 1 + + dup unparse print + set-rule + run-rule + 5000 sleep + random-gallery ; diff --git a/contrib/x11/examples/boids.factor b/contrib/x11/examples/boids.factor new file mode 100644 index 0000000000..c55fc9f1f6 --- /dev/null +++ b/contrib/x11/examples/boids.factor @@ -0,0 +1,282 @@ +! Eduardo Cavazos - wayo.cavazos@gmail.com + +IN: boids + +USING: namespaces math kernel sequences arrays xlib x ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: separation-radius 100 separation-radius set +SYMBOL: alignment-radius 100 alignment-radius set +SYMBOL: cohesion-radius 100 cohesion-radius set + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: separation-view-angle 90 separation-view-angle set +SYMBOL: alignment-view-angle 90 alignment-view-angle set +SYMBOL: cohesion-view-angle 90 cohesion-view-angle set + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: separation-weight 1.0 separation-weight set +SYMBOL: alignment-weight 0.5 alignment-weight set +SYMBOL: cohesion-weight 1.0 cohesion-weight set + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: world-size { 400 400 } world-size set + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: boid pos vel ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: time-slice 0.5 time-slice set + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! random-boid and random-boids +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! : random-range dupd swap - random-int + ; + +: random-range ( a b -- n ) 1 + dupd swap - random-int + ; + +! : random-n ( n -- random-0-to-n-1 ) +! 1 - 0 swap random-int ; + +: random-pos ( -- pos ) + world-size get [ random-int ] map ; + +: random-vel ( -- vel ) + 2 >array [ drop -10 10 random-range ] map ; + +: random-boid ( -- boid ) random-pos random-vel ; + +: random-boids ( n -- boids ) >array [ drop random-boid ] map ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: boids + +: setup-window + ":0.0" initialize-x + create-window win set + world-size get resize-window + map-window + flush-dpy + 50 random-boids boids set ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! draw-boid +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: boid-point-a ( boid -- point-a ) boid-pos ; + +: boid-point-b ( boid -- point-b ) + dup >r boid-pos + r> boid-vel normalize 20 v*n + v+ ; + +: boid-points ( boid -- point-a point-b ) + dup >r boid-point-a r> boid-point-b ; + +: draw-boid ( boid -- ) boid-points draw-line ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: distance ( boid boid -- n ) + boid-pos swap boid-pos v- norm ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: r->d ( radians -- degrees ) 180 * pi / ; + +: constrain ( n a b -- n ) + >r max r> min ; + +: angle-between ( vec vec -- angle ) + 2dup >r >r + v. r> norm r> norm * / -1 1 constrain acos r->d ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: relative-angle ( self other -- angle ) + over >r >r + boid-vel r> boid-pos r> boid-pos v- angle-between ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: vsum ( vector-of-vectors --- vec ) + { 0 0 } [ v+ ] reduce ; + +: average-position ( boids -- pos ) + [ boid-pos ] map dup >r vsum r> length v/n ; + +: average-velocity ( boids -- vel ) + [ boid-vel ] map dup >r vsum r> length v/n ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: subset-with ( obj seq quot -- seq | quot: obj elt -- elt ) + [ >r dup r> ] swap append subset ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: within-radius? ( self other radius -- ? ) + >r distance r> <= ; + +: within-view-angle? ( self other view-angle -- ? ) + >r relative-angle r> 2 / <= ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: within-separation-radius? ( self other -- ? ) + separation-radius get within-radius? ; + +: within-separation-view? ( self other -- ? ) + separation-view-angle get within-view-angle? ; + +: within-separation-neighborhood? ( self other -- ? ) + [ eq? not ] 2keep + [ within-separation-radius? ] 2keep + within-separation-view? + and and ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: within-alignment-radius? ( self other -- ? ) + alignment-radius get within-radius? ; + +: within-alignment-view? ( self other -- ? ) + alignment-view-angle get within-view-angle? ; + +: within-alignment-neighborhood? ( self other -- ? ) + [ eq? not ] 2keep + [ within-alignment-radius? ] 2keep + within-alignment-view? + and and ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: within-cohesion-radius? ( self other -- ? ) + cohesion-radius get within-radius? ; + +: within-cohesion-view? ( self other -- ? ) + cohesion-view-angle get within-view-angle? ; + +: within-cohesion-neighborhood? ( self other -- ? ) + [ eq? not ] 2keep + [ within-cohesion-radius? ] 2keep + within-cohesion-view? + and and ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: separation-force ( self -- force ) + ! boids get [ within-separation-neighborhood? ] subset-with + boids get [ >r dup r> within-separation-neighborhood? ] subset + dup length 0 = + [ drop drop { 0 0 } ] + [ average-position + >r boid-pos r> v- + normalize + separation-weight get + v*n ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: alignment-force ( self -- force ) + ! boids get [ within-alignment-neighborhood? ] subset-with + boids get [ >r dup r> within-alignment-neighborhood? ] subset swap drop + dup length 0 = + [ drop { 0 0 } ] + [ average-velocity + normalize + alignment-weight get + v*n ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: cohesion-force ( self -- force ) + ! boids get [ within-cohesion-neighborhood? ] subset-with + boids get [ >r dup r> within-cohesion-neighborhood? ] subset + dup length 0 = + [ drop drop { 0 0 } ] + [ average-position + swap ! avg-pos self + boid-pos v- + normalize + cohesion-weight get + v*n ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! F = m a +! +! We let m be equal to 1 so then this is simply: F = a + +! : acceleration ( boid -- acceleration ) +! dup >r dup >r +! separation-force r> alignment-force r> cohesion-force v+ v+ ; + +: acceleration ( boid -- acceleration ) + dup dup + separation-force rot + alignment-force rot + cohesion-force v+ v+ ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! iterate-boid +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: new-pos ( boid -- pos ) + dup >r boid-pos r> boid-vel time-slice get v*n v+ ; + +! : new-vel ( boid -- vel ) +! dup >r boid-vel r> acceleration time-slice get v*n v+ ; + +: new-vel ( boid -- vel ) + dup boid-vel swap acceleration time-slice get v*n v+ ; + +: wrap-x ( x -- x ) + dup 0 world-size get nth >= [ drop 0 ] when + dup 0 < [ drop 0 world-size get nth 1 - ] when ; + +: wrap-y ( y -- y ) + dup 1 world-size get nth >= [ drop 0 ] when + dup 0 < [ drop 1 world-size get nth 1 - ] when ; + +: wrap-pos ( pos -- pos ) + [ ] each + wrap-y swap wrap-x swap 2array ; + +: iterate-boid ( self -- self ) + dup >r new-pos wrap-pos r> new-vel ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: iterate-boids ( -- ) + boids get [ iterate-boid ] map boids set ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: draw-boids ( -- ) + boids get [ draw-boid ] each flush-dpy ; + +: run-boids ( -- ) + iterate-boids clear-window draw-boids run-boids ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Comments from others: +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! slava foo get blah foo set ==> foo [ blah ] change +! slava dup >r blah r> ==> [ blah ] keep + +! : execute-with ( item [ word word ... ] -- results ... ) +! [ over >r execute r> ] each drop ; + diff --git a/contrib/x11/examples/example-01.factor b/contrib/x11/examples/example-01.factor new file mode 100644 index 0000000000..293198d0a0 --- /dev/null +++ b/contrib/x11/examples/example-01.factor @@ -0,0 +1,12 @@ + +USING: io concurrency x concurrent-widgets ; + +f initialize-x + +"Hey Hey" create-label +[ map-window ] with-window-object + +"Yo Yo Yo" [ "button pressed" print ] create-button +[ map-window ] with-window-object + +[ concurrent-event-loop ] spawn \ No newline at end of file diff --git a/contrib/x11/examples/example-02.factor b/contrib/x11/examples/example-02.factor new file mode 100644 index 0000000000..4c2768b95f --- /dev/null +++ b/contrib/x11/examples/example-02.factor @@ -0,0 +1,48 @@ + +USING: kernel namespaces sequences x concurrency concurrent-widgets ; + +SYMBOL: win-a SYMBOL: win-b SYMBOL: win-c SYMBOL: win-d + +f initialize-x + +[ win-a win-b win-c win-d ] [ create-window swap set ] each +[ win-a win-b win-c win-d ] [ "black" "red" "green" "blue" ] +[ lookup-color swap get win set set-window-background ] 2each + +[ win-b win-c win-d ] [ get win set win-a get reparent-window ] each + +[ win-a win-b win-c win-d ] [ get win set map-window ] each + +win-a get [ { 300 300 } resize-window ] with-win + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: button-horizontal + +"Horizontal" +[ win-a get + [ stack-children arrange-children-horizontally ] with-win +] create-button +button-horizontal set +button-horizontal get +[ { 100 20 } resize-window + map-window +] with-window-object + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: button-vertical + +"Vertical" +[ win-a get + [ stack-children arrange-children-vertically ] with-win +] create-button +button-vertical set +button-vertical get +[ { 100 20 } resize-window + map-window +] with-window-object + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +[ concurrent-event-loop ] spawn \ No newline at end of file diff --git a/contrib/x11/examples/example-03.factor b/contrib/x11/examples/example-03.factor new file mode 100644 index 0000000000..b4e8eafc46 --- /dev/null +++ b/contrib/x11/examples/example-03.factor @@ -0,0 +1,38 @@ + +USING: kernel namespaces sequences io xlib x concurrency concurrent-widgets ; + +SYMBOL: win-a +SYMBOL: button-a +SYMBOL: button-b +SYMBOL: button-c + +f initialize-x + +create-window-object win-a set + +win-a get [ "black" lookup-color set-window-background ] with-window-object + +"Hey Hey Hey" [ "button pressed" print ] create-button button-a set +"Yo Yo Yo" [ "button pressed" print ] create-button button-b set +"Foo" [ "button pressed" print ] create-button button-c set + +[ button-a button-b button-c ] [ "red" "green" "blue" ] +[ lookup-color swap get [ set-window-background ] with-window-object ] +2each + +[ button-a button-b button-c ] +[ get [ { 100 20 } resize-window ] with-window-object ] +each + +[ button-a button-b button-c ] +[ get [ win-a get window-id reparent-window ] with-window-object ] +each + +win-a get [ map-window ] with-window-object + +[ button-a button-b button-c ] [ get [ map-window ] with-window-object ] +each + +win-a get [ arrange-children-vertically ] with-window-object + +[ concurrent-event-loop ] spawn \ No newline at end of file