extra/L-system/L-system.factor

   1
   2 USING: accessors arrays assocs calendar colors
   3 combinators.short-circuit help.markup help.syntax kernel locals
   4 math math.functions math.matrices math.order math.parser
   5 math.trig math.vectors opengl opengl.demo-support opengl.gl
   6 sbufs sequences strings threads ui.gadgets ui.gadgets.worlds
   7 ui.gestures ui.render ui.tools.workspace ;
   8
   9 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  10
  11 IN: L-system
  12
  13 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  14
  15 TUPLE: <turtle> pos ori angle length thickness color vertices saved ;
  16
  17 DEFER: default-L-parser-values
  18
  19 : reset-turtle ( turtle -- turtle )
  20   { 0 0 0 } clone   >>pos
  21   3 identity-matrix >>ori
  22   V{ } clone >>vertices
  23   V{ } clone >>saved
  24
  25   default-L-parser-values ;
  26
  27 : turtle ( -- turtle ) <turtle> new reset-turtle ;
  28
  29 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  30
  31 :: step-turtle ( TURTLE LENGTH -- turtle )
  32
  33   TURTLE
  34     TURTLE pos>>   TURTLE ori>> { 0 0 LENGTH } m.v   v+
  35   >>pos ;
  36
  37 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  38
  39 :: Rx ( ANGLE -- Rx )
  40
  41   [let | ANGLE [ ANGLE deg>rad ] |
  42
  43     [let | A [ ANGLE cos     ]
  44            B [ ANGLE sin neg ]
  45            C [ ANGLE sin     ]
  46            D [ ANGLE cos     ] |
  47
  48       { { 1 0 0 }
  49         { 0 A B }
  50         { 0 C D } }
  51
  52     ] ] ;
  53
  54 :: Ry ( ANGLE -- Ry )
  55
  56   [let | ANGLE [ ANGLE deg>rad ] |
  57
  58     [let | A [ ANGLE cos     ]
  59            B [ ANGLE sin     ]
  60            C [ ANGLE sin neg ]
  61            D [ ANGLE cos     ] |
  62
  63       { { A 0 B }
  64         { 0 1 0 }
  65         { C 0 D } }
  66
  67     ] ] ;
  68
  69 :: Rz ( ANGLE -- Rz )
  70
  71   [let | ANGLE [ ANGLE deg>rad ] |
  72
  73     [let | A [ ANGLE cos     ]
  74            B [ ANGLE sin neg ]
  75            C [ ANGLE sin     ]
  76            D [ ANGLE cos     ] |
  77
  78       { { A B 0 }
  79         { C D 0 }
  80         { 0 0 1 } }
  81
  82     ] ] ;
  83
  84 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  85
  86 :: apply-rotation ( TURTLE ROTATION -- turtle )
  87
  88   TURTLE  TURTLE ori>> ROTATION m.  >>ori ;
  89
  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 ;
  93
  94 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  95
  96 : pitch-up   ( turtle angle -- turtle ) neg rotate-x ;
  97 : pitch-down ( turtle angle -- turtle )     rotate-x ;
  98
  99 : turn-left  ( turtle angle -- turtle )     rotate-y ;
 100 : turn-right ( turtle angle -- turtle ) neg rotate-y ;
 101
 102 : roll-left  ( turtle angle -- turtle ) neg rotate-z ;
 103 : roll-right ( turtle angle -- turtle )     rotate-z ;
 104
 105 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 106
 107 : V ( -- V ) { 0 1 0 } ;
 108
 109 : X ( turtle -- 3array ) ori>> [ first  ] map ;
 110 : Y ( turtle -- 3array ) ori>> [ second ] map ;
 111 : Z ( turtle -- 3array ) ori>> [ third  ] map ;
 112
 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 ;
 116
 117 :: roll-until-horizontal ( TURTLE -- turtle )
 118
 119   TURTLE
 120
 121     V         TURTLE Z  cross normalize  set-X
 122
 123     TURTLE Z  TURTLE X  cross normalize  set-Y ;
 124
 125 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 126
 127 :: strafe-up ( TURTLE LENGTH -- turtle )
 128   TURTLE 90 pitch-up LENGTH step-turtle 90 pitch-down ;
 129
 130 :: strafe-down ( TURTLE LENGTH -- turtle )
 131   TURTLE 90 pitch-down LENGTH step-turtle 90 pitch-up ;
 132
 133 :: strafe-left ( TURTLE LENGTH -- turtle )
 134   TURTLE 90 turn-left LENGTH step-turtle 90 turn-right ;
 135
 136 :: strafe-right ( TURTLE LENGTH -- turtle )
 137   TURTLE 90 turn-right LENGTH step-turtle 90 turn-left ;
 138
 139 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 140
 141 : polygon ( vertices -- ) GL_POLYGON glBegin [ first3 glVertex3d ] each glEnd ;
 142
 143 : start-polygon ( turtle -- turtle ) dup vertices>> delete-all ;
 144
 145 : finish-polygon ( turtle -- turtle ) dup vertices>> polygon ;
 146
 147 : polygon-vertex ( turtle -- turtle ) dup [ pos>> ] [ vertices>> ] bi push ;
 148
 149 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 150
 151 : record-vertex ( turtle -- turtle ) dup pos>> first3 glVertex3d ;
 152
 153 : draw-forward ( turtle length -- turtle )
 154   GL_LINES glBegin [ record-vertex ] dip step-turtle record-vertex glEnd ;
 155
 156 : move-forward ( turtle length -- turtle ) step-turtle polygon-vertex ;
 157
 158 : sneak-forward ( turtle length -- turtle ) step-turtle ;
 159
 160 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 161
 162 : scale-length ( turtle m -- turtle ) over length>> * >>length ;
 163 : scale-angle  ( turtle m -- turtle ) over angle>>  * >>angle  ;
 164
 165 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 166
 167 : set-thickness ( turtle i -- turtle ) dup glLineWidth >>thickness ;
 168
 169 : scale-thickness ( turtle m -- turtle )
 170   over thickness>> * 0.5 max set-thickness ;
 171
 172 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 173
 174 : color-table ( -- colors )
 175   {
 176     T{ rgba f 0    0    0    1 } ! black
 177     T{ rgba f 0.5  0.5  0.5  1 } ! grey
 178     T{ rgba f 1    0    0    1 } ! red
 179     T{ rgba f 1    1    0    1 } ! yellow
 180     T{ rgba f 0    1    0    1 } ! green
 181     T{ rgba f 0.25 0.88 0.82 1 } ! turquoise
 182     T{ rgba f 0    0    1    1 } ! blue
 183     T{ rgba f 0.63 0.13 0.94 1 } ! purple
 184     T{ rgba f 0.00 0.50 0.00 1 } ! dark green
 185     T{ rgba f 0.00 0.82 0.82 1 } ! dark turquoise
 186     T{ rgba f 0.00 0.00 0.50 1 } ! dark blue
 187     T{ rgba f 0.58 0.00 0.82 1 } ! dark purple
 188     T{ rgba f 0.50 0.00 0.00 1 } ! dark red
 189     T{ rgba f 0.25 0.25 0.25 1 } ! dark grey
 190     T{ rgba f 0.75 0.75 0.75 1 } ! medium grey
 191     T{ rgba f 1    1    1    1 } ! white
 192   } ;
 193
 194 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 195
 196 ! : material-color ( color -- )
 197 !   GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
 198
 199 : material-color ( color -- )
 200   GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot color>raw 4array gl-material ;
 201
 202 : set-color ( turtle i -- turtle )
 203   dup color-table nth dup gl-color material-color >>color ;
 204
 205 : inc-color ( turtle -- turtle ) dup color>> 1 + set-color ;
 206
 207 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 208
 209 : save-turtle    ( turtle -- turtle ) dup clone over saved>> push ;
 210
 211 : restore-turtle ( turtle -- turtle ) saved>> pop dup color>> set-color ;
 212
 213 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 214
 215 : default-L-parser-values ( turtle -- turtle )
 216   1 >>length 45 >>angle 1 >>thickness 2 >>color ;
 217
 218 : L-parser-dialect ( -- commands )
 219
 220   {
 221       { "+" [ dup angle>> turn-left  ] }
 222       { "-" [ dup angle>> turn-right ] }
 223       { "&" [ dup angle>> pitch-down ] }
 224       { "^" [ dup angle>> pitch-up   ] }
 225       { "<" [ dup angle>> roll-left  ] }
 226       { ">" [ dup angle>> roll-right ] }
 227
 228       { "|" [ 180.0         rotate-y ] }
 229       { "%" [ 180.0         rotate-z ] }
 230       { "$" [ roll-until-horizontal  ]  }
 231
 232       { "F" [ dup length>>     draw-forward  ] }
 233       { "Z" [ dup length>> 2 / draw-forward  ] }
 234       { "f" [ dup length>>     move-forward  ] }
 235       { "z" [ dup length>> 2 / move-forward  ] }
 236       { "g" [ dup length>>     sneak-forward ] }
 237       { "." [ polygon-vertex                 ] }
 238
 239       { "[" [ save-turtle      ] }
 240       { "]" [ restore-turtle   ] }
 241
 242       { "{" [ start-polygon    ] }
 243       { "}" [ finish-polygon   ] }
 244
 245       { "/" [ 1.1 scale-length    ] } ! double quote command in lparser
 246       { "'" [ 0.9 scale-length    ] }
 247       { ";" [ 1.1 scale-angle     ] }
 248       { ":" [ 0.9 scale-angle     ] }
 249       { "?" [ 1.4 scale-thickness ] }
 250       { "!" [ 0.7 scale-thickness ] }
 251
 252       { "c" [ dup color>> 1 + color-table length mod set-color ] }
 253
 254     }
 255     ;
 256
 257 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 258
 259 TUPLE: <L-system> < gadget
 260   camera display-list pedestal paused
 261   turtle-values
 262   commands axiom rules string ;
 263
 264 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 265
 266 :: iterate-system ( GADGET -- ) GADGET pedestal>> 0.5 + GADGET (>>pedestal) ;
 267
 268 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 269
 270 :: start-rotation-thread ( GADGET -- )
 271   GADGET f >>paused drop
 272   [
 273     [
 274       GADGET paused>>
 275         [ f ]
 276         [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
 277       if
 278     ]
 279     loop
 280   ]
 281   in-thread ;
 282
 283 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 284
 285 : open-paren  ( -- ch ) CHAR: ( ;
 286 : close-paren ( -- ch ) CHAR: ) ;
 287
 288 : open-paren?  ( obj -- ? ) open-paren  = ;
 289 : close-paren? ( obj -- ? ) close-paren = ;
 290
 291 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 292
 293 :: read-instruction ( STRING -- next rest )
 294
 295   { [ STRING length 1 > ] [ STRING second open-paren? ] } 0&&
 296     [ STRING  close-paren STRING index 1 + cut ]
 297     [ STRING  1                            cut ]
 298   if ;
 299
 300 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 301
 302 :: iterate-string-loop ( STRING RULES ACCUM -- )
 303   STRING empty? not
 304     [
 305       STRING read-instruction
 306
 307       [let | REST [ ] NEXT [ ] |
 308
 309         NEXT 1 head RULES at  NEXT  or  ACCUM push-all
 310
 311         REST RULES ACCUM iterate-string-loop ]
 312     ]
 313   when ;
 314
 315 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 316
 317 :: iterate-string ( STRING RULES -- string )
 318
 319   [let | ACCUM [ STRING length  10 *  <sbuf> ] |
 320
 321     STRING RULES ACCUM iterate-string-loop
 322
 323     ACCUM >string ] ;
 324
 325 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 326
 327 :: interpret-string ( STRING COMMANDS -- )
 328
 329   STRING empty? not
 330     [
 331       STRING read-instruction
 332
 333       [let | REST [ ] NEXT [ ] |
 334
 335         [let | COMMAND [ NEXT 1 head COMMANDS at ] |
 336
 337           COMMAND
 338             [
 339               NEXT length 1 =
 340                 [ COMMAND call ]
 341                 [
 342                   NEXT 2 tail 1 head* string>number
 343                   COMMAND 1 tail*
 344                   call
 345                 ]
 346               if
 347             ]
 348           when ]
 349
 350         REST COMMANDS interpret-string ]
 351     ]
 352   when ;
 353
 354 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 355
 356 :: iterate-L-system-string ( L-SYSTEM -- )
 357   L-SYSTEM string>> L-SYSTEM axiom>> or
 358   L-SYSTEM rules>>
 359   iterate-string
 360   L-SYSTEM (>>string) ;
 361
 362 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 363
 364 :: do-camera-look-at ( CAMERA -- )
 365
 366   [let | EYE   [ CAMERA pos>> ]
 367          FOCUS [ CAMERA clone 1 step-turtle pos>> ]
 368          UP    [ CAMERA clone 90 pitch-up 1 step-turtle pos>> CAMERA pos>> v- ]
 369        |
 370
 371     EYE FOCUS UP gl-look-at ] ;
 372
 373 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 374
 375 :: generate-display-list ( L-SYSTEM -- )
 376
 377   L-SYSTEM find-gl-context
 378
 379   L-SYSTEM display-list>> GL_COMPILE glNewList
 380
 381     turtle
 382     L-SYSTEM turtle-values>> [ ] or call
 383     L-SYSTEM string>> L-SYSTEM axiom>> or
 384     L-SYSTEM commands>>
 385     interpret-string
 386     drop
 387
 388   glEndList ;
 389
 390 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 391
 392 M:: <L-system> draw-gadget* ( L-SYSTEM -- )
 393
 394   black gl-clear
 395
 396   GL_FLAT glShadeModel
 397
 398   GL_PROJECTION glMatrixMode
 399   glLoadIdentity
 400   -1 1 -1 1 1.5 200 glFrustum
 401
 402   GL_MODELVIEW glMatrixMode
 403
 404   glLoadIdentity
 405
 406   L-SYSTEM camera>> do-camera-look-at
 407
 408   GL_FRONT_AND_BACK GL_LINE glPolygonMode
 409
 410   ! draw axis
 411   white gl-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
 412
 413   ! rotate pedestal
 414
 415   L-SYSTEM pedestal>> 0 0 1 glRotated
 416
 417   L-SYSTEM display-list>> glCallList ;
 418
 419 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 420
 421 M:: <L-system> graft* ( L-SYSTEM -- )
 422
 423   L-SYSTEM find-gl-context
 424
 425   1 glGenLists L-SYSTEM (>>display-list) ;
 426
 427 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 428
 429 M:: <L-system> pref-dim* ( L-SYSTEM -- dim ) { 400 400 } ;
 430
 431 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 432
 433 :: with-camera ( L-SYSTEM QUOT -- )
 434   L-SYSTEM camera>> QUOT call drop
 435   L-SYSTEM relayout-1 ;
 436
 437 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 438
 439 <L-system>
 440 H{
 441   { T{ key-down f f "LEFT"  } [ [  5 turn-left   ] with-camera ] }
 442   { T{ key-down f f "RIGHT" } [ [  5 turn-right  ] with-camera ] }
 443   { T{ key-down f f "UP"    } [ [  5 pitch-down  ] with-camera ] }
 444   { T{ key-down f f "DOWN"  } [ [  5 pitch-up    ] with-camera ] }
 445
 446   { T{ key-down f f "a"     } [ [  1 step-turtle ] with-camera ] }
 447   { T{ key-down f f "z"     } [ [ -1 step-turtle ] with-camera ] }
 448
 449   { T{ key-down f f "q"     } [ [ 5 roll-left    ] with-camera ] }
 450   { T{ key-down f f "w"     } [ [ 5 roll-right   ] with-camera ] }
 451
 452   { T{ key-down f { A+ } "LEFT"  } [ [ 1 strafe-left  ] with-camera ] }
 453   { T{ key-down f { A+ } "RIGHT" } [ [ 1 strafe-right ] with-camera ] }
 454   { T{ key-down f { A+ } "UP"    } [ [ 1 strafe-up    ] with-camera ] }
 455   { T{ key-down f { A+ } "DOWN"  } [ [ 1 strafe-down  ] with-camera ] }
 456
 457   { T{ key-down f f "r"     } [ start-rotation-thread          ] }
 458
 459   {
 460     T{ key-down f f "x" }
 461     [
 462       dup iterate-L-system-string
 463       dup generate-display-list
 464       dup relayout-1
 465       drop
 466     ]
 467   }
 468
 469   { T{ key-down f f "F1" } [ drop "L-system" help-window ] }
 470
 471 }
 472 set-gestures
 473
 474 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 475
 476 : L-system ( -- L-system )
 477
 478   <L-system> new-gadget
 479
 480     0 >>pedestal
 481
 482     ! turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ;
 483
 484     turtle 90 pitch-down -5 step-turtle 2 strafe-up >>camera
 485
 486     dup start-rotation-thread
 487
 488   ;
 489
 490 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 491
 492 ARTICLE: "L-system" "L-system"
 493
 494 "Press 'x' to iterate the L-system." $nl
 495
 496 "Camera control:"
 497
 498 { $table
 499
 500   { "a" "Forward" }
 501   { "z" "Backward" }
 502
 503   { "LEFT" "Turn left" }
 504   { "RIGHT" "Turn right" }
 505   { "UP" "Pitch down" }
 506   { "DOWN" "Pitch up" }
 507
 508   { "q" "Roll left" }
 509   { "w" "Roll right" } } ;
 510
 511 ABOUT: "L-system"