contrib/lindenmayer/lindenmayer.factor

   1 ! Eduardo Cavazos - wayo.cavazos@gmail.com
   2
   3 REQUIRES: contrib/math
   4           contrib/vars
   5           contrib/slate/slate
   6           contrib/lindenmayer/opengl
   7           contrib/lindenmayer/turtle
   8           contrib/lindenmayer/camera
   9           contrib/lindenmayer/camera-slate ;
  10
  11 USING: kernel alien namespaces arrays vectors math opengl sequences threads
  12        hashtables strings gadgets
  13        math-contrib vars slate turtle turtle-camera camera-slate
  14        opengl-contrib ;
  15
  16 IN: lindenmayer
  17
  18 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  19 ! roll-until-horizontal
  20 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  21
  22 : V ( -- V ) { 0 1 0 } ;
  23
  24 : X ( -- 3array ) orientation> [ first  ] map ;
  25 : Y ( -- 3array ) orientation> [ second ] map ;
  26 : Z ( -- 3array ) orientation> [ third  ] map ;
  27
  28 : set-X ( seq -- ) orientation> [ 0 swap set-nth ] 2each ;
  29 : set-Y ( seq -- ) orientation> [ 1 swap set-nth ] 2each ;
  30 : set-Z ( seq -- ) orientation> [ 2 swap set-nth ] 2each ;
  31
  32 : roll-until-horizontal ( -- )
  33 V Z cross normalize set-X
  34 Z X cross normalize set-Y ;
  35
  36 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  37
  38 : record-vertex ( -- ) position> gl-vertex ;
  39
  40 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  41
  42 DEFER: polygon-vertex
  43
  44 : draw-forward ( length -- )
  45 GL_LINES glBegin record-vertex step-turtle record-vertex glEnd ;
  46
  47 : move-forward ( length -- ) step-turtle polygon-vertex ;
  48
  49 : sneak-forward ( length -- ) step-turtle ;
  50
  51 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  52
  53 ! (v0 - v1) x (v1 - v2)
  54
  55 : polygon-normal ( {_v0_v1_v2_} -- normal )
  56 0 over nth over 1 swap nth v- swap
  57 1 over nth swap 2 swap nth v- cross ;
  58
  59 ! Test and replace with:
  60 !
  61 ! : v0-v1 ( { v0 v1 v2 } -- vec ) first2 v- ;
  62 !
  63 ! : v1-v2 ( { v0 v1 v2 } -- vec ) first3 v- nip ;
  64 !
  65 ! : polygon-normal ( { v0 v1 v2 } -- normal ) dup v0-v1 swap v1-v2 cross ;
  66
  67 : (polygon) ( vertices -- )
  68 GL_POLYGON glBegin dup polygon-normal gl-normal [ gl-vertex ] each glEnd ;
  69
  70 : polygon ( vertices -- ) dup length 3 >= [ (polygon) ] [ drop ] if ;
  71
  72 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  73
  74 ! Maybe use an array instead of a vector
  75
  76 VAR: vertices
  77
  78 : start-polygon ( -- ) 0 <vector> >vertices ;
  79
  80 : finish-polygon ( -- ) vertices> polygon ;
  81
  82 : polygon-vertex ( -- ) position> vertices> push ;
  83
  84 : reset-vertices start-polygon ;
  85
  86 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  87 ! Lindenmayer string rewriting
  88 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  89
  90 ! Maybe use an array instead of a quot in the work of segment
  91
  92 VAR: rules
  93
  94 : segment ( str -- seq )
  95 { { [ dup "" = ] [ drop [ ] ] }
  96   { [ dup length 1 = ] [ unit ] }
  97   { [ 1 over nth CHAR: ( = ]
  98     [ CHAR: ) over index 1 +            ! str i
  99       2dup head                         ! str i head
 100       -rot tail                         ! head tail
 101       segment swap add* ] }
 102   { [ t ] [ dup 1 head swap 1 tail segment swap add* ] } }
 103 cond ;
 104
 105 : lookup ( str -- str ) dup 1 head rules get hash dup [ nip ] [ drop ] if ;
 106
 107 : rewrite ( str -- str ) segment [ lookup ] map concat ;
 108
 109 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 110 ! Lindenmayer string interpretation
 111 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 112
 113 SYMBOL: command-table
 114
 115 : segment-command ( seg -- command ) 1 head ;
 116
 117 ! : segment-parameter ( seg -- parameter )
 118 ! dup length 1 - 2 swap rot subseq parse call ;
 119
 120 : segment-parameter ( seg -- parameter )
 121 dup length 1 - 2 swap rot subseq string>number ;
 122
 123 : segment-parts ( seg -- param command )
 124 dup segment-parameter swap segment-command ;
 125
 126 : exec-command ( str -- ) command-table get hash dup [ call ] [ drop ] if ;
 127
 128 : exec-command-with-param ( param command -- )
 129 command-table get hash dup [ peek unit call ] [ 2drop ] if ;
 130
 131 : (interpret) ( seg -- )
 132 dup length 1 =
 133 [ exec-command ] [ segment-parts exec-command-with-param ] if ;
 134
 135 : interpret ( str -- ) segment [ (interpret) ] each ;
 136
 137 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 138 ! Lparser dialect
 139 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 140
 141 VAR: angle
 142 VAR: len
 143 VAR: thickness
 144 VAR: color-index
 145
 146 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 147
 148 DEFER: set-thickness
 149 DEFER: set-color-index
 150
 151 TUPLE: state position orientation angle len thickness color-index ;
 152
 153 VAR: states
 154
 155 : reset-state-stack ( -- ) V{ } clone >states ;
 156
 157 : save-state ( -- )
 158 position> orientation> angle> len> thickness> color-index> <state>
 159 states> push ;
 160
 161 : restore-state ( -- )
 162 states> pop
 163 dup state-position    >position
 164 dup state-orientation >orientation
 165 dup state-len         >len
 166 dup state-angle       >angle
 167 dup state-color-index set-color-index
 168 dup state-thickness   set-thickness
 169 drop ;
 170
 171 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 172
 173 : scale-len ( m -- ) len> * >len ;
 174
 175 : scale-angle ( m -- ) angle> * >angle ;
 176
 177 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 178
 179 VAR: color-table
 180
 181 : init-color-table ( -- )
 182 { { 0    0    0 }    ! black
 183   { 0.5  0.5  0.5 }  ! grey
 184   { 1    0    0 }    ! red
 185   { 1    1    0 }    ! yellow
 186   { 0    1    0 }    ! green
 187   { 0.25 0.88 0.82 } ! turquoise
 188   { 0    0    1 }    ! blue
 189   { 0.63 0.13 0.94 } ! purple
 190   { 0.00 0.50 0.00 } ! dark green
 191   { 0.00 0.82 0.82 } ! dark turquoise
 192   { 0.00 0.00 0.50 } ! dark blue
 193   { 0.58 0.00 0.82 } ! dark purple
 194   { 0.50 0.00 0.00 } ! dark red
 195   { 0.25 0.25 0.25 } ! dark grey
 196   { 0.75 0.75 0.75 } ! medium grey
 197   { 1    1    1 }    ! white
 198 } [ 1 set-color-alpha ] map color-table set ;
 199
 200 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 201
 202 : material-color ( color -- )
 203 GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material-fv ;
 204
 205 : set-color-index ( i -- )
 206 dup >color-index color-table> nth dup gl-color material-color ;
 207
 208 : inc-color-index ( -- ) color-index> 1 + set-color-index ;
 209
 210 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 211
 212 : set-thickness ( i -- ) dup >thickness glLineWidth ;
 213
 214 : scale-thickness ( m -- ) thickness> * 0.5 max set-thickness ;
 215
 216 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 217
 218 VAR: default-values
 219 VAR: model-values
 220
 221 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 222
 223 : lparser-dialect ( -- )
 224
 225 [ 1 >len   45 >angle   1 >thickness   2 >color-index ] >default-values
 226
 227 H{ { "+" [ angle get     turn-left ] }
 228    { "-" [ angle get     turn-right ] }
 229    { "&" [ angle get     pitch-down ] }
 230    { "^" [ angle get     pitch-up ] }
 231    { "<" [ angle get     roll-left ] }
 232    { ">" [ angle get     roll-right ] }
 233
 234    { "|" [ 180.0         rotate-y ] }
 235    { "%" [ 180.0         rotate-z ] }
 236    { "$" [ roll-until-horizontal ]  }
 237
 238    { "F" [ len get     draw-forward ] }
 239    { "Z" [ len get 2 / draw-forward ] }
 240    { "f" [ len get     move-forward ] }
 241    { "z" [ len get 2 / move-forward ] }
 242    { "g" [ len get     sneak-forward ] }
 243    { "." [ polygon-vertex ] }
 244
 245    { "[" [ save-state ] }
 246    { "]" [ restore-state ] }
 247    { "{" [ start-polygon ] }
 248    { "}" [ finish-polygon ] }
 249
 250    { "/" [ 1.1 scale-len ] } ! double quote command in lparser
 251    { "'" [ 0.9 scale-len ] }
 252    { ";" [ 1.1 scale-angle ] }
 253    { ":" [ 0.9 scale-angle ] }
 254    { "?" [ 1.4 scale-thickness ] }
 255    { "!" [ 0.7 scale-thickness ] }
 256
 257    { "c" [ color-index> 1 + color-table get length mod set-color-index ] }
 258
 259 } command-table set ;
 260
 261 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 262
 263 VAR: axiom
 264 VAR: result
 265
 266 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 267
 268 : iterate ( -- ) result> rewrite >result ;
 269
 270 : iterations ( n -- ) [ iterate ] times ;
 271
 272 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 273
 274 VAR: model
 275
 276 : init-model ( -- ) 1 glGenLists >model ;
 277
 278 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 279
 280 : display ( -- )
 281
 282 black gl-clear-color
 283
 284 GL_FLAT glShadeModel
 285
 286 GL_PROJECTION glMatrixMode
 287 glLoadIdentity
 288 -1 1 -1 1 1.5 200 glFrustum
 289
 290 GL_MODELVIEW glMatrixMode
 291
 292 glLoadIdentity
 293
 294 [ do-look-at ] camera> with-turtle
 295
 296 GL_COLOR_BUFFER_BIT glClear
 297
 298 GL_FRONT_AND_BACK GL_LINE glPolygonMode
 299
 300 white gl-color
 301 GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
 302
 303 color-index> set-color-index
 304
 305 model> glCallList ;
 306
 307 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 308
 309 : init-turtle ( -- ) <turtle> >turtle ;
 310
 311 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 312
 313 : init-camera ( -- ) <turtle> >camera ;
 314
 315 : reset-camera ( -- ) [
 316 reset-turtle
 317 45 turn-left
 318 45 pitch-up
 319 5 step-turtle
 320 180 turn-left
 321 ] camera> with-turtle ;
 322
 323 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 324
 325 : init-slate ( -- )
 326 <camera-slate> >slate
 327 namespace slate> set-slate-ns
 328 slate> "L-system" open-titled-window
 329 [ display ] >action ;
 330
 331 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 332
 333 : init ( -- )
 334 init-turtle
 335 init-turtle-stack
 336 init-camera reset-camera
 337 init-model
 338
 339 2 >color-index
 340 init-color-table
 341
 342 init-slate ;
 343
 344 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 345
 346 : result>model ( -- )
 347 [ model> GL_COMPILE glNewList result> interpret glEndList ] >action .slate ;
 348
 349 : build-model ( -- )
 350 reset-state-stack
 351 reset-vertices
 352 reset-turtle
 353 default-values> call
 354 model-values> call
 355 result>model
 356 3000 sleep
 357 [ display ] >action .slate ;
 358
 359 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 360 ! Examples
 361 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 362
 363 : koch ( -- ) lparser-dialect   [ 90 >angle ] >model-values
 364
 365 H{ { "K" "[[a|b] '(0.41)f'(2.439) |<(60) [a|b]]" }
 366    { "k" "[ c'(0.5) K]" }
 367    { "a" "[d <(120) d <(120) d ]" }
 368    { "b" "e" }
 369    { "e" "[^ '(.2887)f'(3.4758) &(180)      +z{.-(120)f-(120)f}]" }
 370    { "d" "[^ '(.2887)f'(3.4758) &(109.5111) +zk{.-(120)f-(120)f}]" }
 371 } >rules
 372
 373 "K" >axiom   axiom> >result ;
 374
 375 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 376
 377 : spiral-0 ( -- ) lparser-dialect   [ 10 >angle 5 >thickness ] >model-values
 378
 379 "[P]|[P]" >axiom
 380
 381 H{ { "P" "[A]>>>>>>>>>[cB]>>>>>>>>>[ccC]>>>>>>>>>[cccD]" }
 382    { "A" "F+;'A" }
 383    { "B" "F!+F+;'B" }
 384    { "C" "F!^+F^+;'C" }
 385    { "D" "F!>^+F>^+;'D" }
 386 } >rules
 387
 388 axiom> >result ;
 389
 390 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 391
 392 : tree-5 ( -- ) lparser-dialect   [ 5 >angle   1 >thickness ] >model-values
 393
 394 "c(4)FFS" >result
 395
 396 H{ { "S" "FFR>(60)R>(60)R>(60)R>(60)R>(60)R>(30)S" }
 397    { "R" "[Ba]" }
 398    { "a" "$tF[Cx]Fb" }
 399    { "b" "$tF[Dy]Fa" }
 400    { "B" "&B" }
 401    { "C" "+C" }
 402    { "D" "-D" }
 403
 404    { "x" "a" }
 405    { "y" "b" }
 406
 407    { "F" "'(1.25)F'(.8)" }
 408 } >rules ;
 409
 410 : tree-5-scene ( -- )
 411 tree-5
 412 9 iterations
 413 build-model
 414 [ reset-turtle 90 pitch-down -70 step-turtle 50 strafe-up ] camera> with-turtle
 415 .slate ;
 416
 417 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 418
 419 : abop-1 ( -- ) lparser-dialect   [ 45 >angle   5 >thickness ] >model-values
 420
 421 H{ { "A" "F[&'(.8)!BL]>(137)'!(.9)A" }
 422    { "B" "F[-'(.8)!(.9)$CL]'!(.9)C" }
 423    { "C" "F[+'(.8)!(.9)$BL]'!(.9)B" }
 424
 425    { "L" "~c(8){+(30)f-(120)f-(120)f}" }
 426 } >rules
 427
 428 "c(12)FFAL" >result ;
 429
 430 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 431
 432 : abop-2 ( -- ) lparser-dialect   [ 30 >angle   5 >thickness ] >model-values
 433
 434 H{ { "A" "F[&'(.7)!BL]>(137)[&'(.6)!BL]>(137)'(.9)!(.9)A" }
 435    { "B" "F[-'(.7)!(.9)$CL]'(.9)!(.9)C" }
 436    { "C" "F[+'(.7)!(.9)$BL]'(.9)!(.9)B" }
 437
 438    { "L" "~c(8){+(45)f(.1)-(45)f(.1)-(45)f(.1)+(45)|+(45)f(.1)-(45)f(.1)-(45)f(.1)}" }
 439
 440 } >rules
 441
 442 "c(12)FAL" >result ;
 443
 444 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 445
 446 : abop-3 ( -- ) lparser-dialect   [ 30 >angle   5 >thickness ] >model-values
 447
 448 H{ { "A" "!(.9)t(.4)FB>(94)B>(132)B" }
 449    { "B" "[&t(.4)F$A]" }
 450    { "F" "'(1.25)F'(.8)" }
 451 } >rules
 452
 453 "c(12)FA" >result ;
 454
 455 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 456
 457 : abop-4 ( -- ) lparser-dialect   [ 18 >angle   5 >thickness ] >model-values
 458
 459 H{ { "N" "FII[&(60)rY]>(90)[&(45)'(0.8)rA]>(90)[&(60)rY]>(90)[&(45)'(0.8)rD]!FIK" }
 460    { "Y" "[c(4){++l.--l.--l.++|++l.--l.--l.}]" }
 461    { "l" "g(.2)l" }
 462    { "K" "[!c(2)FF>w>(72)w>(72)w>(72)w>(72)w]" }
 463    { "w" "[c(2)^!F][c(5)&(72){-(54)f(3)+(54)f(3)|-(54)f(3)+(54)f(3)}]" }
 464    { "f" "_" }
 465
 466    { "A" "B" }
 467    { "B" "C" }
 468    { "C" "D" }
 469    { "D" "E" }
 470    { "E" "G" }
 471    { "G" "H" }
 472    { "H" "N" }
 473
 474    { "I" "FoO" }
 475    { "O" "FoP" }
 476    { "P" "FoQ" }
 477    { "Q" "FoR" }
 478    { "R" "FoS" }
 479    { "S" "FoT" }
 480    { "T" "FoU" }
 481    { "U" "FoV" }
 482    { "V" "FoW" }
 483    { "W" "FoX" }
 484    { "X" "_" }
 485
 486    { "o" "$t(-0.03)" }
 487    { "r" "~(30)" }
 488 } >rules
 489
 490 "c(12)&(20)N" >result ;
 491
 492 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 493
 494 : abop-5 ( -- ) lparser-dialect   [ 5 >angle   5 >thickness ] >model-values
 495
 496 H{ { "a" "F[+(45)l][-(45)l]^;ca" }
 497
 498    { "l" "j" }
 499    { "j" "h" }
 500    { "h" "s" }
 501    { "s" "d" }
 502    { "d" "x" }
 503    { "x" "a" }
 504
 505    { "F" "'(1.17)F'(.855)" }
 506 } >rules
 507
 508 "&(90)+(90)a" >result ;
 509
 510 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 511
 512 : abop-6 ( -- ) lparser-dialect   [ 5 >angle   5 >thickness ] >model-values
 513
 514 "&(90)+(90)FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x" >result
 515
 516 H{ { "a" "F[cdx][cex]F!(.9)a" }
 517    { "x" "a" }
 518
 519    { "d" "+d" }
 520    { "e" "-e" }
 521
 522    { "F" "'(1.25)F'(.8)" }
 523 } >rules ;
 524
 525 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 526
 527 : airhorse ( -- ) lparser-dialect [ 10 >angle 5 >thickness ] >model-values
 528
 529 "C" >result
 530
 531 H{ { "C" "LBW" }
 532
 533    { "B" "[[''aH]|[g]]" }
 534    { "a" "Fs+;'a" }
 535    { "g" "Ft+;'g" }
 536    { "s" "[::cc!!!!&&[FFcccZ]^^^^FFcccZ]" }
 537    { "t" "[c!!!!&[FF]^^FF]" }
 538
 539    { "L" "O" }
 540    { "O" "P" }
 541    { "P" "Q" }
 542    { "Q" "R" }
 543    { "R" "U" }
 544    { "U" "X" }
 545    { "X" "Y" }
 546    { "Y" "V" }
 547    { "V" "[cc!!!&(90)[Zp]|[Zp]]" }
 548    { "p" "h>(120)h>(120)h" }
 549    { "h" "[+(40)!F'''p]" }
 550
 551    { "H" "[cccci[>(50)dcFFF][<(50)ecFFF]]" }
 552    { "d" "Z!&Z!&:'d" }
 553    { "e" "Z!^Z!^:'e" }
 554    { "i" "-:/i" }
 555
 556    { "W" "[%[!!cb][<<<!!cb][>>>!!cb]]" }
 557    { "b" "Fl!+Fl+;'b" }
 558    { "l" "[-cc{--z++z++z--|--z++z++z}]" }
 559 } >rules ;
 560
 561 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 562
 563 ! These should be moved into a separate file. They are used to pretty
 564 ! print matricies and vectors.
 565
 566 USING: styles prettyprint io ;
 567
 568 : decimal-places ( n d -- n )
 569 10 swap ^ tuck * >fixnum swap /f ;
 570
 571 ! : .mat ( matrix -- ) [ [ 2 decimal-places ] map ] map . ;
 572
 573 : .mat ( matrix -- )
 574 H{ { table-gap 4 } { table-border 4 } }
 575 [ 2 decimal-places pprint ]
 576 tabular-output ;
 577
 578 : .vec ( vector -- ) [ 2 decimal-places ] map . ;
 579
 580 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 581
 582 PROVIDE: lindenmayer ;
 583
 584 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!