extra/lsys/ui/ui.factor

   1
   2 USING: kernel namespaces threads math math.order math.vectors
   3        quotations sequences
   4        opengl
   5        opengl.gl
   6        colors
   7        ui
   8        ui.gestures
   9        ui.gadgets
  10        ui.gadgets.packs
  11        ui.gadgets.labels
  12        ui.gadgets.buttons
  13        ui.gadgets.lib
  14        ui.gadgets.slate
  15        ui.gadgets.theme
  16        vars rewrite-closures
  17        self pos ori turtle opengl.camera
  18        lsys.tortoise lsys.tortoise.graphics
  19        lsys.strings.rewrite lsys.strings.interpret
  20        combinators.short-circuit accessors ;
  21
  22        ! lsys.strings
  23        ! lsys.strings.rewrite
  24        ! lsys.strings.interpret
  25
  26 IN: lsys.ui
  27
  28 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  29
  30 VAR: slate
  31
  32 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  33
  34 VAR: camera
  35
  36 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  37
  38 VAR: model
  39
  40 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  41
  42 : display ( -- )
  43
  44 black set-clear-color GL_COLOR_BUFFER_BIT glClear
  45
  46 GL_FLAT glShadeModel
  47
  48 GL_PROJECTION glMatrixMode
  49 glLoadIdentity
  50 -1 1 -1 1 1.5 200 glFrustum
  51
  52 GL_MODELVIEW glMatrixMode
  53
  54 glLoadIdentity
  55
  56 camera> do-look-at
  57
  58 GL_FRONT_AND_BACK GL_LINE glPolygonMode
  59
  60 white color>raw glColor4d
  61
  62 ! white set-color
  63
  64 GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
  65
  66 color> set-color
  67
  68 model> glCallList ;
  69
  70 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  71
  72 : result>model ( -- )
  73 slate> find-gl-context
  74 model> GL_COMPILE glNewList result> interpret glEndList ;
  75
  76 : build-model ( -- )
  77 tortoise-stack> delete-all
  78 vertices> delete-all
  79 reset-turtle
  80 default-values> call
  81 model-values> call
  82 result>model
  83 [ display ] closed-quot slate> set-slate-action
  84 slate> relayout-1 ;
  85
  86 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  87
  88 USING: hashtables namespaces.lib ui.gadgets.handler ;
  89
  90 : camera-action ( quot -- quot )
  91 [ drop [ ] camera> with-self slate> relayout-1 ] make* closed-quot ;
  92
  93 VAR: frame
  94 VAR: handler
  95
  96 DEFER: model-chooser
  97 DEFER: scene-chooser
  98 DEFER: empty-model
  99
 100 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 101
 102 : lsys-controller ( -- )
 103
 104 <pile>
 105
 106 {
 107
 108 [ "Load" <label> reverse-video-theme ]
 109
 110 [ "Models" <label> [ drop model-chooser ] closed-quot <bevel-button> ]
 111 [ "Scenes" <label> [ drop scene-chooser ] closed-quot <bevel-button> ]
 112
 113 [ "Model" <label> reverse-video-theme ]
 114
 115 [ "Iterate" <label> [ drop iterate build-model ] closed-quot <bevel-button> ]
 116 [ "Build model" <label> [ drop build-model ] closed-quot <bevel-button> ]
 117
 118 [ "Camera" <label> reverse-video-theme ]
 119
 120 [ "Turn left" <label> [ 5 turn-left ] camera-action <bevel-button> ]
 121 [ "Turn right" <label> [ 5 turn-right ] camera-action <bevel-button> ]
 122 [ "Pitch down" <label> [ 5 pitch-down ] camera-action <bevel-button> ]
 123 [ "Pitch up" <label> [ 5 pitch-up ] camera-action <bevel-button> ]
 124
 125 [ "Forward - a"  <label> [  1 step-turtle ] camera-action <bevel-button> ]
 126 [ "Backward - z" <label> [ -1 step-turtle ] camera-action <bevel-button> ]
 127
 128 [ "Roll left - q" <label> [ 5 roll-left ] camera-action <bevel-button> ]
 129 [ "Roll right - w" <label> [ 5 roll-right ] camera-action <bevel-button> ]
 130
 131 [ "Strafe left - (alt)" <label> [ 1 strafe-left ] camera-action <bevel-button> ]
 132 [ "Strafe right - (alt)" <label> [ 1 strafe-right ] camera-action <bevel-button> ]
 133 [ "Strafe down - (alt)" <label> [ 1 strafe-up ] camera-action <bevel-button> ]
 134 [ "Strafe up - (alt)" <label> [ 1 strafe-down ] camera-action <bevel-button> ]
 135
 136 [ "View 1 - 1" <label>
 137   [ pos> norm reset-turtle 90 turn-left step-turtle 180 turn-left ]
 138   camera-action <bevel-button> ]
 139
 140 [ "View 2 - 2" <label>
 141   [ pos> norm reset-turtle 90 pitch-up step-turtle 180 pitch-down ]
 142   camera-action <bevel-button> ]
 143
 144 [ "View 3 - 3" <label>
 145   [ pos> norm reset-turtle step-turtle 180 turn-left ]
 146   camera-action <bevel-button> ]
 147
 148 [ "View 4 - 4" <label>
 149   [ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
 150   camera-action <bevel-button> ]
 151
 152 }
 153
 154 [ call add-gadget ] each
 155 1 >>fill
 156 "L-system control" open-window ;
 157
 158 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 159
 160 : lsys-viewer ( -- )
 161
 162 [ ] <slate> >slate
 163 { 400 400 } clone slate> set-slate-pdim
 164
 165 slate> <handler>
 166
 167 {
 168
 169 { T{ key-down f f "LEFT" }  [ [ 5 turn-left ] camera-action ] }
 170 { T{ key-down f f "RIGHT" } [ [ 5 turn-right ] camera-action ] }
 171 { T{ key-down f f "UP" }    [ [ 5 pitch-down ] camera-action ] }
 172 { T{ key-down f f "DOWN" }  [ [ 5 pitch-up ] camera-action ] }
 173
 174 { T{ key-down f f "a" } [ [ 1 step-turtle ] camera-action ] }
 175 { T{ key-down f f "z" } [ [ -1 step-turtle ] camera-action ] }
 176
 177 { T{ key-down f f "q" } [ [ 5 roll-left ] camera-action ] }
 178 { T{ key-down f f "w" } [ [ 5 roll-right ] camera-action ] }
 179
 180 { T{ key-down f { A+ } "LEFT" }  [ [ 1 strafe-left ] camera-action ] }
 181 { T{ key-down f { A+ } "RIGHT" } [ [ 1 strafe-right ] camera-action ] }
 182 { T{ key-down f { A+ } "UP" }    [ [ 1 strafe-up ] camera-action ] }
 183 { T{ key-down f { A+ } "DOWN" }  [ [ 1 strafe-down ] camera-action ] }
 184
 185 { T{ key-down f f "1" }
 186   [ [ pos> norm reset-turtle 90 turn-left step-turtle 180 turn-left ]
 187     camera-action ] }
 188
 189 { T{ key-down f f "2" }
 190   [ [ pos> norm reset-turtle 90 pitch-up step-turtle 180 pitch-down ]
 191     camera-action ] }
 192
 193 { T{ key-down f f "3" }
 194 [ [ pos> norm reset-turtle step-turtle 180 turn-left ]
 195     camera-action ] }
 196
 197 { T{ key-down f f "4" }
 198 [ [ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
 199     camera-action ] }
 200
 201 } [ make* ] map >hashtable >>table
 202
 203 "L-system view" open-window
 204
 205 500 sleep
 206
 207 slate> find-gl-context
 208 1 glGenLists >model
 209
 210 <turtle> >camera
 211
 212 [ camera> >self
 213   reset-turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left
 214 ] with-scope
 215
 216 init-color-table
 217
 218 <tortoise> >self
 219
 220 V{ } clone >tortoise-stack
 221
 222 V{ } clone >vertices
 223
 224 empty-model
 225
 226 build-model
 227
 228 ;
 229
 230 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 231 ! Examples
 232 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 233
 234 : koch ( -- ) lparser-dialect   [ 90 >angle ] >model-values
 235
 236 H{ { "K" "[[a|b] '(0.41)f'(2.439) |<(60) [a|b]]" }
 237    { "k" "[ c'(0.5) K]" }
 238    { "a" "[d <(120) d <(120) d ]" }
 239    { "b" "e" }
 240    { "e" "[^ '(.2887)f'(3.4758) &(180)      +z{.-(120)f-(120)f}]" }
 241    { "d" "[^ '(.2887)f'(3.4758) &(109.5111) +zk{.-(120)f-(120)f}]" }
 242 } >rules
 243
 244 "K" >result ;
 245
 246 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 247
 248 : spiral-0 ( -- ) lparser-dialect   [ 10 >angle 5 >thickness ] >model-values
 249
 250 "[P]|[P]" >result
 251
 252 H{ { "P" "[A]>>>>>>>>>[cB]>>>>>>>>>[ccC]>>>>>>>>>[cccD]" }
 253    { "A" "F+;'A" }
 254    { "B" "F!+F+;'B" }
 255    { "C" "F!^+F^+;'C" }
 256    { "D" "F!>^+F>^+;'D" }
 257 } >rules ;
 258
 259 : spiral-0-scene ( -- )
 260 spiral-0
 261 22 iterations
 262 build-model
 263 [ reset-turtle 90 turn-left 16 step-turtle 180 turn-left ]
 264 camera> with-self slate> relayout-1 ;
 265
 266 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 267
 268 : tree-5 ( -- ) lparser-dialect   [ 5 >angle   1 >thickness ] >model-values
 269
 270 "c(4)FFS" >result
 271
 272 H{ { "S" "FFR>(60)R>(60)R>(60)R>(60)R>(60)R>(30)S" }
 273    { "R" "[Ba]" }
 274    { "a" "$tF[Cx]Fb" }
 275    { "b" "$tF[Dy]Fa" }
 276    { "B" "&B" }
 277    { "C" "+C" }
 278    { "D" "-D" }
 279
 280    { "x" "a" }
 281    { "y" "b" }
 282
 283    { "F" "'(1.25)F'(.8)" }
 284 } >rules ;
 285
 286 : tree-5-scene ( -- )
 287 tree-5
 288 9 iterations
 289 build-model
 290 [ reset-turtle 90 pitch-down -70 step-turtle 50 strafe-up ] camera> with-self
 291 slate> relayout-1 ;
 292
 293 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 294
 295 : abop-1 ( -- ) lparser-dialect   [ 45 >angle   5 >thickness ] >model-values
 296
 297 H{ { "A" "F[&'(.8)!BL]>(137)'!(.9)A" }
 298    { "B" "F[-'(.8)!(.9)$CL]'!(.9)C" }
 299    { "C" "F[+'(.8)!(.9)$BL]'!(.9)B" }
 300
 301    { "L" "~c(8){+(30)f-(120)f-(120)f}" }
 302 } >rules
 303
 304 "c(12)FFAL" >result ;
 305
 306 : abop-1-scene ( -- )
 307 abop-1
 308 8 iterations
 309 build-model
 310 [ reset-turtle
 311   90 pitch-up 7 step-turtle 90 pitch-down 4 step-turtle 90 pitch-down ]
 312 camera> with-self slate> relayout-1 ;
 313
 314 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 315
 316 : abop-2 ( -- ) lparser-dialect   [ 30 >angle   5 >thickness ] >model-values
 317
 318 H{ { "A" "F[&'(.7)!BL]>(137)[&'(.6)!BL]>(137)'(.9)!(.9)A" }
 319    { "B" "F[-'(.7)!(.9)$CL]'(.9)!(.9)C" }
 320    { "C" "F[+'(.7)!(.9)$BL]'(.9)!(.9)B" }
 321
 322    { "L" "~c(8){+(45)f(.1)-(45)f(.1)-(45)f(.1)+(45)|+(45)f(.1)-(45)f(.1)-(45)f(.1)}" }
 323
 324 } >rules
 325
 326 "c(12)FAL" >result ;
 327
 328 : abop-2-scene ( -- )
 329 abop-2
 330 7 iterations
 331 build-model
 332 [ reset-turtle { 0 4 4 } >pos 90 pitch-down ]
 333 camera> with-self slate> relayout-1 ;
 334
 335 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 336
 337 : abop-3 ( -- ) lparser-dialect   [ 30 >angle   5 >thickness ] >model-values
 338
 339 H{ { "A" "!(.9)t(.4)FB>(94)B>(132)B" }
 340    { "B" "[&t(.4)F$A]" }
 341    { "F" "'(1.25)F'(.8)" }
 342 } >rules
 343
 344 "c(12)FA" >result ;
 345
 346 : abop-3-scene ( -- )
 347 abop-3 11 iterations build-model
 348 [ reset-turtle { 0 47 29 } >pos 90 pitch-down ] camera> with-self
 349 slate> relayout-1 ;
 350
 351 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 352
 353 : abop-4 ( -- ) lparser-dialect   [ 18 >angle   5 >thickness ] >model-values
 354
 355 H{ { "N" "FII[&(60)rY]>(90)[&(45)'(0.8)rA]>(90)[&(60)rY]>(90)[&(45)'(0.8)rD]!FIK" }
 356    { "Y" "[c(4){++l.--l.--l.++|++l.--l.--l.}]" }
 357    { "l" "g(.2)l" }
 358    { "K" "[!c(2)FF>w>(72)w>(72)w>(72)w>(72)w]" }
 359    { "w" "[c(2)^!F][c(5)&(72){-(54)f(3)+(54)f(3)|-(54)f(3)+(54)f(3)}]" }
 360    { "f" "_" }
 361
 362    { "A" "B" }
 363    { "B" "C" }
 364    { "C" "D" }
 365    { "D" "E" }
 366    { "E" "G" }
 367    { "G" "H" }
 368    { "H" "N" }
 369
 370    { "I" "FoO" }
 371    { "O" "FoP" }
 372    { "P" "FoQ" }
 373    { "Q" "FoR" }
 374    { "R" "FoS" }
 375    { "S" "FoT" }
 376    { "T" "FoU" }
 377    { "U" "FoV" }
 378    { "V" "FoW" }
 379    { "W" "FoX" }
 380    { "X" "_" }
 381
 382    { "o" "$t(-0.03)" }
 383    { "r" "~(30)" }
 384 } >rules
 385
 386 "c(12)&(20)N" >result ;
 387
 388 : abop-4-scene ( -- )
 389 abop-4 21 iterations build-model
 390 [ reset-turtle
 391   { 53 25 36 } >pos
 392   { { 0.57 -0.14 -0.80 } { -0.81 -0.18 -0.54 } { -0.07 0.97 -0.22 } }
 393   >ori
 394 ] camera> with-self slate> relayout-1 ;
 395
 396 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 397
 398 : abop-5 ( -- ) lparser-dialect   [ 5 >angle   5 >thickness ] >model-values
 399
 400 H{ { "a" "F[+(45)l][-(45)l]^;ca" }
 401
 402    { "l" "j" }
 403    { "j" "h" }
 404    { "h" "s" }
 405    { "s" "d" }
 406    { "d" "x" }
 407    { "x" "a" }
 408
 409    { "F" "'(1.17)F'(.855)" }
 410 } >rules
 411
 412 "&(90)+(90)a" >result ;
 413
 414 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 415
 416 : abop-6 ( -- ) lparser-dialect   [ 5 >angle   5 >thickness ] >model-values
 417
 418 "&(90)+(90)FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x" >result
 419
 420 H{ { "a" "F[cdx][cex]F!(.9)a" }
 421    { "x" "a" }
 422
 423    { "d" "+d" }
 424    { "e" "-e" }
 425
 426    { "F" "'(1.25)F'(.8)" }
 427 } >rules ;
 428
 429 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 430
 431 : airhorse ( -- ) lparser-dialect [ 10 >angle 5 >thickness ] >model-values
 432
 433 "C" >result
 434
 435 H{ { "C" "LBW" }
 436
 437    { "B" "[[''aH]|[g]]" }
 438    { "a" "Fs+;'a" }
 439    { "g" "Ft+;'g" }
 440    { "s" "[::cc!!!!&&[FFcccZ]^^^^FFcccZ]" }
 441    { "t" "[c!!!!&[FF]^^FF]" }
 442
 443    { "L" "O" }
 444    { "O" "P" }
 445    { "P" "Q" }
 446    { "Q" "R" }
 447    { "R" "U" }
 448    { "U" "X" }
 449    { "X" "Y" }
 450    { "Y" "V" }
 451    { "V" "[cc!!!&(90)[Zp]|[Zp]]" }
 452    { "p" "h>(120)h>(120)h" }
 453    { "h" "[+(40)!F'''p]" }
 454
 455    { "H" "[cccci[>(50)dcFFF][<(50)ecFFF]]" }
 456    { "d" "Z!&Z!&:'d" }
 457    { "e" "Z!^Z!^:'e" }
 458    { "i" "-:/i" }
 459
 460    { "W" "[%[!!cb][<<<!!cb][>>>!!cb]]" }
 461    { "b" "Fl!+Fl+;'b" }
 462    { "l" "[-cc{--z++z++z--|--z++z++z}]" }
 463 } >rules ;
 464
 465 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 466
 467 : empty-model ( -- )
 468 lparser-dialect
 469 [ ] >model-values
 470 " " >result
 471 H{ } >rules ;
 472
 473 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 474
 475 : model-chooser ( -- )
 476 <pile>
 477 {
 478 [ "abop-1" <label> [ drop abop-1 build-model ] closed-quot <bevel-button> ]
 479 [ "abop-2" <label> [ drop abop-2 build-model ] closed-quot <bevel-button> ]
 480 [ "abop-3" <label> [ drop abop-3 build-model ] closed-quot <bevel-button> ]
 481 [ "abop-4" <label> [ drop abop-4 build-model ] closed-quot <bevel-button> ]
 482 [ "abop-5" <label> [ drop abop-5 build-model ] closed-quot <bevel-button> ]
 483 [ "abop-6" <label> [ drop abop-6 build-model ] closed-quot <bevel-button> ]
 484 [ "tree-5" <label> [ drop tree-5 build-model ] closed-quot <bevel-button> ]
 485 [ "airhorse" <label> [ drop airhorse build-model ] closed-quot <bevel-button> ]
 486 [ "spiral-0" <label> [ drop spiral-0 build-model ] closed-quot <bevel-button> ]
 487 [ "koch" <label> [ drop koch build-model ] closed-quot <bevel-button> ]
 488 }
 489 [ call add-gadget ] each
 490 1 >>fill
 491 "L-system models" open-window ;
 492
 493 : scene-chooser ( -- )
 494 <pile>
 495 {
 496 [ "abop-1" <label> [ drop abop-1-scene ] closed-quot <bevel-button> ]
 497 [ "abop-2" <label> [ drop abop-2-scene ] closed-quot <bevel-button> ]
 498 [ "tree-5" <label> [ drop tree-5-scene ] closed-quot <bevel-button> ]
 499 }
 500 [ call add-gadget ] each
 501 1 >>fill
 502 "L-system scenes" open-window ;
 503
 504 : lsys-window* ( -- )
 505 [ lsys-controller lsys-viewer ] with-ui ;
 506
 507 MAIN: lsys-window*