2 USING: accessors arrays assocs calendar colors
3 combinators.short-circuit help help.markup help.syntax kernel
4 math math.functions math.matrices math.order math.parser
5 math.trig math.vectors opengl opengl.demo-support opengl.gl
6 opengl.glu sbufs sequences strings threads ui.gadgets
7 ui.gadgets.worlds ui.gestures ui.render ;
9 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
13 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
15 TUPLE: turtle pos ori angle length thickness color vertices saved ;
17 DEFER: default-L-parser-values
19 : reset-turtle ( turtle -- turtle )
21 3 <identity-matrix> >>ori
25 default-L-parser-values ;
27 : <turtle> ( -- turtle ) turtle new reset-turtle ;
29 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
31 :: step-turtle ( TURTLE LENGTH -- turtle )
34 TURTLE pos>> TURTLE ori>> { 0 0 LENGTH } mdotv v+
37 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
84 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
86 :: apply-rotation ( TURTLE ROTATION -- turtle )
88 TURTLE TURTLE ori>> ROTATION mdot >>ori ;
90 : rotate-x ( turtle angle -- turtle ) Rx apply-rotation ;
91 : rotate-y ( turtle angle -- turtle ) Ry apply-rotation ;
92 : rotate-z ( turtle angle -- turtle ) Rz apply-rotation ;
94 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
96 : pitch-up ( turtle angle -- turtle ) neg rotate-x ;
97 : pitch-down ( turtle angle -- turtle ) rotate-x ;
99 : turn-left ( turtle angle -- turtle ) rotate-y ;
100 : turn-right ( turtle angle -- turtle ) neg rotate-y ;
102 : roll-left ( turtle angle -- turtle ) neg rotate-z ;
103 : roll-right ( turtle angle -- turtle ) rotate-z ;
105 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
107 : V ( -- V ) { 0 1 0 } ;
109 : X ( turtle -- 3array ) ori>> [ first ] map ;
110 : Y ( turtle -- 3array ) ori>> [ second ] map ;
111 : Z ( turtle -- 3array ) ori>> [ third ] map ;
113 : set-X ( turtle seq -- turtle ) over ori>> [ set-first ] 2each ;
114 : set-Y ( turtle seq -- turtle ) over ori>> [ set-second ] 2each ;
115 : set-Z ( turtle seq -- turtle ) over ori>> [ set-third ] 2each ;
117 :: roll-until-horizontal ( TURTLE -- turtle )
121 V TURTLE Z cross normalize set-X
123 TURTLE Z TURTLE X cross normalize set-Y ;
125 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
127 :: strafe-up ( TURTLE LENGTH -- turtle )
128 TURTLE 90 pitch-up LENGTH step-turtle 90 pitch-down ;
130 :: strafe-down ( TURTLE LENGTH -- turtle )
131 TURTLE 90 pitch-down LENGTH step-turtle 90 pitch-up ;
133 :: strafe-left ( TURTLE LENGTH -- turtle )
134 TURTLE 90 turn-left LENGTH step-turtle 90 turn-right ;
136 :: strafe-right ( TURTLE LENGTH -- turtle )
137 TURTLE 90 turn-right LENGTH step-turtle 90 turn-left ;
139 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
141 : polygon ( vertices -- ) GL_POLYGON glBegin [ first3 glVertex3d ] each glEnd ;
143 : start-polygon ( turtle -- turtle ) dup vertices>> delete-all ;
145 : finish-polygon ( turtle -- turtle ) dup vertices>> polygon ;
147 : polygon-vertex ( turtle -- turtle ) dup [ pos>> ] [ vertices>> ] bi push ;
149 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
151 : record-vertex ( turtle -- turtle ) dup pos>> first3 glVertex3d ;
153 : draw-forward ( turtle length -- turtle )
154 GL_LINES glBegin [ record-vertex ] dip step-turtle record-vertex glEnd ;
156 : move-forward ( turtle length -- turtle ) step-turtle polygon-vertex ;
158 : sneak-forward ( turtle length -- turtle ) step-turtle ;
160 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
162 : scale-length ( turtle m -- turtle ) over length>> * >>length ;
163 : scale-angle ( turtle m -- turtle ) over angle>> * >>angle ;
165 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
167 : set-thickness ( turtle i -- turtle ) dup glLineWidth >>thickness ;
169 : scale-thickness ( turtle m -- turtle )
170 over thickness>> * 0.5 max set-thickness ;
172 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
174 : color-table ( -- colors )
185 COLOR: dark-turquoise
187 T{ rgba f 0.58 0.00 0.82 1 } ! dark purple
194 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
196 ! : material-color ( color -- )
197 ! GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
199 : material-color ( color -- )
200 GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot >rgba-components 4array
203 : set-color ( turtle i -- turtle )
204 dup color-table nth dup gl-color material-color >>color ;
206 : inc-color ( turtle -- turtle ) dup color>> 1 + set-color ;
208 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
210 : save-turtle ( turtle -- turtle ) dup clone over saved>> push ;
212 : restore-turtle ( turtle -- turtle ) saved>> pop dup color>> set-color ;
214 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
216 : default-L-parser-values ( turtle -- turtle )
217 1 >>length 45 >>angle 1 >>thickness 2 >>color ;
219 : L-parser-dialect ( -- commands )
222 { "+" [ dup angle>> turn-left ] }
223 { "-" [ dup angle>> turn-right ] }
224 { "&" [ dup angle>> pitch-down ] }
225 { "^" [ dup angle>> pitch-up ] }
226 { "<" [ dup angle>> roll-left ] }
227 { ">" [ dup angle>> roll-right ] }
229 { "|" [ 180.0 rotate-y ] }
230 { "%" [ 180.0 rotate-z ] }
231 { "$" [ roll-until-horizontal ] }
233 { "F" [ dup length>> draw-forward ] }
234 { "Z" [ dup length>> 2 / draw-forward ] }
235 { "f" [ dup length>> move-forward ] }
236 { "z" [ dup length>> 2 / move-forward ] }
237 { "g" [ dup length>> sneak-forward ] }
238 { "." [ polygon-vertex ] }
240 { "[" [ save-turtle ] }
241 { "]" [ restore-turtle ] }
243 { "{" [ start-polygon ] }
244 { "}" [ finish-polygon ] }
246 { "/" [ 1.1 scale-length ] } ! double quote command in lparser
247 { "'" [ 0.9 scale-length ] }
248 { ";" [ 1.1 scale-angle ] }
249 { ":" [ 0.9 scale-angle ] }
250 { "?" [ 1.4 scale-thickness ] }
251 { "!" [ 0.7 scale-thickness ] }
253 { "c" [ dup color>> 1 + color-table length mod set-color ] }
258 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
260 TUPLE: L-system < gadget
261 camera display-list pedestal paused
263 commands axiom rules string ;
265 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
267 :: iterate-system ( GADGET -- ) GADGET pedestal>> 0.5 + GADGET pedestal<< ;
269 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
271 :: start-rotation-thread ( GADGET -- )
272 GADGET f >>paused drop
277 [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
284 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
286 : open-paren ( -- ch ) CHAR: ( ;
287 : close-paren ( -- ch ) CHAR: ) ;
289 : open-paren? ( obj -- ? ) open-paren = ;
290 : close-paren? ( obj -- ? ) close-paren = ;
292 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
294 :: read-instruction ( STRING -- next rest )
296 { [ STRING length 1 > ] [ STRING second open-paren? ] } 0&&
297 [ STRING close-paren STRING index 1 + cut ]
301 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
303 :: iterate-string-loop ( STRING RULES ACCUM -- )
307 STRING read-instruction :> ( NEXT REST )
309 NEXT 1 head RULES at NEXT or ACCUM push-all
311 REST RULES ACCUM iterate-string-loop ]
315 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
317 :: iterate-string ( STRING RULES -- string )
319 [let STRING length 10 * <sbuf> :> ACCUM
321 STRING RULES ACCUM iterate-string-loop
325 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
327 :: interpret-string ( TURTLE STRING COMMANDS -- turtle )
332 STRING read-instruction :> ( NEXT REST )
333 NEXT 1 head COMMANDS at :> COMMAND
337 [ TURTLE COMMAND call( turtle -- turtle ) drop ]
340 NEXT 2 tail 1 head* string>number
342 call( turtle x -- turtle ) drop
348 TURTLE REST COMMANDS interpret-string drop ]
352 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
354 :: iterate-L-system-string ( L-SYSTEM -- )
355 L-SYSTEM string>> L-SYSTEM axiom>> or
360 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
362 :: do-camera-look-at ( CAMERA -- )
366 CAMERA clone 1 step-turtle pos>> :> FOCUS
367 CAMERA clone 90 pitch-up 1 step-turtle pos>> CAMERA pos>> v- :> UP
369 EYE FOCUS UP gl-look-at ] ;
371 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
373 :: generate-display-list ( L-SYSTEM -- )
375 L-SYSTEM find-gl-context
377 L-SYSTEM display-list>> GL_COMPILE glNewList
380 L-SYSTEM turtle-values>> [ ] or call( turtle -- turtle )
381 L-SYSTEM string>> L-SYSTEM axiom>> or
388 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
390 M:: L-system draw-gadget* ( L-SYSTEM -- )
392 COLOR: black gl-clear
396 GL_PROJECTION glMatrixMode
398 -1 1 -1 1 1.5 200 glFrustum
400 GL_MODELVIEW glMatrixMode
404 L-SYSTEM camera>> do-camera-look-at
406 GL_FRONT_AND_BACK GL_LINE glPolygonMode
409 COLOR: white gl-color GL_LINES
410 glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
414 L-SYSTEM pedestal>> 0 0 1 glRotated
416 L-SYSTEM display-list>> glCallList ;
418 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
420 M:: L-system graft* ( L-SYSTEM -- )
422 L-SYSTEM find-gl-context
424 1 glGenLists L-SYSTEM display-list<< ;
426 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
428 M:: L-system pref-dim* ( L-SYSTEM -- dim ) { 400 400 } ;
430 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
432 :: with-camera ( L-SYSTEM QUOT -- )
433 L-SYSTEM camera>> QUOT call drop
434 L-SYSTEM relayout-1 ; inline
436 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
440 { T{ key-down f f "LEFT" } [ [ 5 turn-left ] with-camera ] }
441 { T{ key-down f f "RIGHT" } [ [ 5 turn-right ] with-camera ] }
442 { T{ key-down f f "UP" } [ [ 5 pitch-down ] with-camera ] }
443 { T{ key-down f f "DOWN" } [ [ 5 pitch-up ] with-camera ] }
445 { T{ key-down f f "a" } [ [ 1 step-turtle ] with-camera ] }
446 { T{ key-down f f "z" } [ [ -1 step-turtle ] with-camera ] }
448 { T{ key-down f f "q" } [ [ 5 roll-left ] with-camera ] }
449 { T{ key-down f f "w" } [ [ 5 roll-right ] with-camera ] }
451 { T{ key-down f { A+ } "LEFT" } [ [ 1 strafe-left ] with-camera ] }
452 { T{ key-down f { A+ } "RIGHT" } [ [ 1 strafe-right ] with-camera ] }
453 { T{ key-down f { A+ } "UP" } [ [ 1 strafe-up ] with-camera ] }
454 { T{ key-down f { A+ } "DOWN" } [ [ 1 strafe-down ] with-camera ] }
456 { T{ key-down f f "r" } [ start-rotation-thread ] }
459 T{ key-down f f "x" }
461 dup iterate-L-system-string
462 dup generate-display-list
468 { T{ key-down f f "F1" } [ drop "L-system" help ] }
473 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
475 : <L-system> ( -- L-system )
481 ! <turtle> 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ;
483 <turtle> 90 pitch-down -5 step-turtle 2 strafe-up >>camera
485 dup start-rotation-thread
489 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
491 ARTICLE: "L-system" "L-system"
493 "Press 'x' to iterate the L-system." $nl
502 { "LEFT" "Turn left" }
503 { "RIGHT" "Turn right" }
504 { "UP" "Pitch down" }
505 { "DOWN" "Pitch up" }
508 { "w" "Roll right" } } ;