--- /dev/null
+
+USING: accessors arrays assocs colors combinators.short-circuit
+kernel locals math math.functions math.matrices math.order
+math.parser math.trig math.vectors opengl opengl.demo-support
+opengl.gl sbufs sequences strings ui.gadgets ui.gadgets.worlds
+ui.gestures ui.render ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IN: L-system
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <turtle> pos ori angle length thickness color vertices saved ;
+
+DEFER: default-L-parser-values
+
+: reset-turtle ( turtle -- turtle )
+ { 0 0 0 } clone >>pos
+ 3 identity-matrix >>ori
+ V{ } clone >>vertices
+ V{ } clone >>saved
+
+ default-L-parser-values ;
+
+: turtle ( -- turtle ) <turtle> new reset-turtle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: step-turtle ( TURTLE LENGTH -- turtle )
+
+ TURTLE
+ TURTLE pos>> TURTLE ori>> { 0 0 LENGTH } m.v v+
+ >>pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: Rx ( ANGLE -- Rx )
+
+ [let | ANGLE [ ANGLE deg>rad ] |
+
+ [let | A [ ANGLE cos ]
+ B [ ANGLE sin neg ]
+ C [ ANGLE sin ]
+ D [ ANGLE cos ] |
+
+ { { 1 0 0 }
+ { 0 A B }
+ { 0 C D } }
+
+ ] ] ;
+
+:: Ry ( ANGLE -- Ry )
+
+ [let | ANGLE [ ANGLE deg>rad ] |
+
+ [let | A [ ANGLE cos ]
+ B [ ANGLE sin ]
+ C [ ANGLE sin neg ]
+ D [ ANGLE cos ] |
+
+ { { A 0 B }
+ { 0 1 0 }
+ { C 0 D } }
+
+ ] ] ;
+
+:: Rz ( ANGLE -- Rz )
+
+ [let | ANGLE [ ANGLE deg>rad ] |
+
+ [let | A [ ANGLE cos ]
+ B [ ANGLE sin neg ]
+ C [ ANGLE sin ]
+ D [ ANGLE cos ] |
+
+ { { A B 0 }
+ { C D 0 }
+ { 0 0 1 } }
+
+ ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: apply-rotation ( TURTLE ROTATION -- turtle )
+
+ TURTLE TURTLE ori>> ROTATION m. >>ori ;
+
+: rotate-x ( turtle angle -- turtle ) Rx apply-rotation ;
+: rotate-y ( turtle angle -- turtle ) Ry apply-rotation ;
+: rotate-z ( turtle angle -- turtle ) Rz apply-rotation ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pitch-up ( turtle angle -- turtle ) neg rotate-x ;
+: pitch-down ( turtle angle -- turtle ) rotate-x ;
+
+: turn-left ( turtle angle -- turtle ) rotate-y ;
+: turn-right ( turtle angle -- turtle ) neg rotate-y ;
+
+: roll-left ( turtle angle -- turtle ) neg rotate-z ;
+: roll-right ( turtle angle -- turtle ) rotate-z ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: V ( -- V ) { 0 1 0 } ;
+
+: X ( turtle -- 3array ) ori>> [ first ] map ;
+: Y ( turtle -- 3array ) ori>> [ second ] map ;
+: Z ( turtle -- 3array ) ori>> [ third ] map ;
+
+: set-X ( turtle seq -- turtle ) over ori>> [ set-first ] 2each ;
+: set-Y ( turtle seq -- turtle ) over ori>> [ set-second ] 2each ;
+: set-Z ( turtle seq -- turtle ) over ori>> [ set-third ] 2each ;
+
+:: roll-until-horizontal ( TURTLE -- turtle )
+
+ TURTLE
+
+ V TURTLE Z cross normalize set-X
+
+ TURTLE Z TURTLE X cross normalize set-Y ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: strafe-up ( TURTLE LENGTH -- turtle )
+ TURTLE 90 pitch-up LENGTH step-turtle 90 pitch-down ;
+
+:: strafe-down ( TURTLE LENGTH -- turtle )
+ TURTLE 90 pitch-down LENGTH step-turtle 90 pitch-up ;
+
+:: strafe-left ( TURTLE LENGTH -- turtle )
+ TURTLE 90 turn-left LENGTH step-turtle 90 turn-right ;
+
+:: strafe-right ( TURTLE LENGTH -- turtle )
+ TURTLE 90 turn-right LENGTH step-turtle 90 turn-left ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: polygon ( vertices -- ) GL_POLYGON glBegin [ first3 glVertex3d ] each glEnd ;
+
+: start-polygon ( turtle -- turtle ) dup vertices>> delete-all ;
+
+: finish-polygon ( turtle -- turtle ) dup vertices>> polygon ;
+
+: polygon-vertex ( turtle -- turtle ) dup [ pos>> ] [ vertices>> ] bi push ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: record-vertex ( turtle -- turtle ) dup pos>> first3 glVertex3d ;
+
+: draw-forward ( turtle length -- turtle )
+ GL_LINES glBegin [ record-vertex ] dip step-turtle record-vertex glEnd ;
+
+: move-forward ( turtle length -- turtle ) step-turtle polygon-vertex ;
+
+: sneak-forward ( turtle length -- turtle ) step-turtle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: scale-length ( turtle m -- turtle ) over length>> * >>length ;
+: scale-angle ( turtle m -- turtle ) over angle>> * >>angle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: set-thickness ( turtle i -- turtle ) dup glLineWidth >>thickness ;
+
+: scale-thickness ( turtle m -- turtle )
+ over thickness>> * 0.5 max set-thickness ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: color-table ( -- colors )
+ {
+ T{ rgba f 0 0 0 1 } ! black
+ T{ rgba f 0.5 0.5 0.5 1 } ! grey
+ T{ rgba f 1 0 0 1 } ! red
+ T{ rgba f 1 1 0 1 } ! yellow
+ T{ rgba f 0 1 0 1 } ! green
+ T{ rgba f 0.25 0.88 0.82 1 } ! turquoise
+ T{ rgba f 0 0 1 1 } ! blue
+ T{ rgba f 0.63 0.13 0.94 1 } ! purple
+ T{ rgba f 0.00 0.50 0.00 1 } ! dark green
+ T{ rgba f 0.00 0.82 0.82 1 } ! dark turquoise
+ T{ rgba f 0.00 0.00 0.50 1 } ! dark blue
+ T{ rgba f 0.58 0.00 0.82 1 } ! dark purple
+ T{ rgba f 0.50 0.00 0.00 1 } ! dark red
+ T{ rgba f 0.25 0.25 0.25 1 } ! dark grey
+ T{ rgba f 0.75 0.75 0.75 1 } ! medium grey
+ T{ rgba f 1 1 1 1 } ! white
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : material-color ( color -- )
+! GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
+
+: material-color ( color -- )
+ GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot color>raw 4array gl-material ;
+
+: set-color ( turtle i -- turtle )
+ dup color-table nth dup gl-color material-color >>color ;
+
+: inc-color ( turtle -- turtle ) dup color>> 1 + set-color ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: save-turtle ( turtle -- turtle ) dup clone over saved>> push ;
+: restore-turtle ( turtle -- turtle ) saved>> pop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: default-L-parser-values ( turtle -- turtle )
+ 1 >>length 45 >>angle 1 >>thickness 2 >>color ;
+
+: L-parser-dialect ( -- commands )
+
+ {
+ { "+" [ dup angle>> turn-left ] }
+ { "-" [ dup angle>> turn-right ] }
+ { "&" [ dup angle>> pitch-down ] }
+ { "^" [ dup angle>> pitch-up ] }
+ { "<" [ dup angle>> roll-left ] }
+ { ">" [ dup angle>> roll-right ] }
+
+ { "|" [ 180.0 rotate-y ] }
+ { "%" [ 180.0 rotate-z ] }
+ { "$" [ roll-until-horizontal ] }
+
+ { "F" [ dup length>> draw-forward ] }
+ { "Z" [ dup length>> 2 / draw-forward ] }
+ { "f" [ dup length>> move-forward ] }
+ { "z" [ dup length>> 2 / move-forward ] }
+ { "g" [ dup length>> sneak-forward ] }
+ { "." [ polygon-vertex ] }
+
+ { "[" [ save-turtle ] }
+ { "]" [ restore-turtle ] }
+
+ { "{" [ start-polygon ] }
+ { "}" [ finish-polygon ] }
+
+ { "/" [ 1.1 scale-length ] } ! double quote command in lparser
+ { "'" [ 0.9 scale-length ] }
+ { ";" [ 1.1 scale-angle ] }
+ { ":" [ 0.9 scale-angle ] }
+ { "?" [ 1.4 scale-thickness ] }
+ { "!" [ 0.7 scale-thickness ] }
+
+ { "c" [ dup color>> 1 + color-table length mod set-color ] }
+
+ }
+ ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <L-system> < gadget
+ camera display-list
+ commands axiom rules string ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: open-paren ( -- ch ) CHAR: ( ;
+: close-paren ( -- ch ) CHAR: ) ;
+
+: open-paren? ( obj -- ? ) open-paren = ;
+: close-paren? ( obj -- ? ) close-paren = ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: read-instruction ( STRING -- next rest )
+
+ { [ STRING length 1 > ] [ STRING second open-paren? ] } 0&&
+ [ STRING close-paren STRING index 1 + cut ]
+ [ STRING 1 cut ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-string-loop ( STRING RULES ACCUM -- )
+ STRING empty? not
+ [
+ STRING read-instruction
+
+ [let | REST [ ] NEXT [ ] |
+
+ NEXT 1 head RULES at NEXT or ACCUM push-all
+
+ REST RULES ACCUM iterate-string-loop ]
+ ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-string ( STRING RULES -- string )
+
+ [let | ACCUM [ STRING length 10 * <sbuf> ] |
+
+ STRING RULES ACCUM iterate-string-loop
+
+ ACCUM >string ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: interpret-string ( STRING COMMANDS -- )
+
+ STRING empty? not
+ [
+ STRING read-instruction
+
+ [let | REST [ ] NEXT [ ] |
+
+ [let | COMMAND [ NEXT 1 head COMMANDS at ] |
+
+ COMMAND
+ [
+ NEXT length 1 =
+ [ COMMAND call ]
+ [
+ NEXT 2 tail 1 head* string>number
+ COMMAND 1 tail*
+ call
+ ]
+ if
+ ]
+ when ]
+
+ REST COMMANDS interpret-string ]
+ ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-L-system-string ( L-SYSTEM -- )
+ L-SYSTEM string>>
+ L-SYSTEM rules>>
+ iterate-string
+ L-SYSTEM (>>string) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: do-camera-look-at ( CAMERA -- )
+
+ [let | EYE [ CAMERA pos>> ]
+ FOCUS [ CAMERA clone 1 step-turtle pos>> ]
+ UP [ CAMERA clone 90 pitch-up 1 step-turtle pos>> CAMERA pos>> v- ]
+ |
+
+ EYE FOCUS UP gl-look-at ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: generate-display-list ( L-SYSTEM -- )
+
+ L-SYSTEM find-gl-context
+
+ L-SYSTEM display-list>> GL_COMPILE glNewList
+
+ turtle
+ L-SYSTEM string>>
+ L-SYSTEM commands>>
+ interpret-string
+ drop
+
+ glEndList ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <L-system> draw-gadget* ( L-SYSTEM -- )
+
+ black gl-clear
+
+ GL_FLAT glShadeModel
+
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ -1 1 -1 1 1.5 200 glFrustum
+
+ GL_MODELVIEW glMatrixMode
+
+ glLoadIdentity
+
+ L-SYSTEM camera>> do-camera-look-at
+
+ GL_FRONT_AND_BACK GL_LINE glPolygonMode
+
+ ! draw axis
+ white gl-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
+
+ L-SYSTEM display-list>> glCallList ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <L-system> graft* ( L-SYSTEM -- )
+
+ L-SYSTEM find-gl-context
+
+ 1 glGenLists L-SYSTEM (>>display-list) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <L-system> pref-dim* ( L-SYSTEM -- dim ) { 400 400 } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: camera-left ( L-SYSTEM -- )
+ L-SYSTEM camera>> 5 turn-left drop
+ L-SYSTEM relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: with-camera ( L-SYSTEM QUOT -- )
+ L-SYSTEM camera>> QUOT call drop
+ L-SYSTEM relayout-1 ;
+
+<L-system>
+H{
+ { T{ key-down f f "LEFT" } [ [ 5 turn-left ] with-camera ] }
+ { T{ key-down f f "RIGHT" } [ [ 5 turn-right ] with-camera ] }
+ { T{ key-down f f "UP" } [ [ 5 pitch-down ] with-camera ] }
+ { T{ key-down f f "DOWN" } [ [ 5 pitch-up ] with-camera ] }
+
+ { T{ key-down f f "a" } [ [ 1 step-turtle ] with-camera ] }
+ { T{ key-down f f "z" } [ [ -1 step-turtle ] with-camera ] }
+
+ {
+ T{ key-down f f "x" }
+ [
+ dup iterate-L-system-string
+ dup generate-display-list
+ dup relayout-1
+ drop
+ ]
+ }
+
+}
+set-gestures
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: L-system ( -- L-system )
+
+ <L-system> new-gadget
+
+ turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
projects / factor.git / commitdiff