extra/L-system/L-system.factor

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