Remove obsolete examples from contrib/x11/
slava
parent
2a1167ecec
commit
c3e0351faa
|
|
@ -1,103 +0,0 @@
|
|||
! Ed Cavazos - wayo.cavazos@gmail.com
|
||||
|
||||
! Load, compile and then save your image:
|
||||
! "load.factor" run-file save
|
||||
! To run the program:
|
||||
! USE: automata setup-window random-gallery
|
||||
|
||||
USING: parser kernel hashtables namespaces sequences lists math io
|
||||
math-contrib threads strings arrays prettyprint x11 x ;
|
||||
|
||||
IN: automata
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! set-rule
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: rule 8 <hashtable> rule set-global
|
||||
|
||||
: 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 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> <slice> ;
|
||||
|
||||
: 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) ;
|
||||
|
||||
: last ( seq -- item ) dup length 1 - swap nth ;
|
||||
|
||||
: step-line-wrapped ( line -- new-line )
|
||||
dup last 1array swap dup first 1array append append (step) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Display the rule
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: setup-window ( -- )
|
||||
f initialize-x create-window win set
|
||||
{ 400 400 } resize-window map-window flush-dpy ;
|
||||
|
||||
: random-line ( -- line ) window-width [ 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 ( -- last-line ) clear-window
|
||||
0 random-line window-height [ drop 2dup show-line >r 1 + r> step-line ]
|
||||
each nip flush-dpy ;
|
||||
|
||||
: run-rule-wrapped ( -- last-line ) clear-window
|
||||
0 random-line 400 [ drop 2dup show-line >r 1 + r> step-line-wrapped ] each nip
|
||||
flush-dpy ;
|
||||
|
||||
: continue-rule ( first-line -- last-line ) clear-window
|
||||
0 swap 400 [ drop 2dup show-line swap 1 + swap step-line ] each nip
|
||||
flush-dpy ;
|
||||
|
||||
: continue-rule-wrapped ( first-line -- last-line ) clear-window
|
||||
0 swap 400 [ drop 2dup show-line swap 1 + swap step-line-wrapped ] each nip
|
||||
flush-dpy ;
|
||||
|
||||
: random-gallery ( -- )
|
||||
255 random-int 1 + dup unparse print flush
|
||||
set-rule run-rule 5000 sleep random-gallery ;
|
||||
|
||||
SYMBOL: interesting
|
||||
|
||||
{ 150 193 165 146 144 86 104 } interesting set-global
|
||||
|
||||
: random-item ( seq -- item ) dup length random-int swap nth ;
|
||||
|
||||
: random-interesting-gallery ( -- )
|
||||
interesting get random-item set-rule run-rule drop 10000 sleep
|
||||
random-interesting-gallery ;
|
||||
|
|
@ -1,273 +0,0 @@
|
|||
! Eduardo Cavazos - wayo.cavazos@gmail.com
|
||||
|
||||
! Load, compile and then save your image:
|
||||
! "load.factor" run-file save
|
||||
! To run the program:
|
||||
! USE: boids setup-window run-boids
|
||||
|
||||
USING: threads namespaces math kernel sequences arrays x11 x ; IN: boids
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: separation-radius 100 separation-radius set-global
|
||||
SYMBOL: alignment-radius 100 alignment-radius set-global
|
||||
SYMBOL: cohesion-radius 100 cohesion-radius set-global
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: separation-view-angle 90 separation-view-angle set-global
|
||||
SYMBOL: alignment-view-angle 90 alignment-view-angle set-global
|
||||
SYMBOL: cohesion-view-angle 90 cohesion-view-angle set-global
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: separation-weight 1.0 separation-weight set-global
|
||||
SYMBOL: alignment-weight 0.5 alignment-weight set-global
|
||||
SYMBOL: cohesion-weight 1.0 cohesion-weight set-global
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: world-size { 400 400 } world-size set-global
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: boid pos vel ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: time-slice 0.5 time-slice set-global
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! 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 <boid> ;
|
||||
|
||||
: random-boids ( n -- boids ) >array [ drop random-boid ] map ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: boids
|
||||
|
||||
: setup-window
|
||||
f 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 <boid> ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: 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 1 sleep 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 ;
|
||||
|
||||
|
|
@ -1,63 +0,0 @@
|
|||
USING: kernel sequences namespaces math threads io opengl concurrency
|
||||
x11 x gl concurrent-widgets ;
|
||||
|
||||
SYMBOL: pval
|
||||
|
||||
: p pval get ;
|
||||
: -p pval get neg ;
|
||||
|
||||
: wire-cube ( size -- )
|
||||
2.0 / pval set
|
||||
GL_LINE_LOOP glBegin
|
||||
-p -p -p glVertex3f
|
||||
p -p -p glVertex3f
|
||||
p p -p glVertex3f
|
||||
-p p -p glVertex3f
|
||||
glEnd
|
||||
GL_LINE_LOOP glBegin
|
||||
-p -p p glVertex3f
|
||||
p -p p glVertex3f
|
||||
p p p glVertex3f
|
||||
-p p p glVertex3f
|
||||
glEnd
|
||||
GL_LINES glBegin
|
||||
-p -p -p glVertex3f
|
||||
-p -p p glVertex3f
|
||||
p -p -p glVertex3f
|
||||
p -p p glVertex3f
|
||||
-p p -p glVertex3f
|
||||
-p p p glVertex3f
|
||||
p p -p glVertex3f
|
||||
p p p glVertex3f
|
||||
glEnd ;
|
||||
|
||||
: init ( -- ) 0.0 0.0 0.0 0.0 glClearColor GL_FLAT glShadeModel ;
|
||||
|
||||
: display ( -- )
|
||||
GL_COLOR_BUFFER_BIT glClear
|
||||
1.0 1.0 1.0 glColor3f
|
||||
glLoadIdentity
|
||||
0.0 0.0 5.0 0.0 0.0 0.0 0.0 1.0 0.0 gluLookAt
|
||||
1.0 2.0 1.0 glScalef
|
||||
1.0 wire-cube
|
||||
glFlush ;
|
||||
|
||||
: reshape ( { width height } -- )
|
||||
>r 0 0 r> [ ] each glViewport
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
-1.0 1.0 -1.0 1.0 1.5 20.0 glFrustum
|
||||
GL_MODELVIEW glMatrixMode
|
||||
display ;
|
||||
|
||||
f initialize-x
|
||||
|
||||
create-pwindow
|
||||
[ drop reshape ] over set-pwindow-resize-action
|
||||
window-id win set
|
||||
StructureNotifyMask select-input
|
||||
{ 500 500 } resize-window { 100 100 } move-window map-window
|
||||
|
||||
[ GLX_RGBA ] choose-visual create-context make-current
|
||||
|
||||
init [ concurrent-event-loop ] spawn display
|
||||
|
|
@ -1,56 +0,0 @@
|
|||
USING: kernel sequences namespaces math hashtables threads io opengl
|
||||
concurrency x11 x gl concurrent-widgets ;
|
||||
|
||||
SYMBOL: loop-action
|
||||
|
||||
! [ ] loop-action set
|
||||
|
||||
SYMBOL: spin 0.0 spin set
|
||||
|
||||
: init ( -- ) 0.0 0.0 0.0 0.0 glClearColor GL_FLAT glShadeModel ;
|
||||
|
||||
: display ( -- )
|
||||
GL_COLOR_BUFFER_BIT glClear
|
||||
glPushMatrix
|
||||
spin get 0.0 0.0 1.0 glRotatef
|
||||
1.0 1.0 1.0 glColor3f
|
||||
-25.0 -25.0 25.0 25.0 glRectf
|
||||
glPopMatrix
|
||||
swap-buffers ;
|
||||
|
||||
: spin-display ( -- )
|
||||
spin get 2.0 + spin set
|
||||
spin get 360.0 > [ spin get 360.0 - spin set ] when display ;
|
||||
|
||||
: reshape ( { width height } -- )
|
||||
>r 0 0 r> [ ] each glViewport
|
||||
GL_PROJECTION glMatrixMode glLoadIdentity
|
||||
-50.0 50.0 -50.0 50.0 -1.0 1.0 glOrtho
|
||||
GL_MODELVIEW glMatrixMode glLoadIdentity ;
|
||||
|
||||
: mouse ( event -- )
|
||||
{ { [ dup XButtonEvent-button Button1 = ]
|
||||
[ global [ [ spin-display ] loop-action set ] bind drop ] }
|
||||
{ [ dup XButtonEvent-button Button2 = ]
|
||||
[ global [ [ ] loop-action set ] bind drop ] }
|
||||
{ [ t ] [ drop ] } } cond ;
|
||||
|
||||
: loop ( -- ) loop-action get call 10 sleep loop ;
|
||||
|
||||
! : loop ( -- ) loop-action global hash call 10 sleep loop ;
|
||||
|
||||
! The following line wasn't needed in 0.79
|
||||
! USE: hashtables 10 <hashtable> window-table set
|
||||
|
||||
f initialize-x
|
||||
|
||||
create-pwindow
|
||||
[ drop reshape ] over set-pwindow-resize-action
|
||||
[ "button pressed" print drop mouse ] over set-pwindow-button-action
|
||||
window-id win set
|
||||
StructureNotifyMask ButtonPressMask bitor select-input
|
||||
{ 250 250 } resize-window { 100 100 } move-window map-window
|
||||
|
||||
[ GLX_RGBA GLX_DOUBLEBUFFER ] choose-visual create-context make-current
|
||||
|
||||
init [ concurrent-event-loop ] spawn [ loop ] spawn
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
|
||||
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
|
||||
|
|
@ -1,48 +0,0 @@
|
|||
|
||||
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
|
||||
|
|
@ -1,38 +0,0 @@
|
|||
|
||||
USING: kernel namespaces sequences io 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
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
USING: kernel words namespaces sequences x11 opengl x gl ;
|
||||
|
||||
: display ( -- )
|
||||
GL_COLOR_BUFFER_BIT glClear
|
||||
1.0 1.0 1.0 glColor3f
|
||||
GL_POLYGON glBegin
|
||||
0.25 0.25 0.0 glVertex3f
|
||||
0.75 0.25 0.0 glVertex3f
|
||||
0.75 0.75 0.0 glVertex3f
|
||||
0.25 0.75 0.0 glVertex3f
|
||||
glEnd
|
||||
glFlush ;
|
||||
|
||||
: init ( -- )
|
||||
0.0 0.0 0.0 0.0 glClearColor
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
0.0 1.0 0.0 1.0 -1.0 1.0 glOrtho
|
||||
;
|
||||
|
||||
f initialize-x create-window win set { 250 250 } resize-window map-window
|
||||
[ GLX_RGBA ] choose-visual create-context make-current init display
|
||||
|
|
@ -1,167 +0,0 @@
|
|||
IN: nehe
|
||||
USING: opengl x11 xlib syntax kernel sequences alien namespaces math threads generic io prettyprint ;
|
||||
|
||||
TUPLE: gl-window dpy screen win ctx x y width height depth ;
|
||||
SYMBOL: current-window
|
||||
|
||||
SYMBOL: dpy
|
||||
SYMBOL: screen
|
||||
SYMBOL: root
|
||||
SYMBOL: win
|
||||
SYMBOL: ctx
|
||||
SYMBOL: title
|
||||
SYMBOL: vi
|
||||
SYMBOL: x
|
||||
SYMBOL: y
|
||||
SYMBOL: width
|
||||
SYMBOL: height
|
||||
|
||||
: >int-array ( seq -- int-array )
|
||||
dup length dup "int" <c-array> -rot [
|
||||
pick set-int-nth
|
||||
] 2each ;
|
||||
|
||||
: attr-list ( -- c-array )
|
||||
[
|
||||
GLX_RGBA , GLX_DOUBLEBUFFER ,
|
||||
GLX_RED_SIZE , 4 ,
|
||||
GLX_GREEN_SIZE , 4 ,
|
||||
GLX_BLUE_SIZE , 4 ,
|
||||
GLX_DEPTH_SIZE , 16 ,
|
||||
None ,
|
||||
] f make >int-array ;
|
||||
|
||||
: resize-gl-scene ( glwin -- )
|
||||
0 0 rot [ gl-window-width ] keep [ gl-window-height ] keep >r glViewport
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
45 r> [ gl-window-width ] keep gl-window-height / 0.1 100 gluPerspective
|
||||
GL_MODELVIEW glMatrixMode ;
|
||||
|
||||
: gl-init ( glwin -- )
|
||||
GL_SMOOTH glShadeModel
|
||||
0 0 0 0 glClearColor
|
||||
1 glClearDepth
|
||||
GL_DEPTH_TEST glEnable
|
||||
GL_LEQUAL glDepthFunc
|
||||
GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint
|
||||
resize-gl-scene
|
||||
glFlush ;
|
||||
|
||||
: normal-XSetWindowAttributes ( cmap -- valuemask attr )
|
||||
<XSetWindowAttributes> [
|
||||
set-XSetWindowAttributes-colormap
|
||||
] keep
|
||||
ExposureMask KeyPressMask bitor ButtonPressMask bitor StructureNotifyMask bitor
|
||||
over set-XSetWindowAttributes-event_mask
|
||||
dup 1 swap set-XSetWindowAttributes-border_pixel
|
||||
CWBorderPixel CWColormap bitor CWEventMask bitor swap ;
|
||||
|
||||
: make-display ( display-num -- display )
|
||||
dup [ <c-string> ] when XOpenDisplay dup dpy set ;
|
||||
|
||||
: make-screen ( display -- screen )
|
||||
XDefaultScreen dup screen set ;
|
||||
|
||||
: make-vi ( display screen -- vi )
|
||||
attr-list glXChooseVisual dup vi set ;
|
||||
|
||||
: make-ctx ( display vi -- )
|
||||
0 <alien> GL_TRUE glXCreateContext ctx set ;
|
||||
|
||||
: make-colormap ( -- cmap )
|
||||
dpy get vi get 2dup XVisualInfo-screen XRootWindow dup root set
|
||||
swap XVisualInfo-visual AllocNone XCreateColormap ;
|
||||
|
||||
: make-win ( valuemask attr -- win )
|
||||
>r >r dpy get root get x get y get width get height get 0 vi get
|
||||
dup XVisualInfo-depth InputOutput rot XVisualInfo-visual r> r> XCreateWindow dup win set ;
|
||||
|
||||
: make-gl-window ( display-num x y width height depth title -- glwin )
|
||||
[
|
||||
title set depth set height set width set y set x set
|
||||
make-display dup dup make-screen make-vi make-ctx
|
||||
make-colormap normal-XSetWindowAttributes make-win
|
||||
dpy get swap 2dup over "WM_DELETE_WINDOW" 1 XInternAtom <int> 1 XSetWMProtocols drop
|
||||
2dup title get dup None 0 <alien> 0 over XSetStandardProperties drop
|
||||
2dup XMapRaised drop
|
||||
2dup ctx get glXMakeCurrent 2drop
|
||||
screen get win get ctx get x get y get width get height get depth get <gl-window>
|
||||
dup gl-init
|
||||
dup global [ current-window set ] bind
|
||||
] with-scope ;
|
||||
|
||||
: draw-gl-scene ( -- )
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
glLoadIdentity
|
||||
-1.5 0 -6 glTranslatef
|
||||
GL_TRIANGLES [
|
||||
0 1 0 glVertex3f
|
||||
-1 -1 0 glVertex3f
|
||||
1 -1 0 glVertex3f
|
||||
] do-state
|
||||
3 0 0 glTranslatef
|
||||
GL_QUADS [
|
||||
-1 1 1 glVertex3f
|
||||
1 1 0 glVertex3f
|
||||
1 -1 0 glVertex3f
|
||||
-1 -1 0 glVertex3f
|
||||
] do-state
|
||||
current-window get dup gl-window-dpy swap gl-window-win glXSwapBuffers ;
|
||||
|
||||
: kill-gl-window ( glwin -- )
|
||||
dup gl-window-ctx [
|
||||
over gl-window-dpy dup None 0 <alien> glXMakeCurrent drop
|
||||
swap glXDestroyContext
|
||||
0 over set-gl-window-ctx
|
||||
] when*
|
||||
gl-window-dpy XCloseDisplay ;
|
||||
|
||||
GENERIC: (handle-event) ( glwin xevent -- continue? )
|
||||
|
||||
M: x-expose-event (handle-event)
|
||||
nip XExposeEvent-count 0 = [ draw-gl-scene ] when t ;
|
||||
|
||||
M: x-configure-notify-event (handle-event)
|
||||
#! resize if the width or height has changed
|
||||
[ XConfigureEvent-width swap gl-window-width = ] 2keep
|
||||
[ XConfigureEvent-height swap gl-window-height = and ] 2keep rot [
|
||||
2drop
|
||||
] [
|
||||
[ XConfigureEvent-width swap set-gl-window-width ] 2keep
|
||||
[ XConfigureEvent-height swap set-gl-window-height ] 2keep
|
||||
drop resize-gl-scene
|
||||
] if t ;
|
||||
|
||||
M: x-button-press-event (handle-event)
|
||||
#! quit if a mouse button is pressed
|
||||
2drop f ;
|
||||
|
||||
PREDICATE: x-key-press-event quit-key-event
|
||||
0 XLookupKeysym dup CHAR: q = swap XK_Escape = or ;
|
||||
|
||||
M: quit-key-event (handle-event)
|
||||
2drop f ;
|
||||
|
||||
M: x-client-message-event (handle-event)
|
||||
swap gl-window-dpy swap XClientMessageEvent-message_type XGetAtomName
|
||||
"WM_PROTOCOLS" = not ;
|
||||
|
||||
M: object (handle-event)
|
||||
#! unknown event, ignore and continue
|
||||
2drop t ;
|
||||
|
||||
: handle-event ( glwin xevent -- continue? )
|
||||
over gl-window-dpy over XNextEvent drop (handle-event) ;
|
||||
|
||||
: (loop) ( glwin xevent -- continue? )
|
||||
over gl-window-dpy XPending 0 > [
|
||||
2dup handle-event [ (loop) ] [ 2drop f ] if
|
||||
] [ 2drop t ] if ;
|
||||
|
||||
: loop ( glwin xevent -- )
|
||||
2dup (loop) [ draw-gl-scene loop ] [ 2drop ] if ;
|
||||
|
||||
: main ( -- )
|
||||
":0.0" 10 10 640 480 16 "NeHe Lesson 2" make-gl-window
|
||||
dup <XEvent> loop kill-gl-window ;
|
||||
|
|
@ -1,17 +0,0 @@
|
|||
USING: kernel words sequences alien arrays namespaces x11 x ; IN: gl
|
||||
|
||||
: >int-array ( seq -- <int-array> )
|
||||
dup length "int" <c-array> swap dup length >array [ pick set-int-nth ] 2each ;
|
||||
|
||||
: >attributes ( seq -- attributes )
|
||||
0 add [ dup word? [ execute ] [ ] if ] map ;
|
||||
|
||||
: choose-visual ( attributes -- XVisualInfo* )
|
||||
>attributes >int-array dpy get scr get rot glXChooseVisual ;
|
||||
|
||||
: create-context ( XVisualInfo* -- GLXContext )
|
||||
>r dpy get r> 0 <alien> 1 glXCreateContext ;
|
||||
|
||||
: make-current ( GLXContext -- ) >r dpy get win get r> glXMakeCurrent drop ;
|
||||
|
||||
: swap-buffers ( -- ) dpy get win get glXSwapBuffers ;
|
||||
|
|
@ -1,5 +1,9 @@
|
|||
REQUIRES: contrib/concurrency ;
|
||||
|
||||
PROVIDE: contrib/x11 {
|
||||
"rectangle.factor" "x.factor" "draw-string.factor" "concurrent-widgets.factor" "gl.factor"
|
||||
} ;
|
||||
PROVIDE: contrib/x11
|
||||
{ +files+ {
|
||||
"rectangle.factor"
|
||||
"x.factor"
|
||||
"draw-string.factor"
|
||||
"concurrent-widgets.factor"
|
||||
} } ;
|
||||
Loading…
Reference in New Issue