unmaintained/4DNav/4DNav.factor

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