New implementation of L-system program
wayo.cavazos
parent
ca36912b5a
commit
c66f9ecc01
|
|
@ -0,0 +1,42 @@
|
|||
|
||||
USING: kernel namespaces generic gadgets vars slate turtle turtle-camera ;
|
||||
|
||||
IN: camera-slate
|
||||
|
||||
TUPLE: camera-slate ;
|
||||
|
||||
C: camera-slate ( -- ) <slate> over set-delegate ;
|
||||
|
||||
VAR: camera
|
||||
|
||||
camera-slate H{
|
||||
{ T{ key-down f f "LEFT" }
|
||||
[ slate-ns [ [ 5 turn-left ] camera> with-turtle .slate ] bind ] }
|
||||
{ T{ key-down f f "RIGHT" }
|
||||
[ slate-ns [ [ 5 turn-right ] camera> with-turtle .slate ] bind ] }
|
||||
{ T{ key-down f f "UP" }
|
||||
[ slate-ns [ [ 5 pitch-down ] camera> with-turtle .slate ] bind ] }
|
||||
{ T{ key-down f f "DOWN" }
|
||||
[ slate-ns [ [ 5 pitch-up ] camera> with-turtle .slate ] bind ] }
|
||||
{ T{ key-down f f "LEFT" }
|
||||
[ slate-ns [ [ 5 turn-left ] camera> with-turtle .slate ] bind ] }
|
||||
|
||||
{ T{ key-down f f "a" }
|
||||
[ slate-ns [ [ 1 step-turtle ] camera> with-turtle .slate ] bind ] }
|
||||
{ T{ key-down f f "z" }
|
||||
[ slate-ns [ [ -1 step-turtle ] camera> with-turtle .slate ] bind ] }
|
||||
|
||||
{ T{ key-down f f "q" }
|
||||
[ slate-ns [ [ 5 roll-left ] camera> with-turtle .slate ] bind ] }
|
||||
{ T{ key-down f f "w" }
|
||||
[ slate-ns [ [ 5 roll-right ] camera> with-turtle .slate ] bind ] }
|
||||
|
||||
{ T{ key-down f { A+ } "LEFT" }
|
||||
[ slate-ns [ [ 1 strafe-left ] camera> with-turtle .slate ] bind ] }
|
||||
{ T{ key-down f { A+ } "RIGHT" }
|
||||
[ slate-ns [ [ 1 strafe-right ] camera> with-turtle .slate ] bind ] }
|
||||
{ T{ key-down f { A+ } "UP" }
|
||||
[ slate-ns [ [ 1 strafe-up ] camera> with-turtle .slate ] bind ] }
|
||||
{ T{ key-down f { A+ } "DOWN" }
|
||||
[ slate-ns [ [ 1 strafe-down ] camera> with-turtle .slate ] bind ] }
|
||||
} set-gestures
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
USING: kernel math sequences opengl turtle ;
|
||||
IN: turtle-camera
|
||||
|
||||
: camera-eye ( -- array ) position> ;
|
||||
|
||||
: camera-focus ( -- array )
|
||||
push-turtle
|
||||
1 step-turtle position>
|
||||
pop-turtle ;
|
||||
|
||||
: camera-up ( -- array )
|
||||
push-turtle
|
||||
90 pitch-up position> 1 step-turtle position> swap v-
|
||||
pop-turtle ;
|
||||
|
||||
: do-look-at ( -- )
|
||||
camera-eye first3 camera-focus first3 camera-up first3 gluLookAt ;
|
||||
|
|
@ -0,0 +1,581 @@
|
|||
! Eduardo Cavazos - wayo.cavazos@gmail.com
|
||||
|
||||
REQUIRES: contrib/math contrib/vars ;
|
||||
|
||||
USING: kernel alien namespaces arrays vectors math opengl sequences threads
|
||||
hashtables strings gadgets
|
||||
math-contrib vars slate turtle turtle-camera camera-slate
|
||||
opengl-contrib ;
|
||||
|
||||
IN: lindenmayer
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! roll-until-horizontal
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: V ( -- V ) { 0 1 0 } ;
|
||||
|
||||
: X ( -- 3array ) orientation> [ first ] map ;
|
||||
: Y ( -- 3array ) orientation> [ second ] map ;
|
||||
: Z ( -- 3array ) orientation> [ third ] map ;
|
||||
|
||||
: set-X ( seq -- ) orientation> [ 0 swap set-nth ] 2each ;
|
||||
: set-Y ( seq -- ) orientation> [ 1 swap set-nth ] 2each ;
|
||||
: set-Z ( seq -- ) orientation> [ 2 swap set-nth ] 2each ;
|
||||
|
||||
: roll-until-horizontal ( -- )
|
||||
V Z cross normalize set-X
|
||||
Z X cross normalize set-Y ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: record-vertex ( -- ) position> gl-vertex ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
DEFER: polygon-vertex
|
||||
|
||||
: draw-forward ( length -- )
|
||||
GL_LINES glBegin record-vertex step-turtle record-vertex glEnd ;
|
||||
|
||||
: move-forward ( length -- ) step-turtle polygon-vertex ;
|
||||
|
||||
: sneak-forward ( length -- ) step-turtle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! (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 ;
|
||||
|
||||
! Test and replace with:
|
||||
!
|
||||
! : v0-v1 ( { v0 v1 v2 } -- vec ) first2 v- ;
|
||||
!
|
||||
! : v1-v2 ( { v0 v1 v2 } -- vec ) first3 v- nip ;
|
||||
!
|
||||
! : polygon-normal ( { v0 v1 v2 } -- normal ) dup v0-v1 swap v1-v2 cross ;
|
||||
|
||||
: (polygon) ( vertices -- )
|
||||
GL_POLYGON glBegin dup polygon-normal gl-normal [ gl-vertex ] each glEnd ;
|
||||
|
||||
: polygon ( vertices -- ) dup length 3 >= [ (polygon) ] [ drop ] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! Maybe use an array instead of a vector
|
||||
|
||||
VAR: vertices
|
||||
|
||||
: start-polygon ( -- ) 0 <vector> >vertices ;
|
||||
|
||||
: finish-polygon ( -- ) vertices> polygon ;
|
||||
|
||||
: polygon-vertex ( -- ) position> vertices> push ;
|
||||
|
||||
: reset-vertices start-polygon ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Lindenmayer string rewriting
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! Maybe use an array instead of a quot in the work of segment
|
||||
|
||||
VAR: rules
|
||||
|
||||
: segment ( str -- seq )
|
||||
{ { [ dup "" = ] [ drop [ ] ] }
|
||||
{ [ dup length 1 = ] [ unit ] }
|
||||
{ [ 1 over nth CHAR: ( = ]
|
||||
[ CHAR: ) over index 1 + ! str i
|
||||
2dup head ! str i head
|
||||
-rot tail ! head tail
|
||||
segment swap add* ] }
|
||||
{ [ t ] [ dup 1 head swap 1 tail segment swap add* ] } }
|
||||
cond ;
|
||||
|
||||
: lookup ( str -- str ) dup 1 head rules get hash dup [ nip ] [ drop ] if ;
|
||||
|
||||
: rewrite ( str -- str ) segment [ lookup ] map concat ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Lindenmayer string interpretation
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: command-table
|
||||
|
||||
: segment-command ( seg -- command ) 1 head ;
|
||||
|
||||
! : segment-parameter ( seg -- parameter )
|
||||
! dup length 1 - 2 swap rot subseq parse call ;
|
||||
|
||||
: segment-parameter ( seg -- parameter )
|
||||
dup length 1 - 2 swap rot subseq string>number ;
|
||||
|
||||
: segment-parts ( seg -- param command )
|
||||
dup segment-parameter swap segment-command ;
|
||||
|
||||
: exec-command ( str -- ) command-table get hash dup [ call ] [ drop ] if ;
|
||||
|
||||
: exec-command-with-param ( param command -- )
|
||||
command-table get hash dup [ peek unit call ] [ 2drop ] if ;
|
||||
|
||||
: (interpret) ( seg -- )
|
||||
dup length 1 =
|
||||
[ exec-command ] [ segment-parts exec-command-with-param ] if ;
|
||||
|
||||
: interpret ( str -- ) segment [ (interpret) ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Lparser dialect
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: angle
|
||||
VAR: len
|
||||
VAR: thickness
|
||||
VAR: color-index
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
DEFER: set-thickness
|
||||
DEFER: set-color-index
|
||||
|
||||
TUPLE: state position orientation angle len thickness color-index ;
|
||||
|
||||
VAR: states
|
||||
|
||||
: reset-state-stack ( -- ) V{ } clone >states ;
|
||||
|
||||
: save-state ( -- )
|
||||
position> orientation> angle> len> thickness> color-index> <state>
|
||||
states> push ;
|
||||
|
||||
: restore-state ( -- )
|
||||
states> pop
|
||||
dup state-position >position
|
||||
dup state-orientation >orientation
|
||||
dup state-len >len
|
||||
dup state-angle >angle
|
||||
dup state-color-index set-color-index
|
||||
dup state-thickness set-thickness
|
||||
drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: scale-len ( m -- ) len> * >len ;
|
||||
|
||||
: scale-angle ( m -- ) angle> * >angle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: color-table
|
||||
|
||||
: init-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.25 0.88 0.82 } ! turquoise
|
||||
{ 0 0 1 } ! blue
|
||||
{ 0.63 0.13 0.94 } ! purple
|
||||
{ 0.00 0.50 0.00 } ! dark green
|
||||
{ 0.00 0.82 0.82 } ! dark turquoise
|
||||
{ 0.00 0.00 0.50 } ! dark blue
|
||||
{ 0.58 0.00 0.82 } ! dark purple
|
||||
{ 0.50 0.00 0.00 } ! dark red
|
||||
{ 0.25 0.25 0.25 } ! dark grey
|
||||
{ 0.75 0.75 0.75 } ! medium grey
|
||||
{ 1 1 1 } ! white
|
||||
} [ 1 set-color-alpha ] map color-table set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: material-color ( color -- )
|
||||
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material-fv ;
|
||||
|
||||
: set-color-index ( i -- )
|
||||
dup >color-index color-table> nth dup gl-color material-color ;
|
||||
|
||||
: inc-color-index ( -- ) color-index> 1 + set-color-index ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: set-thickness ( i -- ) dup >thickness glLineWidth ;
|
||||
|
||||
: scale-thickness ( m -- ) thickness> * 0.5 max set-thickness ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: default-values
|
||||
VAR: model-values
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: lparser-dialect ( -- )
|
||||
|
||||
[ 1 >len 45 >angle 1 >thickness 2 >color-index ] >default-values
|
||||
|
||||
H{ { "+" [ angle get turn-left ] }
|
||||
{ "-" [ angle get turn-right ] }
|
||||
{ "&" [ angle get pitch-down ] }
|
||||
{ "^" [ angle get pitch-up ] }
|
||||
{ "<" [ angle get roll-left ] }
|
||||
{ ">" [ angle get roll-right ] }
|
||||
|
||||
{ "|" [ 180.0 rotate-y ] }
|
||||
{ "%" [ 180.0 rotate-z ] }
|
||||
{ "$" [ roll-until-horizontal ] }
|
||||
|
||||
{ "F" [ len get draw-forward ] }
|
||||
{ "Z" [ len get 2 / draw-forward ] }
|
||||
{ "f" [ len get move-forward ] }
|
||||
{ "z" [ len get 2 / move-forward ] }
|
||||
{ "g" [ len get sneak-forward ] }
|
||||
{ "." [ polygon-vertex ] }
|
||||
|
||||
{ "[" [ save-state ] }
|
||||
{ "]" [ restore-state ] }
|
||||
{ "{" [ start-polygon ] }
|
||||
{ "}" [ finish-polygon ] }
|
||||
|
||||
{ "/" [ 1.1 scale-len ] } ! double quote command in lparser
|
||||
{ "'" [ 0.9 scale-len ] }
|
||||
{ ";" [ 1.1 scale-angle ] }
|
||||
{ ":" [ 0.9 scale-angle ] }
|
||||
{ "?" [ 1.4 scale-thickness ] }
|
||||
{ "!" [ 0.7 scale-thickness ] }
|
||||
|
||||
{ "c" [ color-index> 1 + color-table get length mod set-color-index ] }
|
||||
|
||||
} command-table set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Examples
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: axiom
|
||||
VAR: result
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: iterate ( -- ) result> rewrite >result ;
|
||||
|
||||
: iterations ( n -- ) [ iterate ] times ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: koch ( -- ) lparser-dialect [ 90 >angle ] >model-values
|
||||
|
||||
H{ { "K" "[[a|b] '(0.41)f'(2.439) |<(60) [a|b]]" }
|
||||
{ "k" "[ c'(0.5) K]" }
|
||||
{ "a" "[d <(120) d <(120) d ]" }
|
||||
{ "b" "e" }
|
||||
{ "e" "[^ '(.2887)f'(3.4758) &(180) +z{.-(120)f-(120)f}]" }
|
||||
{ "d" "[^ '(.2887)f'(3.4758) &(109.5111) +zk{.-(120)f-(120)f}]" }
|
||||
} >rules
|
||||
|
||||
"K" >axiom axiom> >result ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: spiral-0 ( -- ) lparser-dialect [ 10 >angle 5 >thickness ] >model-values
|
||||
|
||||
"[P]|[P]" axiom set
|
||||
|
||||
H{ { "P" "[A]>>>>>>>>>[cB]>>>>>>>>>[ccC]>>>>>>>>>[cccD]" }
|
||||
{ "A" "F+;'A" }
|
||||
{ "B" "F!+F+;'B" }
|
||||
{ "C" "F!^+F^+;'C" }
|
||||
{ "D" "F!>^+F>^+;'D" }
|
||||
} rules set
|
||||
|
||||
axiom> >result ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: tree-5 ( -- ) lparser-dialect 5 angle set 1 thickness set
|
||||
|
||||
"c(4)FFS" axiom set
|
||||
|
||||
H{ { "S" "FFR>(60)R>(60)R>(60)R>(60)R>(60)R>(30)S" }
|
||||
{ "R" "[Ba]" }
|
||||
{ "a" "$tF[Cx]Fb" }
|
||||
{ "b" "$tF[Dy]Fa" }
|
||||
{ "B" "&B" }
|
||||
{ "C" "+C" }
|
||||
{ "D" "-D" }
|
||||
|
||||
{ "x" "a" }
|
||||
{ "y" "b" }
|
||||
|
||||
{ "F" "'(1.25)F'(.8)" }
|
||||
} rules set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: abop-1 ( -- ) lparser-dialect 45 angle set 5 set-thickness
|
||||
|
||||
H{ { "A" "F[&'(.8)!BL]>(137)'!(.9)A" }
|
||||
{ "B" "F[-'(.8)!(.9)$CL]'!(.9)C" }
|
||||
{ "C" "F[+'(.8)!(.9)$BL]'!(.9)B" }
|
||||
|
||||
{ "L" "~c(8){+(30)f-(120)f-(120)f}" }
|
||||
} rules set
|
||||
|
||||
"c(12)FFAL" axiom set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: abop-2 ( -- ) lparser-dialect 30 angle set 5 thickness set
|
||||
|
||||
H{ { "A" "F[&'(.7)!BL]>(137)[&'(.6)!BL]>(137)'(.9)!(.9)A" }
|
||||
{ "B" "F[-'(.7)!(.9)$CL]'(.9)!(.9)C" }
|
||||
{ "C" "F[+'(.7)!(.9)$BL]'(.9)!(.9)B" }
|
||||
|
||||
{ "L" "~c(8){+(45)f(.1)-(45)f(.1)-(45)f(.1)+(45)|+(45)f(.1)-(45)f(.1)-(45)f(.1)}" }
|
||||
|
||||
} rules set
|
||||
|
||||
"c(12)FAL" axiom set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: abop-3 ( -- ) lparser-dialect 30 angle set 5 thickness set
|
||||
|
||||
H{ { "A" "!(.9)t(.4)FB>(94)B>(132)B" }
|
||||
{ "B" "[&t(.4)F$A]" }
|
||||
{ "F" "'(1.25)F'(.8)" }
|
||||
} rules set
|
||||
|
||||
"c(12)FA" axiom set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: abop-4 ( -- ) lparser-dialect 18 angle set 5 thickness set
|
||||
|
||||
H{ { "N" "FII[&(60)rY]>(90)[&(45)'(0.8)rA]>(90)[&(60)rY]>(90)[&(45)'(0.8)rD]!FIK" }
|
||||
{ "Y" "[c(4){++l.--l.--l.++|++l.--l.--l.}]" }
|
||||
{ "l" "g(.2)l" }
|
||||
{ "K" "[!c(2)FF>w>(72)w>(72)w>(72)w>(72)w]" }
|
||||
{ "w" "[c(2)^!F][c(5)&(72){-(54)f(3)+(54)f(3)|-(54)f(3)+(54)f(3)}]" }
|
||||
{ "f" "_" }
|
||||
|
||||
{ "A" "B" }
|
||||
{ "B" "C" }
|
||||
{ "C" "D" }
|
||||
{ "D" "E" }
|
||||
{ "E" "G" }
|
||||
{ "G" "H" }
|
||||
{ "H" "N" }
|
||||
|
||||
{ "I" "FoO" }
|
||||
{ "O" "FoP" }
|
||||
{ "P" "FoQ" }
|
||||
{ "Q" "FoR" }
|
||||
{ "R" "FoS" }
|
||||
{ "S" "FoT" }
|
||||
{ "T" "FoU" }
|
||||
{ "U" "FoV" }
|
||||
{ "V" "FoW" }
|
||||
{ "W" "FoX" }
|
||||
{ "X" "_" }
|
||||
|
||||
{ "o" "$t(-0.03)" }
|
||||
{ "r" "~(30)" }
|
||||
} rules set
|
||||
|
||||
"c(12)&(20)N" axiom set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: abop-5 ( -- ) lparser-dialect 5 angle set 5 thickness set
|
||||
|
||||
H{ { "a" "F[+(45)l][-(45)l]^;ca" }
|
||||
|
||||
{ "l" "j" }
|
||||
{ "j" "h" }
|
||||
{ "h" "s" }
|
||||
{ "s" "d" }
|
||||
{ "d" "x" }
|
||||
{ "x" "a" }
|
||||
|
||||
{ "F" "'(1.17)F'(.855)" }
|
||||
} rules set
|
||||
|
||||
"&(90)+(90)a" axiom set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: abop-6 ( -- ) lparser-dialect 5 angle set 5 thickness set
|
||||
|
||||
"&(90)+(90)FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x"
|
||||
axiom set
|
||||
|
||||
H{ { "a" "F[cdx][cex]F!(.9)a" }
|
||||
{ "x" "a" }
|
||||
|
||||
{ "d" "+d" }
|
||||
{ "e" "-e" }
|
||||
|
||||
{ "F" "'(1.25)F'(.8)" }
|
||||
} rules set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: airhorse ( -- ) lparser-dialect 10 angle set 5 thickness set
|
||||
|
||||
"C" axiom set
|
||||
|
||||
H{ { "C" "LBW" }
|
||||
|
||||
{ "B" "[[''aH]|[g]]" }
|
||||
{ "a" "Fs+;'a" }
|
||||
{ "g" "Ft+;'g" }
|
||||
{ "s" "[::cc!!!!&&[FFcccZ]^^^^FFcccZ]" }
|
||||
{ "t" "[c!!!!&[FF]^^FF]" }
|
||||
|
||||
{ "L" "O" }
|
||||
{ "O" "P" }
|
||||
{ "P" "Q" }
|
||||
{ "Q" "R" }
|
||||
{ "R" "U" }
|
||||
{ "U" "X" }
|
||||
{ "X" "Y" }
|
||||
{ "Y" "V" }
|
||||
{ "V" "[cc!!!&(90)[Zp]|[Zp]]" }
|
||||
{ "p" "h>(120)h>(120)h" }
|
||||
{ "h" "[+(40)!F'''p]" }
|
||||
|
||||
{ "H" "[cccci[>(50)dcFFF][<(50)ecFFF]]" }
|
||||
{ "d" "Z!&Z!&:'d" }
|
||||
{ "e" "Z!^Z!^:'e" }
|
||||
{ "i" "-:/i" }
|
||||
|
||||
{ "W" "[%[!!cb][<<<!!cb][>>>!!cb]]" }
|
||||
{ "b" "Fl!+Fl+;'b" }
|
||||
{ "l" "[-cc{--z++z++z--|--z++z++z}]" }
|
||||
} rules set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: model
|
||||
|
||||
: init-model ( -- ) 1 glGenLists >model ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: display ( -- )
|
||||
|
||||
black gl-clear-color
|
||||
|
||||
GL_FLAT glShadeModel
|
||||
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
-1 1 -1 1 1.5 200 glFrustum
|
||||
|
||||
GL_MODELVIEW glMatrixMode
|
||||
|
||||
glLoadIdentity
|
||||
|
||||
[ do-look-at ] camera> with-turtle
|
||||
|
||||
GL_COLOR_BUFFER_BIT glClear
|
||||
|
||||
GL_FRONT_AND_BACK GL_LINE glPolygonMode
|
||||
|
||||
white gl-color
|
||||
GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
|
||||
|
||||
color-index> set-color-index
|
||||
|
||||
model> glCallList ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: init-turtle ( -- ) <turtle> >turtle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: init-camera ( -- ) <turtle> >camera ;
|
||||
|
||||
: reset-camera ( -- ) [
|
||||
reset-turtle
|
||||
45 turn-left
|
||||
45 pitch-up
|
||||
5 step-turtle
|
||||
180 turn-left
|
||||
] camera> with-turtle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: init-slate ( -- )
|
||||
<camera-slate> >slate
|
||||
namespace slate> set-slate-ns
|
||||
slate> "L-system" open-titled-window
|
||||
[ display ] >action ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: init ( -- )
|
||||
init-turtle
|
||||
init-turtle-stack
|
||||
init-camera reset-camera
|
||||
init-model
|
||||
|
||||
2 >color-index
|
||||
init-color-table
|
||||
|
||||
init-slate ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: result>model ( -- )
|
||||
[ model> GL_COMPILE glNewList result> interpret glEndList ] >action .slate ;
|
||||
|
||||
: build-model ( -- )
|
||||
reset-state-stack
|
||||
reset-vertices
|
||||
reset-turtle
|
||||
default-values> call
|
||||
model-values> call
|
||||
result>model
|
||||
3000 sleep
|
||||
[ display ] >action .slate ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! These should be moved into a separate file. They are used to pretty
|
||||
! print matricies and vectors.
|
||||
|
||||
USING: styles prettyprint io ;
|
||||
|
||||
: decimal-places ( n d -- n )
|
||||
10 swap ^ tuck * >fixnum swap /f ;
|
||||
|
||||
! : .mat ( matrix -- ) [ [ 2 decimal-places ] map ] map . ;
|
||||
|
||||
: .mat ( matrix -- )
|
||||
H{ { table-gap 4 } { table-border 4 } }
|
||||
[ 2 decimal-places pprint ]
|
||||
tabular-output ;
|
||||
|
||||
: .vec ( vector -- ) [ 2 decimal-places ] map . ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
PROVIDE: lindenmayer ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! reset-turtle
|
||||
! koch
|
||||
! [
|
||||
! model> GL_COMPILE glNewList
|
||||
! result> interpret
|
||||
! glEndList
|
||||
! ] >action
|
||||
! slate> relayout-1
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
REQUIRES: contrib/alien ;
|
||||
USING: kernel sequences opengl alien-contrib ;
|
||||
IN: opengl-contrib
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: gl-clear-color ( 4seq -- ) first4 glClearColor ;
|
||||
|
||||
: gl-vertex-3f ( 3seq -- ) first3 glVertex3f ;
|
||||
|
||||
: gl-vertex ( 3seq -- ) gl-vertex-3f ;
|
||||
|
||||
: gl-normal-3f ( vec -- ) first3 glNormal3f ;
|
||||
|
||||
: gl-normal ( vec -- ) gl-normal-3f ;
|
||||
|
||||
: gl-material-fv ( face pname params -- ) >float-array glMaterialfv ;
|
||||
|
||||
: gl-color ( vec -- ) first4 glColor4f ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Misc stuff that should probably go in a separate file
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: black ( -- color ) { 0 0 0 1 } ;
|
||||
|
||||
: white ( -- color ) { 1 1 1 1 } ;
|
||||
|
||||
: red ( -- color ) { 1 0 0 1 } ;
|
||||
|
||||
: green ( -- color ) { 0 1 0 1 } ;
|
||||
|
||||
: blue ( -- color ) { 0 0 1 1 } ;
|
||||
|
||||
: yellow ( -- color ) { 1 1 0 1 } ;
|
||||
|
||||
: set-color-alpha ( color alpha -- color ) swap 3 head swap add ;
|
||||
|
||||
|
|
@ -0,0 +1,119 @@
|
|||
REQUIRES: contrib/math contrib/vars ;
|
||||
USING: kernel math namespaces sequences arrays math-contrib vars ;
|
||||
IN: turtle
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: turtle position orientation ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: turtle
|
||||
|
||||
: position> ( -- position ) turtle> turtle-position ;
|
||||
|
||||
: >position ( position -- ) turtle> set-turtle-position ;
|
||||
|
||||
: orientation> ( -- orientation ) turtle> turtle-orientation ;
|
||||
|
||||
: >orientation ( orientation -- ) turtle> set-turtle-orientation ;
|
||||
|
||||
: with-turtle ( quot turtle -- ) [ >turtle call ] with-scope ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: reset-turtle ( -- ) { 0 0 0 } >position 3 identity-matrix >orientation ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
C: turtle ( -- ) [ reset-turtle ] over with-turtle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: make-matrix >r { } make r> group ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! These rotation matrices are from
|
||||
! `Computer Graphics: Principles and Practice'
|
||||
|
||||
: Rz ( angle -- Rx ) deg>rad
|
||||
[ dup cos , dup sin neg , 0 ,
|
||||
dup sin , dup cos , 0 ,
|
||||
0 , 0 , 1 , ] 3 make-matrix nip ;
|
||||
|
||||
: Ry ( angle -- Ry ) deg>rad
|
||||
[ dup cos , 0 , dup sin ,
|
||||
0 , 1 , 0 ,
|
||||
dup sin neg , 0 , dup cos , ] 3 make-matrix nip ;
|
||||
|
||||
: Rx ( angle -- Rz ) deg>rad
|
||||
[ 1 , 0 , 0 ,
|
||||
0 , dup cos , dup sin neg ,
|
||||
0 , dup sin , dup cos , ] 3 make-matrix nip ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: apply-rotation ( rotation -- ) orientation> swap m. >orientation ;
|
||||
|
||||
: rotate-x ( angle -- ) Rx apply-rotation ;
|
||||
: rotate-y ( angle -- ) Ry apply-rotation ;
|
||||
: rotate-z ( angle -- ) Rz apply-rotation ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: pitch-up ( angle -- ) neg rotate-x ;
|
||||
: pitch-down ( angle -- ) rotate-x ;
|
||||
|
||||
: turn-left ( angle -- ) rotate-y ;
|
||||
: turn-right ( angle -- ) neg rotate-y ;
|
||||
|
||||
: roll-left ( angle -- ) neg rotate-z ;
|
||||
: roll-right ( angle -- ) rotate-z ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: step-vector ( length -- array ) { 0 0 1 } n*v ;
|
||||
|
||||
: step-turtle ( length -- )
|
||||
step-vector orientation> swap m.v position> v+ >position ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: strafe-up ( length -- )
|
||||
90 pitch-up
|
||||
step-turtle
|
||||
90 pitch-down ;
|
||||
|
||||
: strafe-down ( length -- )
|
||||
90 pitch-down
|
||||
step-turtle
|
||||
90 pitch-up ;
|
||||
|
||||
: strafe-left ( length -- )
|
||||
90 turn-left
|
||||
step-turtle
|
||||
90 turn-right ;
|
||||
|
||||
: strafe-right ( length -- )
|
||||
90 turn-right
|
||||
step-turtle
|
||||
90 turn-left ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: turtle-stack
|
||||
|
||||
: init-turtle-stack ( -- ) V{ } clone >turtle-stack ;
|
||||
|
||||
: push-turtle ( -- ) turtle> clone turtle-stack> push ;
|
||||
|
||||
! : pop-turtle ( -- ) turtle-stack> pop >turtle ;
|
||||
|
||||
: pop-turtle ( -- )
|
||||
turtle-stack> pop dup
|
||||
turtle-position >position
|
||||
turtle-orientation >orientation ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
Loading…
Reference in New Issue