steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

L-system: fix compilation

master
Alexander Iljin 2020-08-03 21:56:59 +02:00 committed by John Benediktsson
parent 28bdbf8a2c
commit bfe2140148
1 changed files with 54 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

105
extra/L-system/L-system.factor
View File

@ -1,10 +1,10 @@
USING: accessors arrays assocs calendar colors USING: accessors arrays assocs calendar colors colors.constants
combinators.short-circuit help.markup help.syntax kernel locals combinators.short-circuit help help.markup help.syntax kernel
math math.functions math.matrices math.order math.parser locals math math.functions math.matrices
math.trig math.vectors opengl opengl.demo-support opengl.gl math.order math.parser math.trig math.vectors opengl
sbufs sequences strings threads ui.gadgets ui.gadgets.worlds opengl.demo-support opengl.gl opengl.glu sbufs sequences strings
ui.gestures ui.render ui.tools.workspace ; threads ui.gadgets ui.gadgets.worlds ui.gestures ui.render ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -18,7 +18,7 @@ DEFER: default-L-parser-values
: reset-turtle ( turtle -- turtle ) : reset-turtle ( turtle -- turtle )
{ 0 0 0 } clone >>pos { 0 0 0 } clone >>pos
3 identity-matrix >>ori 3 <identity-matrix> >>ori
V{ } clone >>vertices V{ } clone >>vertices
V{ } clone >>saved V{ } clone >>saved
@ -31,61 +31,61 @@ DEFER: default-L-parser-values
:: step-turtle ( TURTLE LENGTH -- turtle ) :: step-turtle ( TURTLE LENGTH -- turtle )
TURTLE TURTLE
TURTLE pos>> TURTLE ori>> { 0 0 LENGTH } m.v v+ TURTLE pos>> TURTLE ori>> { 0 0 LENGTH } mdotv v+
>>pos ; >>pos ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: Rx ( ANGLE -- Rx ) : Rx ( ANGLE -- Rx )
[let | ANGLE [ ANGLE deg>rad ] | [let deg>rad :> ANGLE
[let | A [ ANGLE cos ] ANGLE cos :> A
B [ ANGLE sin neg ] ANGLE sin neg :> B
C [ ANGLE sin ] ANGLE sin :> C
D [ ANGLE cos ] | ANGLE cos :> D
{ { 1 0 0 } { { 1 0 0 }
{ 0 A B } { 0 A B }
{ 0 C D } } { 0 C D } }
] ] ; ] ;
:: Ry ( ANGLE -- Ry ) : Ry ( ANGLE -- Ry )
[let | ANGLE [ ANGLE deg>rad ] | [let deg>rad :> ANGLE
[let | A [ ANGLE cos ] ANGLE cos :> A
B [ ANGLE sin ] ANGLE sin :> B
C [ ANGLE sin neg ] ANGLE sin neg :> C
D [ ANGLE cos ] | ANGLE cos :> D
{ { A 0 B } { { A 0 B }
{ 0 1 0 } { 0 1 0 }
{ C 0 D } } { C 0 D } }
] ] ; ] ;
:: Rz ( ANGLE -- Rz ) : Rz ( ANGLE -- Rz )
[let | ANGLE [ ANGLE deg>rad ] | [let deg>rad :> ANGLE
[let | A [ ANGLE cos ] ANGLE cos :> A
B [ ANGLE sin neg ] ANGLE sin neg :> B
C [ ANGLE sin ] ANGLE sin :> C
D [ ANGLE cos ] | ANGLE cos :> D
{ { A B 0 } { { A B 0 }
{ C D 0 } { C D 0 }
{ 0 0 1 } } { 0 0 1 } }
] ] ; ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: apply-rotation ( TURTLE ROTATION -- turtle ) :: apply-rotation ( TURTLE ROTATION -- turtle )
TURTLE TURTLE ori>> ROTATION m. >>ori ; TURTLE TURTLE ori>> ROTATION mdot >>ori ;
: rotate-x ( turtle angle -- turtle ) Rx apply-rotation ; : rotate-x ( turtle angle -- turtle ) Rx apply-rotation ;
: rotate-y ( turtle angle -- turtle ) Ry apply-rotation ; : rotate-y ( turtle angle -- turtle ) Ry apply-rotation ;
@ -197,7 +197,8 @@ DEFER: default-L-parser-values
! GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ; ! GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
: material-color ( color -- ) : material-color ( color -- )
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot color>raw 4array gl-material ; GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot >rgba-components 4array
gl-material ;
: set-color ( turtle i -- turtle ) : set-color ( turtle i -- turtle )
dup color-table nth dup gl-color material-color >>color ; dup color-table nth dup gl-color material-color >>color ;
@ -304,7 +305,7 @@ TUPLE: <L-system> < gadget
[ [
STRING read-instruction STRING read-instruction
[let | REST [ ] NEXT [ ] | [let :> ( NEXT REST )
NEXT 1 head RULES at NEXT or ACCUM push-all NEXT 1 head RULES at NEXT or ACCUM push-all
@ -316,7 +317,7 @@ TUPLE: <L-system> < gadget
:: iterate-string ( STRING RULES -- string ) :: iterate-string ( STRING RULES -- string )
[let | ACCUM [ STRING length 10 * <sbuf> ] | [let STRING length 10 * <sbuf> :> ACCUM
STRING RULES ACCUM iterate-string-loop STRING RULES ACCUM iterate-string-loop
@ -324,32 +325,33 @@ TUPLE: <L-system> < gadget
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: interpret-string ( STRING COMMANDS -- ) :: interpret-string ( TURTLE STRING COMMANDS -- turtle )
STRING empty? not STRING empty? not
[ [
STRING read-instruction STRING read-instruction
[let | REST [ ] NEXT [ ] | [let :> ( NEXT REST )
[let | COMMAND [ NEXT 1 head COMMANDS at ] | NEXT 1 head COMMANDS at :> COMMAND
COMMAND COMMAND
[ [
NEXT length 1 = NEXT length 1 =
[ COMMAND call ] [ TURTLE COMMAND call( turtle -- turtle ) drop ]
[ [
TURTLE
NEXT 2 tail 1 head* string>number NEXT 2 tail 1 head* string>number
COMMAND 1 tail* COMMAND 1 tail*
call call( turtle x -- turtle ) drop
] ]
if if
] ]
when ] when
REST COMMANDS interpret-string ] TURTLE REST COMMANDS interpret-string drop ]
] ]
when ; when TURTLE ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -363,10 +365,10 @@ TUPLE: <L-system> < gadget
:: do-camera-look-at ( CAMERA -- ) :: do-camera-look-at ( CAMERA -- )
[let | EYE [ CAMERA pos>> ] [let
FOCUS [ CAMERA clone 1 step-turtle pos>> ] CAMERA pos>> :> EYE
UP [ CAMERA clone 90 pitch-up 1 step-turtle pos>> CAMERA pos>> v- ] CAMERA clone 1 step-turtle pos>> :> FOCUS
| CAMERA clone 90 pitch-up 1 step-turtle pos>> CAMERA pos>> v- :> UP
EYE FOCUS UP gl-look-at ] ; EYE FOCUS UP gl-look-at ] ;
@ -379,7 +381,7 @@ TUPLE: <L-system> < gadget
L-SYSTEM display-list>> GL_COMPILE glNewList L-SYSTEM display-list>> GL_COMPILE glNewList
turtle turtle
L-SYSTEM turtle-values>> [ ] or call L-SYSTEM turtle-values>> [ ] or call( turtle -- turtle )
L-SYSTEM string>> L-SYSTEM axiom>> or L-SYSTEM string>> L-SYSTEM axiom>> or
L-SYSTEM commands>> L-SYSTEM commands>>
interpret-string interpret-string
@ -391,7 +393,7 @@ TUPLE: <L-system> < gadget
M:: <L-system> draw-gadget* ( L-SYSTEM -- ) M:: <L-system> draw-gadget* ( L-SYSTEM -- )
black gl-clear COLOR: black gl-clear
GL_FLAT glShadeModel GL_FLAT glShadeModel
@ -408,7 +410,8 @@ M:: <L-system> draw-gadget* ( L-SYSTEM -- )
GL_FRONT_AND_BACK GL_LINE glPolygonMode GL_FRONT_AND_BACK GL_LINE glPolygonMode
! draw axis ! draw axis
white gl-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd COLOR: white gl-color GL_LINES
glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
! rotate pedestal ! rotate pedestal
@ -432,7 +435,7 @@ M:: <L-system> pref-dim* ( L-SYSTEM -- dim ) { 400 400 } ;
:: with-camera ( L-SYSTEM QUOT -- ) :: with-camera ( L-SYSTEM QUOT -- )
L-SYSTEM camera>> QUOT call drop L-SYSTEM camera>> QUOT call drop
L-SYSTEM relayout-1 ; L-SYSTEM relayout-1 ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -466,7 +469,7 @@ H{
] ]
} }
{ T{ key-down f f "F1" } [ drop "L-system" help-window ] } { T{ key-down f f "F1" } [ drop "L-system" help ] }
} }
set-gestures set-gestures
@ -475,7 +478,7 @@ set-gestures
: L-system ( -- L-system ) : L-system ( -- L-system )
<L-system> new-gadget <L-system> new
0 >>pedestal 0 >>pedestal