1 ! Copyright (C) 2008 Jeff Bigot
2 ! See http://factorcode.org/license.txt for BSD license.
49 4DNav.space-file-decoder
55 QUALIFIED-WITH: ui.pens.solid s
56 QUALIFIED-WITH: ui.gadgets.wrappers w
61 VALUE: translation-step
64 3 \ translation-step set-value
65 5 \ rotation-step set-value
67 VAR: selected-file-model
75 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
79 : closed-quot ( quot -- quot )
80 namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;
82 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
83 ! waiting for deep-cleave-quots
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 ;
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 ;
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 ;
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 ;
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 ;
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 ;
121 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
123 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
125 : button* ( string quot -- button )
126 closed-quot <repeat-button> ;
128 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
130 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
132 : model-projection-chooser ( -- gadget )
133 observer3d> projection-mode>>
134 { { 1 "perspective" } { 0 "orthogonal" } }
137 : collision-detection-chooser ( -- gadget )
138 observer3d> collision-mode>>
139 { { t "on" } { f "off" } } <radio-buttons> ;
141 : model-projection ( x -- space )
142 present-space> swap space-project ;
144 : update-observer-projections ( -- )
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<< ;
156 : camera-action ( quot -- quot )
157 '[ drop _ observer3d>
158 with-self update-observer-projections ]
161 : win3D ( text gadget -- )
162 "navigateur 4D : " rot append open-window ;
164 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
165 ! 4D object manipulation
166 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
168 : (mvt-4D) ( quot -- )
170 swap call space-ensure-solids
172 update-model-projections
173 update-observer-projections ; inline
175 : rotation-4D ( m -- )
176 '[ _ [ [ middle-of-space dup vneg ] keep
177 swap space-translate ] dip
182 : translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ;
184 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
186 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
188 : menu-rotations-4D ( -- gadget )
190 { 1 1 } >>filled-cell
192 "XY +" [ drop rotation-step 4D-Rxy rotation-4D ]
194 "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ]
198 "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ]
200 "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ]
204 "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ]
206 "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ]
210 "XW +" [ drop rotation-step 4D-Rxw rotation-4D ]
212 "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ]
216 "YW +" [ drop rotation-step 4D-Ryw rotation-4D ]
218 "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ]
222 "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ]
224 "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ]
226 @bottom-right grid-add
229 : menu-translations-4D ( -- gadget )
231 { 1 1 } >>filled-cell
234 "X+" [ drop { 1 0 0 0 } translation-step v*n
237 "X-" [ drop { -1 0 0 0 } translation-step v*n
241 "YZW" <label> add-gadget
242 @bottom-right grid-add
244 "XZW" <label> add-gadget
246 "Y+" [ drop { 0 1 0 0 } translation-step v*n
249 "Y-" [ drop { 0 -1 0 0 } translation-step v*n
255 "XYW" <label> add-gadget
257 "Z+" [ drop { 0 0 1 0 } translation-step v*n
260 "Z-" [ drop { 0 0 -1 0 } translation-step v*n
267 "W+" [ drop { 0 0 0 1 } translation-step v*n
270 "W-" [ drop { 0 0 0 -1 } translation-step v*n
274 "XYZ" <label> add-gadget
275 @bottom-left grid-add
276 "X" <label> @center grid-add
279 : menu-4D ( -- gadget )
281 "rotations" <label> add-gadget
282 menu-rotations-4D add-gadget
283 "translations" <label> add-gadget
284 menu-translations-4D add-gadget
290 ! ------------------------------------------------------
292 : redraw-model ( space -- )
294 update-model-projections
295 update-observer-projections ;
297 : load-model-file ( -- )
298 selected-file dup selected-file-model> set-model
302 : mvt-3D-X ( turn pitch -- quot )
303 '[ turtle-pos> norm neg reset-turtle
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
313 : camera-button ( string quot -- button )
314 [ <label> ] dip camera-action <repeat-button> ;
316 ! ----------------------------------------------------------
318 ! ----------------------------------------------------------
319 : <run-file-button> ( file-name -- button )
320 dup '[ drop _ \ selected-file set-value load-model-file
322 closed-quot <roll-button> { 0 0 } >>align ;
324 : <list-runner> ( -- gadget )
325 "resource:extra/4DNav"
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> ;
333 ! -----------------------------------------------------
335 : menu-rotations-3D ( -- gadget )
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
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
354 : menu-translations-3D ( -- gadget )
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
366 "Forward (ctl)" [ translation-step step-turtle ]
367 camera-button add-gadget
369 [ translation-step neg step-turtle ]
370 camera-button add-gadget
374 : menu-quick-views ( -- gadget )
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
382 : menu-3D ( -- gadget )
385 menu-rotations-3D add-gadget
386 menu-translations-3D add-gadget
390 menu-quick-views add-gadget ;
392 TUPLE: handler < w:wrapper table ;
394 : <handler> ( child -- handler ) handler w:new-wrapper ;
396 M: handler handle-gesture ( gesture gadget -- ? )
397 tuck table>> at dup [ call( gadget -- ) f ] [ 2drop t ] if ;
399 : add-keyboard-delegate ( obj -- obj )
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 ] }
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 ]
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 ] }
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 ] }
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 ] }
439 ! --------------------------------------------
441 ! --------------------------------------------
444 GENERIC: adsoda-display-model ( x -- )
446 M: light adsoda-display-model
449 [ direction>> "direction : " pprint . ]
450 [ color>> "color : " pprint . ]
454 M: face adsoda-display-model
456 [ halfspace>> "halfspace : " pprint . ]
457 [ touching-corners>> "touching corners : " pprint . ]
460 M: solid adsoda-display-model
462 [ name>> "solid called : " pprint . ]
463 [ color>> "color : " pprint . ]
464 [ dimension>> "dimension : " pprint . ]
465 [ faces>> "composed of faces : " pprint
466 [ adsoda-display-model ] each ]
469 M: space adsoda-display-model
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 ]
480 ! ----------------------------------------------
481 : menu-bar ( -- gadget )
483 "reinit" [ drop load-model-file ] button* add-gadget
484 selected-file-model> <label-control> add-gadget
488 : controller-window* ( -- gadget )
495 "Projection mode : " <label> add-gadget
496 model-projection-chooser add-gadget
499 "Collision detection (slow and buggy ) : "
501 collision-detection-chooser add-gadget
506 COLOR: purple s:<solid> >>interior
507 "4D movements" <labeled-gadget>
513 COLOR: purple s:<solid> >>interior
514 "Camera 3D" <labeled-gadget>
516 COLOR: gray s:<solid> >>interior
519 : viewer-windows* ( -- )
526 : navigator-window* ( -- )
529 add-keyboard-delegate
530 "navigateur 4D" open-window
533 : windows ( -- ) [ [ navigator-window* ] with-scope ] with-ui ;
536 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
538 : init-variables ( -- )
539 "choose a file" <model> >selected-file-model
540 <observer> >observer3d
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
560 selected-file read-model-file >present-space