*** empty log message ***
Eduardo Cavazos
parent
9da28cdc78
commit
50c636b9c4
|
|
@ -0,0 +1,55 @@
|
|||
USING: kernel alien math arrays sequences opengl namespaces concurrency
|
||||
xlib x x11 gl concurrent-widgets lindenmayer ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
USE: sequences
|
||||
|
||||
: >float-array ( seq -- )
|
||||
dup length <float-array> swap dup length >array [ pick set-float-nth ] 2each ;
|
||||
|
||||
USE: lindenmayer
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: camera-position { 5 5 5 } camera-position set
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: display ( -- )
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
camera-position get glLoadIdentity [ ] each 0.0 0.0 0.0 0.0 1.0 0.0 gluLookAt
|
||||
reset result get interpret glFlush ;
|
||||
|
||||
: reshape ( { width height } -- )
|
||||
>r 0 0 r> [ ] each glViewport
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity -1.0 1.0 -1.0 1.0 1.5 200.0 glFrustum
|
||||
GL_MODELVIEW glMatrixMode
|
||||
display ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
f initialize-x
|
||||
|
||||
create-pwindow
|
||||
[ drop reshape ] over set-pwindow-resize-action
|
||||
[ 2drop display ] over set-pwindow-expose-action
|
||||
window-id win set
|
||||
ExposureMask StructureNotifyMask bitor select-input
|
||||
{ 500 500 } resize-window { 0 0 } move-window map-window
|
||||
|
||||
[ GLX_RGBA ] choose-visual create-context make-current
|
||||
|
||||
0.0 0.0 0.0 0.0 glClearColor
|
||||
GL_SMOOTH glShadeModel
|
||||
|
||||
GL_FRONT_AND_BACK GL_SPECULAR { 1.0 1.0 1.0 1.0 } >float-array glMaterialfv
|
||||
GL_FRONT_AND_BACK GL_SHININESS { 50.0 } >float-array glMaterialfv
|
||||
GL_LIGHT0 GL_POSITION { 1.0 1.0 1.0 0.0 } >float-array glLightfv
|
||||
|
||||
GL_LIGHTING glEnable
|
||||
GL_LIGHT0 glEnable
|
||||
GL_DEPTH_TEST glEnable
|
||||
|
||||
[ concurrent-event-loop ] spawn
|
||||
|
|
@ -0,0 +1,296 @@
|
|||
USING: kernel alien namespaces arrays vectors math opengl math-contrib
|
||||
sequences hashtables strings ;
|
||||
|
||||
IN: lindenmayer
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: make-matrix >r { } make r> swap group ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: RU ( angle -- RU ) deg>rad
|
||||
[ dup cos , dup sin , 0 ,
|
||||
dup sin neg , dup cos , 0 ,
|
||||
0 , 0 , 1 , ] 3 make-matrix nip ;
|
||||
|
||||
: RL ( angle -- RL ) deg>rad
|
||||
[ dup cos , 0 , dup sin neg ,
|
||||
0 , 1 , 0 ,
|
||||
dup sin , 0 , dup cos , ] 3 make-matrix nip ;
|
||||
|
||||
: RH ( angle -- RH ) deg>rad
|
||||
[ 1 , 0 , 0 ,
|
||||
0 , dup cos , dup sin neg ,
|
||||
0 , dup sin , dup cos , ] 3 make-matrix nip ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: position
|
||||
SYMBOL: orientation
|
||||
|
||||
: rotate-U ( angle -- ) RU orientation get swap m. orientation set ;
|
||||
: rotate-L ( angle -- ) RL orientation get swap m. orientation set ;
|
||||
: rotate-H ( angle -- ) RH orientation get swap m. orientation set ;
|
||||
|
||||
: step ( length -- )
|
||||
>r position get orientation get 0 0 r> 3array m.v v+ position set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: record-vertex ( -- ) position get first3 glVertex3f ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: rotate-z rotate-U ;
|
||||
: rotate-y neg rotate-L ;
|
||||
: rotate-x neg rotate-H ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: reset ( -- ) { 0 0 0 } position set 3 identity-matrix orientation set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
DEFER: polygon-vertex
|
||||
|
||||
: draw-forward ( length -- )
|
||||
GL_LINES glBegin record-vertex step record-vertex glEnd ;
|
||||
|
||||
: move-forward ( length -- ) step polygon-vertex ;
|
||||
|
||||
: sneak-forward ( length -- ) step ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! (v0 - v1) x (v1 - v2)
|
||||
|
||||
: polygon-normal ( { v0 v1 v2 } -- normal )
|
||||
0 over nth over 1 swap nth v- swap
|
||||
1 over nth swap 2 swap nth v- cross ;
|
||||
|
||||
: polygon ( vertices -- )
|
||||
GL_POLYGON glBegin dup polygon-normal first3 glNormal3f
|
||||
[ first3 glVertex3f ] each glEnd ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: vertices
|
||||
|
||||
V{ } vertices set
|
||||
|
||||
: start-polygon ( -- ) 0 <vector> vertices set ;
|
||||
|
||||
: finish-polygon ( -- ) vertices get polygon ;
|
||||
|
||||
: polygon-vertex ( -- ) position get vertices get push ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Lindenmayer string rewriting and interpretation
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: rules
|
||||
SYMBOL: command-table
|
||||
|
||||
: lookup ( str -- str ) dup rules get hash dup [ nip ] [ drop ] if ;
|
||||
|
||||
: rewrite ( str -- str ) "" swap [ ch>string lookup append ] each ;
|
||||
|
||||
: interpret ( str -- )
|
||||
[ ch>string command-table get hash dup [ call ] [ drop ] if ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Lparser dialect
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: angle
|
||||
SYMBOL: length
|
||||
SYMBOL: thickness
|
||||
SYMBOL: color-index
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
DEFER: set-thickness
|
||||
DEFER: set-color-index
|
||||
|
||||
TUPLE: state position orientation angle length thickness color-index ;
|
||||
|
||||
SYMBOL: states V{ } states set
|
||||
|
||||
: save-state ( -- )
|
||||
position get orientation get angle get length get thickness get
|
||||
color-index get <state>
|
||||
states get push ;
|
||||
|
||||
: restore-state ( -- )
|
||||
states get pop
|
||||
dup state-position position set
|
||||
dup state-orientation orientation set
|
||||
dup state-length length set
|
||||
dup state-angle angle set
|
||||
dup state-color-index set-color-index
|
||||
dup state-thickness set-thickness
|
||||
drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: scale-length ( m -- ) length get * length set ;
|
||||
|
||||
: scale-angle ( m -- ) angle get * angle set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: color-table
|
||||
|
||||
{ { 0 0 0 } ! black
|
||||
{ 0.5 0.5 0.5 } ! grey
|
||||
{ 1 0 0 } ! red
|
||||
{ 1 1 0 } ! yellow
|
||||
{ 0 1 0 } ! green
|
||||
{ 0.250 0.878 0.815 } ! turquoise
|
||||
{ 0 0 1 } ! blue
|
||||
{ 0.627 0.125 0.941 } ! purple
|
||||
{ 0 0.392 0 } ! dark green
|
||||
{ 0.0 0.807 0.819 } ! dark turquoise
|
||||
{ 0.0 0.0 0.545 } ! dark blue
|
||||
{ 0.580 0.0 0.827 } ! dark purple
|
||||
{ 0.545 0.0 0.0 } ! dark red
|
||||
{ 0.25 0.25 0.25 } ! dark grey
|
||||
{ 0.75 0.75 0.75 } ! medium grey
|
||||
{ 1 1 1 } ! white
|
||||
} color-table set
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
USE: sequences
|
||||
|
||||
: >float-array ( seq -- )
|
||||
dup length <float-array> swap dup length >array [ pick set-float-nth ] 2each ;
|
||||
|
||||
USE: lindenmayer
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: material-color ( r g b -- )
|
||||
3array 1.0 add >float-array
|
||||
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot glMaterialfv ;
|
||||
|
||||
: set-color-index ( i -- )
|
||||
dup color-index set color-table get nth dup
|
||||
first3 glColor3f first3 material-color ;
|
||||
|
||||
: inc-color-index ( -- ) color-index get 1 + set-color-index ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: set-thickness ( i -- ) dup thickness set glLineWidth ;
|
||||
|
||||
: scale-thickness ( m -- ) thickness get * 0.5 max set-thickness ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: lparser-dialect ( -- )
|
||||
|
||||
1 length set 45 angle set 1 thickness set 2 set-color-index
|
||||
|
||||
H{ [[ "+" [ angle get rotate-y ] ]]
|
||||
[[ "-" [ angle get neg rotate-y ] ]]
|
||||
[[ "&" [ angle get rotate-x ] ]]
|
||||
[[ "^" [ angle get neg rotate-x ] ]]
|
||||
[[ "<" [ angle get rotate-z ] ]]
|
||||
[[ ">" [ angle get neg rotate-z ] ]]
|
||||
[[ "|" [ 180.0 rotate-y ] ]]
|
||||
[[ "%" [ 180.0 rotate-z ] ]]
|
||||
|
||||
[[ "F" [ length get draw-forward ] ]]
|
||||
[[ "Z" [ length get 2 / draw-forward ] ]]
|
||||
[[ "f" [ length get move-forward ] ]]
|
||||
[[ "z" [ length get 2 / move-forward ] ]]
|
||||
[[ "g" [ length get sneak-forward ] ]]
|
||||
|
||||
! [[ "." [ record-vertex ] ]]
|
||||
[[ "." [ polygon-vertex ] ]]
|
||||
[[ "[" [ save-state ] ]]
|
||||
[[ "]" [ restore-state ] ]]
|
||||
! [[ "{" [ GL_LINE_LOOP glBegin ] ]]
|
||||
! [[ "{" [ GL_POLYGON glBegin ] ]]
|
||||
[[ "{" [ start-polygon ] ]]
|
||||
! [[ "}" [ glEnd ] ]]
|
||||
[[ "}" [ finish-polygon ] ]]
|
||||
|
||||
[[ "/" [ 1.1 scale-length ] ]]
|
||||
[[ "'" [ 0.9 scale-length ] ]]
|
||||
[[ ";" [ 1.1 scale-angle ] ]]
|
||||
[[ ":" [ 0.9 scale-angle ] ]]
|
||||
[[ "?" [ thickness get 1.4 * thickness set ] ]]
|
||||
[[ "!" [ thickness get 0.7 * thickness set ] ]]
|
||||
|
||||
[[ "c" [ inc-color-index ] ]]
|
||||
} command-table set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Examples
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: result
|
||||
|
||||
: koch ( -- ) lparser-dialect 90 angle set
|
||||
|
||||
[ 0.41 scale-length ] "1" command-table get set-hash
|
||||
[ 2.439 scale-length ] "2" command-table get set-hash
|
||||
[ 0.5 scale-length ] "3" command-table get set-hash
|
||||
[ 0.2887 scale-length ] "4" command-table get set-hash
|
||||
[ 3.4758 scale-length ] "5" command-table get set-hash
|
||||
[ 60 rotate-z ] "6" command-table get set-hash
|
||||
[ 120 rotate-z ] "7" command-table get set-hash
|
||||
[ 180 rotate-x ] "8" command-table get set-hash
|
||||
[ 109.5111 rotate-x ] "9" command-table get set-hash
|
||||
[ -120 rotate-y ] "0" command-table get set-hash
|
||||
|
||||
H{ [[ "K" "[[a|b] 1f2 |6 [a|b]]" ]]
|
||||
[[ "k" "[ c3 K]" ]]
|
||||
[[ "a" "[d 7 d 7 d ]" ]]
|
||||
[[ "b" "e" ]]
|
||||
[[ "e" "[^ 4f5 8 +z{.0f0f}]" ]]
|
||||
[[ "d" "[^ 4f5 9 +zk{.0f0f}]" ]]
|
||||
} rules set
|
||||
|
||||
"K" 5 [ rewrite ] times dup result set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: spiral-0 ( -- ) lparser-dialect 10 angle set
|
||||
|
||||
H{ [[ "P" "[A]>>>>>>>>>[cB]>>>>>>>>>[ccC]>>>>>>>>>[cccD]" ]]
|
||||
[[ "A" "F+;'A" ]]
|
||||
[[ "B" "F!+F+;'B" ]]
|
||||
[[ "C" "F!^+F^+;'C" ]]
|
||||
[[ "D" "F!>^+F>^+;'D" ]]
|
||||
} rules set
|
||||
|
||||
"[P]|[P]" 5 [ rewrite ] times dup result set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: tree-5 ( -- ) lparser-dialect 5 angle set
|
||||
|
||||
[ 4 set-color-index ] "1" command-table get set-hash
|
||||
[ 60 neg rotate-z ] "2" command-table get set-hash
|
||||
[ 1.25 scale-length ] "3" command-table get set-hash
|
||||
[ 0.8 scale-length ] "4" command-table get set-hash
|
||||
[ 30 neg rotate-z ] "5" command-table get set-hash
|
||||
|
||||
H{ [[ "S" "FFR2R2R2R2R2R5S" ]]
|
||||
[[ "R" "[Ba]" ]]
|
||||
[[ "a" "$tF[Cx]Fb" ]]
|
||||
[[ "b" "$tF[Dy]Fa" ]]
|
||||
[[ "B" "&B" ]]
|
||||
[[ "C" "+C" ]]
|
||||
[[ "D" "-D" ]]
|
||||
[[ "x" "a" ]]
|
||||
[[ "y" "b" ]]
|
||||
[[ "F" "3F4" ]]
|
||||
} rules set
|
||||
|
||||
"1FFS" result set ;
|
||||
|
||||
Loading…
Reference in New Issue