unmaintained/4DNav/4DNav.factor

   1 ! Copyright (C) 2008 Jeff Bigot
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel
   4 namespaces
   5 accessors
   6 assocs
   7 make
   8 math
   9 math.functions
  10 math.trig
  11 math.parser
  12 hashtables
  13 sequences
  14 combinators
  15 continuations
  16 colors
  17 colors.constants
  18 prettyprint
  19 vars
  20 quotations
  21 io
  22 io.directories
  23 io.pathnames
  24 help.markup
  25 io.files
  26 ui.gadgets.panes
  27  ui
  28        ui.gadgets
  29        ui.traverse
  30        ui.gadgets.borders
  31        ui.gadgets.frames
  32        ui.gadgets.tracks
  33        ui.gadgets.labels
  34        ui.gadgets.labeled
  35        ui.gadgets.lists
  36        ui.gadgets.buttons
  37        ui.gadgets.packs
  38        ui.gadgets.grids
  39        ui.gadgets.corners
  40        ui.gestures
  41        ui.gadgets.scrollers
  42 splitting
  43 vectors
  44 math.vectors
  45 values
  46 4DNav.turtle
  47 4DNav.window3D
  48 4DNav.deep
  49 4DNav.space-file-decoder
  50 models
  51 fry
  52 adsoda
  53 adsoda.tools
  54 ;
  55 QUALIFIED-WITH: ui.pens.solid s
  56 QUALIFIED-WITH: ui.gadgets.wrappers w
  57
  58
  59 IN: 4DNav
  60 VALUE: selected-file
  61 VALUE: translation-step
  62 VALUE: rotation-step
  63
  64 3 \ translation-step set-value
  65 5 \ rotation-step set-value
  66
  67 VAR: selected-file-model
  68 VAR: observer3d
  69 VAR: view1
  70 VAR: view2
  71 VAR: view3
  72 VAR: view4
  73 VAR: present-space
  74
  75 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  76
  77 ! namespace utilities
  78
  79 : closed-quot ( quot -- quot )
  80   namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;
  81
  82 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  83 ! waiting for deep-cleave-quots
  84
  85 : 4D-Rxy ( angle -- Rx ) deg>rad
  86 [ 1.0 , 0.0 , 0.0       , 0.0 ,
  87   0.0 , 1.0 , 0.0       , 0.0 ,
  88   0.0 , 0.0 , dup cos  , dup sin neg  ,
  89   0.0 , 0.0 , dup sin  , dup cos  ,  ] 4 make-matrix nip ;
  90
  91 : 4D-Rxz ( angle -- Ry ) deg>rad
  92 [ 1.0 , 0.0       , 0.0 , 0.0 ,
  93   0.0 , dup cos  , 0.0 , dup sin neg  ,
  94   0.0 , 0.0       , 1.0 , 0.0 ,
  95   0.0 , dup sin  , 0.0 , dup cos  ,  ] 4 make-matrix nip ;
  96
  97 : 4D-Rxw ( angle -- Rz ) deg>rad
  98 [ 1.0 , 0.0       , 0.0           , 0.0 ,
  99   0.0 , dup cos  , dup sin neg  , 0.0 ,
 100   0.0 , dup sin  , dup cos     , 0.0 ,
 101   0.0 , 0.0       , 0.0           , 1.0 , ] 4 make-matrix nip ;
 102
 103 : 4D-Ryz ( angle -- Rx ) deg>rad
 104 [ dup cos  , 0.0 , 0.0 , dup sin neg  ,
 105   0.0       , 1.0 , 0.0 , 0.0 ,
 106   0.0       , 0.0 , 1.0 , 0.0 ,
 107   dup sin  , 0.0 , 0.0 , dup cos  ,   ] 4 make-matrix nip ;
 108
 109 : 4D-Ryw ( angle -- Ry ) deg>rad
 110 [ dup cos  , 0.0 , dup sin neg  , 0.0 ,
 111   0.0       , 1.0 , 0.0           , 0.0 ,
 112   dup sin  , 0.0 , dup cos     , 0.0 ,
 113   0.0       , 0.0 , 0.0        , 1.0 ,  ] 4 make-matrix nip ;
 114
 115 : 4D-Rzw ( angle -- Rz ) deg>rad
 116 [ dup cos  , dup sin neg  , 0.0 , 0.0 ,
 117   dup sin  , dup cos     , 0.0 , 0.0 ,
 118   0.0       , 0.0           , 1.0 , 0.0 ,
 119   0.0       , 0.0          , 0.0 , 1.0 ,  ] 4 make-matrix nip ;
 120
 121 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 122 ! UI
 123 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 124
 125 : button* ( string quot -- button )
 126     closed-quot <repeat-button>  ;
 127
 128 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 129 !
 130 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 131
 132 : model-projection-chooser ( -- gadget )
 133    observer3d> projection-mode>>
 134    { { 1 "perspective" } { 0 "orthogonal" } }
 135    <radio-buttons> ;
 136
 137 : collision-detection-chooser ( -- gadget )
 138    observer3d> collision-mode>>
 139    { { t "on" } { f "off" }  } <radio-buttons> ;
 140
 141 : model-projection ( x -- space )
 142     present-space>  swap space-project ;
 143
 144 : update-observer-projections (  -- )
 145     view1> relayout-1
 146     view2> relayout-1
 147     view3> relayout-1
 148     view4> relayout-1 ;
 149
 150 : update-model-projections (  -- )
 151     0 model-projection <model> view1> model<<
 152     1 model-projection <model> view2> model<<
 153     2 model-projection <model> view3> model<<
 154     3 model-projection <model> view4> model<< ;
 155
 156 : camera-action ( quot -- quot )
 157     '[ drop _ observer3d>
 158     with-self update-observer-projections ]
 159     closed-quot ;
 160
 161 : win3D ( text gadget -- )
 162     "navigateur 4D : " rot append open-window ;
 163
 164 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 165 ! 4D object manipulation
 166 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 167
 168 : (mvt-4D) ( quot -- )
 169     present-space>
 170         swap call space-ensure-solids
 171     >present-space
 172     update-model-projections
 173     update-observer-projections ; inline
 174
 175 : rotation-4D ( m -- )
 176     '[ _ [ [ middle-of-space dup vneg ] keep
 177         swap space-translate ] dip
 178          space-transform
 179          swap space-translate
 180     ] (mvt-4D) ;
 181
 182 : translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ;
 183
 184 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 185 ! menu
 186 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 187
 188 : menu-rotations-4D ( -- gadget )
 189     3 3 <frame>
 190         { 1 1 } >>filled-cell
 191          <pile> 1 >>fill
 192           "XY +" [ drop rotation-step 4D-Rxy rotation-4D ]
 193                 button* add-gadget
 194           "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ]
 195                 button* add-gadget
 196        @top-left grid-add
 197         <pile> 1 >>fill
 198           "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ]
 199                 button* add-gadget
 200           "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ]
 201                 button* add-gadget
 202        @top grid-add
 203         <pile> 1 >>fill
 204           "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ]
 205                 button* add-gadget
 206           "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ]
 207                 button* add-gadget
 208         @center grid-add
 209          <pile> 1 >>fill
 210           "XW +" [ drop rotation-step 4D-Rxw rotation-4D ]
 211                 button* add-gadget
 212           "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ]
 213                 button* add-gadget
 214         @top-right grid-add
 215          <pile> 1 >>fill
 216           "YW +" [ drop rotation-step 4D-Ryw rotation-4D ]
 217                 button* add-gadget
 218           "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ]
 219                 button* add-gadget
 220        @right grid-add
 221          <pile> 1 >>fill
 222           "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ]
 223                 button* add-gadget
 224           "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ]
 225                 button* add-gadget
 226        @bottom-right grid-add
 227 ;
 228
 229 : menu-translations-4D ( -- gadget )
 230     3 3 <frame>
 231         { 1 1 } >>filled-cell
 232         <pile> 1 >>fill
 233             <shelf> 1 >>fill
 234                 "X+" [ drop {  1 0 0 0 } translation-step v*n
 235                     translation-4D ]
 236                     button* add-gadget
 237                 "X-" [ drop { -1 0 0 0 } translation-step v*n
 238                     translation-4D ]
 239                     button* add-gadget
 240             add-gadget
 241             "YZW" <label> add-gadget
 242          @bottom-right grid-add
 243          <pile> 1 >>fill
 244             "XZW" <label> add-gadget
 245             <shelf> 1 >>fill
 246                 "Y+" [ drop  { 0  1 0 0 } translation-step v*n
 247                     translation-4D ]
 248                     button* add-gadget
 249                 "Y-" [ drop  { 0 -1 0 0 } translation-step v*n
 250                     translation-4D ]
 251                     button* add-gadget
 252                 add-gadget
 253          @top-right grid-add
 254          <pile> 1 >>fill
 255             "XYW" <label> add-gadget
 256             <shelf> 1 >>fill
 257                 "Z+" [ drop { 0 0  1 0 } translation-step v*n
 258                     translation-4D ]
 259                     button* add-gadget
 260                 "Z-" [ drop { 0 0 -1 0 } translation-step v*n
 261                     translation-4D ]
 262                     button* add-gadget
 263                 add-gadget
 264         @top-left grid-add
 265         <pile> 1 >>fill
 266             <shelf> 1 >>fill
 267                 "W+" [ drop { 0 0 0 1  } translation-step v*n
 268                     translation-4D ]
 269                     button* add-gadget
 270                 "W-" [ drop { 0 0 0 -1 } translation-step v*n
 271                     translation-4D ]
 272                     button* add-gadget
 273                 add-gadget
 274             "XYZ" <label> add-gadget
 275         @bottom-left grid-add
 276         "X" <label> @center grid-add
 277 ;
 278
 279 : menu-4D ( -- gadget )
 280     <shelf>
 281         "rotations" <label>     add-gadget
 282         menu-rotations-4D       add-gadget
 283         "translations" <label>  add-gadget
 284         menu-translations-4D    add-gadget
 285         0.5 >>align
 286         { 0 10 } >>gap
 287 ;
 288
 289
 290 ! ------------------------------------------------------
 291
 292 : redraw-model ( space -- )
 293     >present-space
 294     update-model-projections
 295     update-observer-projections ;
 296
 297 : load-model-file ( -- )
 298   selected-file dup selected-file-model> set-model
 299   read-model-file
 300   redraw-model ;
 301
 302 : mvt-3D-X ( turn pitch -- quot )
 303     '[ turtle-pos> norm neg reset-turtle
 304         _ turn-left
 305         _ pitch-up
 306         step-turtle ] ;
 307
 308 : mvt-3D-1 ( -- quot )      90  0 mvt-3D-X ; inline
 309 : mvt-3D-2 ( -- quot )      0  90 mvt-3D-X ; inline
 310 : mvt-3D-3 ( -- quot )      0   0 mvt-3D-X ; inline
 311 : mvt-3D-4 ( -- quot )      45 45 mvt-3D-X ; inline
 312
 313 : camera-button ( string quot -- button )
 314     [ <label>  ] dip camera-action <repeat-button> ;
 315
 316 ! ----------------------------------------------------------
 317 ! file chooser
 318 ! ----------------------------------------------------------
 319 : <run-file-button> ( file-name -- button )
 320   dup '[ drop  _  \ selected-file set-value load-model-file
 321    ]
 322  closed-quot  <roll-button> { 0 0 } >>align ;
 323
 324 : <list-runner> ( -- gadget )
 325     "resource:extra/4DNav"
 326   <pile> 1 >>fill
 327     over dup directory-files
 328     [ ".xml" tail? ] filter
 329     [ append-path ] with map
 330     [ <run-file-button> add-gadget ] each
 331     swap <labeled-gadget> ;
 332
 333 ! -----------------------------------------------------
 334
 335 : menu-rotations-3D ( -- gadget )
 336     3 3 <frame>
 337         { 1 1 } >>filled-cell
 338         "Turn\n left"  [ rotation-step  turn-left  ]
 339             camera-button   @left grid-add
 340         "Turn\n right" [ rotation-step turn-right ]
 341             camera-button   @right grid-add
 342         "Pitch down"   [ rotation-step  pitch-down ]
 343             camera-button   @bottom grid-add
 344         "Pitch up"     [ rotation-step  pitch-up   ]
 345             camera-button   @top grid-add
 346         <shelf>  1 >>fill
 347             "Roll left\n (ctl)"  [ rotation-step  roll-left  ]
 348                 camera-button   add-gadget
 349             "Roll right\n(ctl)"  [ rotation-step  roll-right ]
 350                 camera-button   add-gadget
 351         @center grid-add
 352 ;
 353
 354 : menu-translations-3D ( -- gadget )
 355     3 3 <frame>
 356         { 1 1 } >>filled-cell
 357         "left\n(alt)"        [ translation-step  strafe-left  ]
 358             camera-button @left grid-add
 359         "right\n(alt)"       [ translation-step  strafe-right ]
 360             camera-button @right grid-add
 361         "Strafe up \n (alt)" [ translation-step strafe-up    ]
 362             camera-button @top grid-add
 363         "Strafe down\n (alt)" [ translation-step strafe-down  ]
 364             camera-button @bottom grid-add
 365         <pile>  1 >>fill
 366             "Forward (ctl)"  [  translation-step step-turtle ]
 367                 camera-button add-gadget
 368             "Backward (ctl)"
 369                 [ translation-step neg step-turtle ]
 370                 camera-button   add-gadget
 371         @center grid-add
 372 ;
 373
 374 : menu-quick-views ( -- gadget )
 375     <shelf>
 376         "View 1 (1)" mvt-3D-1 camera-button   add-gadget
 377         "View 2 (2)" mvt-3D-2 camera-button   add-gadget
 378         "View 3 (3)" mvt-3D-3 camera-button   add-gadget
 379         "View 4 (4)" mvt-3D-4 camera-button   add-gadget
 380 ;
 381
 382 : menu-3D ( -- gadget )
 383     <pile>
 384         <shelf>
 385             menu-rotations-3D    add-gadget
 386             menu-translations-3D add-gadget
 387             0.5 >>align
 388             { 0 10 } >>gap
 389         add-gadget
 390         menu-quick-views add-gadget ;
 391
 392 TUPLE: handler < w:wrapper table ;
 393
 394 : <handler> ( child -- handler ) handler w:new-wrapper ;
 395
 396 M: handler handle-gesture ( gesture gadget -- ? )
 397    tuck table>> at dup [ call( gadget -- ) f ] [ 2drop t ] if ;
 398
 399 : add-keyboard-delegate ( obj -- obj )
 400  <handler>
 401 H{
 402         { T{ key-down f f "LEFT" }
 403             [ [ rotation-step turn-left ] camera-action ] }
 404         { T{ key-down f f "RIGHT" }
 405             [ [ rotation-step turn-right ] camera-action ] }
 406         { T{ key-down f f "UP" }
 407             [ [ rotation-step pitch-down ] camera-action ] }
 408         { T{ key-down f f "DOWN" }
 409             [ [ rotation-step pitch-up ] camera-action ] }
 410
 411         { T{ key-down f { C+ } "UP" }
 412            [ [ translation-step step-turtle ] camera-action ] }
 413         { T{ key-down f { C+ } "DOWN" }
 414             [ [ translation-step neg step-turtle ]
 415                     camera-action ] }
 416         { T{ key-down f { C+ } "LEFT" }
 417             [ [ rotation-step roll-left ] camera-action ] }
 418         { T{ key-down f { C+ } "RIGHT" }
 419             [ [ rotation-step roll-right ] camera-action ] }
 420
 421         { T{ key-down f { A+ } "LEFT" }
 422            [ [ translation-step strafe-left ] camera-action ] }
 423         { T{ key-down f { A+ } "RIGHT" }
 424           [ [ translation-step strafe-right ] camera-action ] }
 425         { T{ key-down f { A+ } "UP" }
 426             [ [ translation-step strafe-up ] camera-action ] }
 427         { T{ key-down f { A+ } "DOWN" }
 428            [ [ translation-step strafe-down ] camera-action ] }
 429
 430
 431         { T{ key-down f f "1" } [ mvt-3D-1 camera-action ] }
 432         { T{ key-down f f "2" } [ mvt-3D-2 camera-action ] }
 433         { T{ key-down f f "3" } [ mvt-3D-3  camera-action ] }
 434         { T{ key-down f f "4" } [ mvt-3D-4  camera-action ] }
 435
 436     } >>table
 437     ;
 438
 439 ! --------------------------------------------
 440 ! print elements
 441 ! --------------------------------------------
 442 ! print-content
 443
 444 GENERIC: adsoda-display-model ( x -- )
 445
 446 M: light adsoda-display-model
 447 "\n light : " .
 448      {
 449         [ direction>> "direction : " pprint . ]
 450         [ color>> "color : " pprint . ]
 451     }   cleave
 452     ;
 453
 454 M: face adsoda-display-model
 455      {
 456         [ halfspace>> "halfspace : " pprint . ]
 457         [ touching-corners>> "touching corners : " pprint . ]
 458     }   cleave
 459     ;
 460 M: solid adsoda-display-model
 461      {
 462         [ name>> "solid called : " pprint . ]
 463         [ color>> "color : " pprint . ]
 464         [ dimension>> "dimension : " pprint . ]
 465         [ faces>> "composed of faces : " pprint
 466             [ adsoda-display-model ] each ]
 467     }   cleave
 468     ;
 469 M: space adsoda-display-model
 470      {
 471         [ dimension>> "dimension : " pprint . ]
 472         [ ambient-color>> "ambient-color : " pprint . ]
 473         [ solids>> "composed of solids : " pprint
 474             [ adsoda-display-model ] each ]
 475         [ lights>> "composed of lights : " pprint
 476             [ adsoda-display-model ] each ]
 477     }   cleave
 478     ;
 479
 480 ! ----------------------------------------------
 481 : menu-bar ( -- gadget )
 482        <shelf>
 483           "reinit" [ drop load-model-file ] button* add-gadget
 484           selected-file-model> <label-control> add-gadget
 485     ;
 486
 487
 488 : controller-window* ( -- gadget )
 489     { 0 1 } <track>
 490         menu-bar f track-add
 491         <list-runner>
 492             <scroller>
 493         f track-add
 494         <shelf>
 495             "Projection mode : " <label> add-gadget
 496             model-projection-chooser add-gadget
 497         f track-add
 498         <shelf>
 499             "Collision detection (slow and buggy ) : "
 500                 <label> add-gadget
 501             collision-detection-chooser add-gadget
 502         f track-add
 503         <pile>
 504             0.5 >>align
 505             menu-4D add-gadget
 506             COLOR: purple s:<solid> >>interior
 507             "4D movements" <labeled-gadget>
 508         f track-add
 509         <pile>
 510             0.5 >>align
 511             { 2 2 } >>gap
 512             menu-3D add-gadget
 513             COLOR: purple s:<solid> >>interior
 514             "Camera 3D" <labeled-gadget>
 515         f track-add
 516         COLOR: gray s:<solid> >>interior
 517  ;
 518
 519 : viewer-windows* ( --  )
 520     "YZW" view1> win3D
 521     "XZW" view2> win3D
 522     "XYW" view3> win3D
 523     "XYZ" view4> win3D
 524 ;
 525
 526 : navigator-window* ( -- )
 527     controller-window*
 528     viewer-windows*
 529     add-keyboard-delegate
 530     "navigateur 4D" open-window
 531 ;
 532
 533 : windows ( -- ) [ [ navigator-window* ] with-scope ] with-ui ;
 534
 535
 536 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 537
 538 : init-variables ( -- )
 539     "choose a file" <model> >selected-file-model
 540     <observer> >observer3d
 541     [ observer3d> >self
 542       reset-turtle
 543       45 turn-left
 544       45 pitch-up
 545       -300 step-turtle
 546     ] with-scope
 547
 548 ;
 549
 550
 551 : init-models ( -- )
 552     0 model-projection observer3d> <window3D> >view1
 553     1 model-projection observer3d> <window3D> >view2
 554     2 model-projection observer3d> <window3D> >view3
 555     3 model-projection observer3d> <window3D> >view4
 556 ;
 557
 558 : 4DNav ( -- )
 559     init-variables
 560     selected-file read-model-file >present-space
 561     init-models
 562     windows
 563 ;
 564
 565 MAIN: 4DNav
 566
 567