-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel \r
-namespaces\r
-accessors\r
-assocs\r
-make\r
-math\r
-math.functions\r
-math.trig\r
-math.parser\r
-hashtables\r
-sequences\r
-combinators\r
-continuations\r
-colors\r
-colors.constants\r
-prettyprint\r
-vars\r
-quotations\r
-io\r
-io.directories\r
-io.pathnames\r
-help.markup\r
-io.files\r
-ui.gadgets.panes\r
- ui\r
- ui.gadgets\r
- ui.traverse\r
- ui.gadgets.borders\r
- ui.gadgets.frames\r
- ui.gadgets.tracks\r
- ui.gadgets.labels\r
- ui.gadgets.labeled \r
- ui.gadgets.lists\r
- ui.gadgets.buttons\r
- ui.gadgets.packs\r
- ui.gadgets.grids\r
- ui.gadgets.corners\r
- ui.gestures\r
- ui.gadgets.scrollers\r
-splitting\r
-vectors\r
-math.vectors\r
-values\r
-4DNav.turtle\r
-4DNav.window3D\r
-4DNav.deep\r
-4DNav.space-file-decoder\r
-models\r
-fry\r
-adsoda\r
-adsoda.tools\r
-;\r
-QUALIFIED-WITH: ui.pens.solid s\r
-QUALIFIED-WITH: ui.gadgets.wrappers w\r
-\r
-\r
-IN: 4DNav\r
-VALUE: selected-file\r
-VALUE: translation-step\r
-VALUE: rotation-step\r
-\r
-3 \ translation-step set-value\r
-5 \ rotation-step set-value\r
-\r
-VAR: selected-file-model\r
-VAR: observer3d \r
-VAR: view1 \r
-VAR: view2\r
-VAR: view3\r
-VAR: view4\r
-VAR: present-space\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-! namespace utilities\r
-\r
-: closed-quot ( quot -- quot )\r
- namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! waiting for deep-cleave-quots\r
-\r
-: 4D-Rxy ( angle -- Rx ) deg>rad\r
-[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
- 0.0 , 1.0 , 0.0 , 0.0 ,\r
- 0.0 , 0.0 , dup cos , dup sin neg ,\r
- 0.0 , 0.0 , dup sin , dup cos , ] 4 make-matrix nip ;\r
-\r
-: 4D-Rxz ( angle -- Ry ) deg>rad\r
-[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
- 0.0 , dup cos , 0.0 , dup sin neg ,\r
- 0.0 , 0.0 , 1.0 , 0.0 ,\r
- 0.0 , dup sin , 0.0 , dup cos , ] 4 make-matrix nip ;\r
-\r
-: 4D-Rxw ( angle -- Rz ) deg>rad\r
-[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
- 0.0 , dup cos , dup sin neg , 0.0 ,\r
- 0.0 , dup sin , dup cos , 0.0 ,\r
- 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
-\r
-: 4D-Ryz ( angle -- Rx ) deg>rad\r
-[ dup cos , 0.0 , 0.0 , dup sin neg ,\r
- 0.0 , 1.0 , 0.0 , 0.0 ,\r
- 0.0 , 0.0 , 1.0 , 0.0 ,\r
- dup sin , 0.0 , 0.0 , dup cos , ] 4 make-matrix nip ;\r
-\r
-: 4D-Ryw ( angle -- Ry ) deg>rad\r
-[ dup cos , 0.0 , dup sin neg , 0.0 ,\r
- 0.0 , 1.0 , 0.0 , 0.0 ,\r
- dup sin , 0.0 , dup cos , 0.0 ,\r
- 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
-\r
-: 4D-Rzw ( angle -- Rz ) deg>rad\r
-[ dup cos , dup sin neg , 0.0 , 0.0 ,\r
- dup sin , dup cos , 0.0 , 0.0 ,\r
- 0.0 , 0.0 , 1.0 , 0.0 ,\r
- 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! UI\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: button* ( string quot -- button ) \r
- closed-quot <repeat-button> ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: model-projection-chooser ( -- gadget )\r
- observer3d> projection-mode>>\r
- { { 1 "perspective" } { 0 "orthogonal" } } \r
- <radio-buttons> ;\r
-\r
-: collision-detection-chooser ( -- gadget )\r
- observer3d> collision-mode>>\r
- { { t "on" } { f "off" } } <radio-buttons> ;\r
-\r
-: model-projection ( x -- space ) \r
- present-space> swap space-project ;\r
-\r
-: update-observer-projections ( -- )\r
- view1> relayout-1 \r
- view2> relayout-1 \r
- view3> relayout-1 \r
- view4> relayout-1 ;\r
-\r
-: update-model-projections ( -- )\r
- 0 model-projection <model> view1> model<<\r
- 1 model-projection <model> view2> model<<\r
- 2 model-projection <model> view3> model<<\r
- 3 model-projection <model> view4> model<< ;\r
-\r
-: camera-action ( quot -- quot ) \r
- '[ drop _ observer3d> \r
- with-self update-observer-projections ] \r
- closed-quot ;\r
-\r
-: win3D ( text gadget -- ) \r
- "navigateur 4D : " rot append open-window ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! 4D object manipulation\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: (mvt-4D) ( quot -- ) \r
- present-space> \r
- swap call space-ensure-solids \r
- >present-space \r
- update-model-projections \r
- update-observer-projections ; inline\r
-\r
-: rotation-4D ( m -- ) \r
- '[ _ [ [ middle-of-space dup vneg ] keep \r
- swap space-translate ] dip\r
- space-transform \r
- swap space-translate\r
- ] (mvt-4D) ;\r
-\r
-: translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! menu\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: menu-rotations-4D ( -- gadget )\r
- 3 3 <frame>\r
- { 1 1 } >>filled-cell\r
- <pile> 1 >>fill\r
- "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] \r
- button* add-gadget\r
- "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] \r
- button* add-gadget \r
- @top-left grid-add \r
- <pile> 1 >>fill\r
- "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] \r
- button* add-gadget\r
- "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] \r
- button* add-gadget \r
- @top grid-add \r
- <pile> 1 >>fill\r
- "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] \r
- button* add-gadget\r
- "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] \r
- button* add-gadget \r
- @center grid-add\r
- <pile> 1 >>fill\r
- "XW +" [ drop rotation-step 4D-Rxw rotation-4D ] \r
- button* add-gadget\r
- "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] \r
- button* add-gadget \r
- @top-right grid-add \r
- <pile> 1 >>fill\r
- "YW +" [ drop rotation-step 4D-Ryw rotation-4D ] \r
- button* add-gadget\r
- "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] \r
- button* add-gadget \r
- @right grid-add \r
- <pile> 1 >>fill\r
- "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] \r
- button* add-gadget\r
- "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] \r
- button* add-gadget \r
- @bottom-right grid-add \r
-;\r
-\r
-: menu-translations-4D ( -- gadget )\r
- 3 3 <frame> \r
- { 1 1 } >>filled-cell\r
- <pile> 1 >>fill\r
- <shelf> 1 >>fill \r
- "X+" [ drop { 1 0 0 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget\r
- "X-" [ drop { -1 0 0 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget \r
- add-gadget\r
- "YZW" <label> add-gadget\r
- @bottom-right grid-add\r
- <pile> 1 >>fill\r
- "XZW" <label> add-gadget\r
- <shelf> 1 >>fill\r
- "Y+" [ drop { 0 1 0 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget\r
- "Y-" [ drop { 0 -1 0 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget \r
- add-gadget\r
- @top-right grid-add\r
- <pile> 1 >>fill\r
- "XYW" <label> add-gadget\r
- <shelf> 1 >>fill\r
- "Z+" [ drop { 0 0 1 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget\r
- "Z-" [ drop { 0 0 -1 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget \r
- add-gadget \r
- @top-left grid-add \r
- <pile> 1 >>fill\r
- <shelf> 1 >>fill\r
- "W+" [ drop { 0 0 0 1 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget\r
- "W-" [ drop { 0 0 0 -1 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget \r
- add-gadget\r
- "XYZ" <label> add-gadget\r
- @bottom-left grid-add \r
- "X" <label> @center grid-add\r
-;\r
-\r
-: menu-4D ( -- gadget ) \r
- <shelf> \r
- "rotations" <label> add-gadget\r
- menu-rotations-4D add-gadget\r
- "translations" <label> add-gadget\r
- menu-translations-4D add-gadget\r
- 0.5 >>align\r
- { 0 10 } >>gap\r
-;\r
-\r
-\r
-! ------------------------------------------------------\r
-\r
-: redraw-model ( space -- )\r
- >present-space \r
- update-model-projections \r
- update-observer-projections ;\r
-\r
-: load-model-file ( -- )\r
- selected-file dup selected-file-model> set-model \r
- read-model-file \r
- redraw-model ;\r
-\r
-: mvt-3D-X ( turn pitch -- quot )\r
- '[ turtle-pos> norm neg reset-turtle \r
- _ turn-left \r
- _ pitch-up \r
- step-turtle ] ;\r
-\r
-: mvt-3D-1 ( -- quot ) 90 0 mvt-3D-X ; inline\r
-: mvt-3D-2 ( -- quot ) 0 90 mvt-3D-X ; inline\r
-: mvt-3D-3 ( -- quot ) 0 0 mvt-3D-X ; inline\r
-: mvt-3D-4 ( -- quot ) 45 45 mvt-3D-X ; inline\r
-\r
-: camera-button ( string quot -- button ) \r
- [ <label> ] dip camera-action <repeat-button> ;\r
-\r
-! ----------------------------------------------------------\r
-! file chooser\r
-! ----------------------------------------------------------\r
-: <run-file-button> ( file-name -- button )\r
- dup '[ drop _ \ selected-file set-value load-model-file \r
- ] \r
- closed-quot <roll-button> { 0 0 } >>align ;\r
-\r
-: <list-runner> ( -- gadget )\r
- "resource:extra/4DNav" \r
- <pile> 1 >>fill \r
- over dup directory-files \r
- [ ".xml" tail? ] filter \r
- [ append-path ] with map\r
- [ <run-file-button> add-gadget ] each\r
- swap <labeled-gadget> ;\r
-\r
-! -----------------------------------------------------\r
-\r
-: menu-rotations-3D ( -- gadget )\r
- 3 3 <frame>\r
- { 1 1 } >>filled-cell\r
- "Turn\n left" [ rotation-step turn-left ] \r
- camera-button @left grid-add \r
- "Turn\n right" [ rotation-step turn-right ] \r
- camera-button @right grid-add \r
- "Pitch down" [ rotation-step pitch-down ] \r
- camera-button @bottom grid-add \r
- "Pitch up" [ rotation-step pitch-up ] \r
- camera-button @top grid-add \r
- <shelf> 1 >>fill\r
- "Roll left\n (ctl)" [ rotation-step roll-left ] \r
- camera-button add-gadget \r
- "Roll right\n(ctl)" [ rotation-step roll-right ] \r
- camera-button add-gadget \r
- @center grid-add \r
-;\r
-\r
-: menu-translations-3D ( -- gadget )\r
- 3 3 <frame>\r
- { 1 1 } >>filled-cell\r
- "left\n(alt)" [ translation-step strafe-left ]\r
- camera-button @left grid-add \r
- "right\n(alt)" [ translation-step strafe-right ]\r
- camera-button @right grid-add \r
- "Strafe up \n (alt)" [ translation-step strafe-up ] \r
- camera-button @top grid-add\r
- "Strafe down\n (alt)" [ translation-step strafe-down ]\r
- camera-button @bottom grid-add \r
- <pile> 1 >>fill\r
- "Forward (ctl)" [ translation-step step-turtle ] \r
- camera-button add-gadget\r
- "Backward (ctl)" \r
- [ translation-step neg step-turtle ] \r
- camera-button add-gadget\r
- @center grid-add\r
-;\r
-\r
-: menu-quick-views ( -- gadget )\r
- <shelf>\r
- "View 1 (1)" mvt-3D-1 camera-button add-gadget\r
- "View 2 (2)" mvt-3D-2 camera-button add-gadget\r
- "View 3 (3)" mvt-3D-3 camera-button add-gadget \r
- "View 4 (4)" mvt-3D-4 camera-button add-gadget \r
-;\r
-\r
-: menu-3D ( -- gadget ) \r
- <pile>\r
- <shelf> \r
- menu-rotations-3D add-gadget\r
- menu-translations-3D add-gadget\r
- 0.5 >>align\r
- { 0 10 } >>gap\r
- add-gadget\r
- menu-quick-views add-gadget ; \r
-\r
-TUPLE: handler < w:wrapper table ;\r
-\r
-: <handler> ( child -- handler ) handler w:new-wrapper ;\r
-\r
-M: handler handle-gesture ( gesture gadget -- ? )\r
- tuck table>> at dup [ call( gadget -- ) f ] [ 2drop t ] if ;\r
-\r
-: add-keyboard-delegate ( obj -- obj )\r
- <handler>\r
-H{\r
- { T{ key-down f f "LEFT" } \r
- [ [ rotation-step turn-left ] camera-action ] }\r
- { T{ key-down f f "RIGHT" } \r
- [ [ rotation-step turn-right ] camera-action ] }\r
- { T{ key-down f f "UP" } \r
- [ [ rotation-step pitch-down ] camera-action ] }\r
- { T{ key-down f f "DOWN" } \r
- [ [ rotation-step pitch-up ] camera-action ] }\r
-\r
- { T{ key-down f { C+ } "UP" } \r
- [ [ translation-step step-turtle ] camera-action ] }\r
- { T{ key-down f { C+ } "DOWN" } \r
- [ [ translation-step neg step-turtle ] \r
- camera-action ] }\r
- { T{ key-down f { C+ } "LEFT" } \r
- [ [ rotation-step roll-left ] camera-action ] }\r
- { T{ key-down f { C+ } "RIGHT" } \r
- [ [ rotation-step roll-right ] camera-action ] }\r
-\r
- { T{ key-down f { A+ } "LEFT" } \r
- [ [ translation-step strafe-left ] camera-action ] }\r
- { T{ key-down f { A+ } "RIGHT" } \r
- [ [ translation-step strafe-right ] camera-action ] }\r
- { T{ key-down f { A+ } "UP" } \r
- [ [ translation-step strafe-up ] camera-action ] }\r
- { T{ key-down f { A+ } "DOWN" } \r
- [ [ translation-step strafe-down ] camera-action ] }\r
-\r
-\r
- { T{ key-down f f "1" } [ mvt-3D-1 camera-action ] }\r
- { T{ key-down f f "2" } [ mvt-3D-2 camera-action ] }\r
- { T{ key-down f f "3" } [ mvt-3D-3 camera-action ] }\r
- { T{ key-down f f "4" } [ mvt-3D-4 camera-action ] }\r
-\r
- } >>table\r
- ; \r
-\r
-! --------------------------------------------\r
-! print elements \r
-! --------------------------------------------\r
-! print-content\r
-\r
-GENERIC: adsoda-display-model ( x -- ) \r
-\r
-M: light adsoda-display-model \r
-"\n light : " .\r
- { \r
- [ direction>> "direction : " pprint . ] \r
- [ color>> "color : " pprint . ]\r
- } cleave\r
- ;\r
-\r
-M: face adsoda-display-model \r
- {\r
- [ halfspace>> "halfspace : " pprint . ] \r
- [ touching-corners>> "touching corners : " pprint . ]\r
- } cleave\r
- ;\r
-M: solid adsoda-display-model \r
- {\r
- [ name>> "solid called : " pprint . ] \r
- [ color>> "color : " pprint . ]\r
- [ dimension>> "dimension : " pprint . ]\r
- [ faces>> "composed of faces : " pprint \r
- [ adsoda-display-model ] each ]\r
- } cleave\r
- ;\r
-M: space adsoda-display-model \r
- {\r
- [ dimension>> "dimension : " pprint . ] \r
- [ ambient-color>> "ambient-color : " pprint . ]\r
- [ solids>> "composed of solids : " pprint \r
- [ adsoda-display-model ] each ]\r
- [ lights>> "composed of lights : " pprint \r
- [ adsoda-display-model ] each ] \r
- } cleave\r
- ;\r
-\r
-! ----------------------------------------------\r
-: menu-bar ( -- gadget )\r
- <shelf>\r
- "reinit" [ drop load-model-file ] button* add-gadget\r
- selected-file-model> <label-control> add-gadget\r
- ;\r
-\r
-\r
-: controller-window* ( -- gadget )\r
- { 0 1 } <track>\r
- menu-bar f track-add\r
- <list-runner> \r
- <scroller>\r
- f track-add\r
- <shelf>\r
- "Projection mode : " <label> add-gadget\r
- model-projection-chooser add-gadget\r
- f track-add\r
- <shelf>\r
- "Collision detection (slow and buggy ) : " \r
- <label> add-gadget\r
- collision-detection-chooser add-gadget\r
- f track-add\r
- <pile>\r
- 0.5 >>align \r
- menu-4D add-gadget \r
- COLOR: purple s:<solid> >>interior\r
- "4D movements" <labeled-gadget>\r
- f track-add\r
- <pile>\r
- 0.5 >>align\r
- { 2 2 } >>gap\r
- menu-3D add-gadget\r
- COLOR: purple s:<solid> >>interior\r
- "Camera 3D" <labeled-gadget>\r
- f track-add \r
- COLOR: gray s:<solid> >>interior\r
- ;\r
- \r
-: viewer-windows* ( -- )\r
- "YZW" view1> win3D \r
- "XZW" view2> win3D \r
- "XYW" view3> win3D \r
- "XYZ" view4> win3D \r
-;\r
-\r
-: navigator-window* ( -- )\r
- controller-window*\r
- viewer-windows* \r
- add-keyboard-delegate\r
- "navigateur 4D" open-window\r
-;\r
-\r
-: windows ( -- ) [ [ navigator-window* ] with-scope ] with-ui ;\r
-\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: init-variables ( -- )\r
- "choose a file" <model> >selected-file-model \r
- <observer> >observer3d\r
- [ observer3d> >self\r
- reset-turtle \r
- 45 turn-left \r
- 45 pitch-up \r
- -300 step-turtle \r
- ] with-scope\r
- \r
-;\r
-\r
-\r
-: init-models ( -- )\r
- 0 model-projection observer3d> <window3D> >view1\r
- 1 model-projection observer3d> <window3D> >view2\r
- 2 model-projection observer3d> <window3D> >view3\r
- 3 model-projection observer3d> <window3D> >view4\r
-;\r
-\r
-: 4DNav ( -- ) \r
- init-variables\r
- selected-file read-model-file >present-space\r
- init-models\r
- windows\r
-;\r
-\r
-MAIN: 4DNav\r
-\r
-\r
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel
+namespaces
+accessors
+assocs
+make
+math
+math.functions
+math.trig
+math.parser
+hashtables
+sequences
+combinators
+continuations
+colors
+colors.constants
+prettyprint
+vars
+quotations
+io
+io.directories
+io.pathnames
+help.markup
+io.files
+ui.gadgets.panes
+ ui
+ ui.gadgets
+ ui.traverse
+ ui.gadgets.borders
+ ui.gadgets.frames
+ ui.gadgets.tracks
+ ui.gadgets.labels
+ ui.gadgets.labeled
+ ui.gadgets.lists
+ ui.gadgets.buttons
+ ui.gadgets.packs
+ ui.gadgets.grids
+ ui.gadgets.corners
+ ui.gestures
+ ui.gadgets.scrollers
+splitting
+vectors
+math.vectors
+values
+4DNav.turtle
+4DNav.window3D
+4DNav.deep
+4DNav.space-file-decoder
+models
+fry
+adsoda
+adsoda.tools
+;
+QUALIFIED-WITH: ui.pens.solid s
+QUALIFIED-WITH: ui.gadgets.wrappers w
+
+
+IN: 4DNav
+VALUE: selected-file
+VALUE: translation-step
+VALUE: rotation-step
+
+3 \ translation-step set-value
+5 \ rotation-step set-value
+
+VAR: selected-file-model
+VAR: observer3d
+VAR: view1
+VAR: view2
+VAR: view3
+VAR: view4
+VAR: present-space
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! namespace utilities
+
+: closed-quot ( quot -- quot )
+ namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! waiting for deep-cleave-quots
+
+: 4D-Rxy ( angle -- Rx ) deg>rad
+[ 1.0 , 0.0 , 0.0 , 0.0 ,
+ 0.0 , 1.0 , 0.0 , 0.0 ,
+ 0.0 , 0.0 , dup cos , dup sin neg ,
+ 0.0 , 0.0 , dup sin , dup cos , ] 4 make-matrix nip ;
+
+: 4D-Rxz ( angle -- Ry ) deg>rad
+[ 1.0 , 0.0 , 0.0 , 0.0 ,
+ 0.0 , dup cos , 0.0 , dup sin neg ,
+ 0.0 , 0.0 , 1.0 , 0.0 ,
+ 0.0 , dup sin , 0.0 , dup cos , ] 4 make-matrix nip ;
+
+: 4D-Rxw ( angle -- Rz ) deg>rad
+[ 1.0 , 0.0 , 0.0 , 0.0 ,
+ 0.0 , dup cos , dup sin neg , 0.0 ,
+ 0.0 , dup sin , dup cos , 0.0 ,
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
+
+: 4D-Ryz ( angle -- Rx ) deg>rad
+[ dup cos , 0.0 , 0.0 , dup sin neg ,
+ 0.0 , 1.0 , 0.0 , 0.0 ,
+ 0.0 , 0.0 , 1.0 , 0.0 ,
+ dup sin , 0.0 , 0.0 , dup cos , ] 4 make-matrix nip ;
+
+: 4D-Ryw ( angle -- Ry ) deg>rad
+[ dup cos , 0.0 , dup sin neg , 0.0 ,
+ 0.0 , 1.0 , 0.0 , 0.0 ,
+ dup sin , 0.0 , dup cos , 0.0 ,
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
+
+: 4D-Rzw ( angle -- Rz ) deg>rad
+[ dup cos , dup sin neg , 0.0 , 0.0 ,
+ dup sin , dup cos , 0.0 , 0.0 ,
+ 0.0 , 0.0 , 1.0 , 0.0 ,
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! UI
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: button* ( string quot -- button )
+ closed-quot <repeat-button> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: model-projection-chooser ( -- gadget )
+ observer3d> projection-mode>>
+ { { 1 "perspective" } { 0 "orthogonal" } }
+ <radio-buttons> ;
+
+: collision-detection-chooser ( -- gadget )
+ observer3d> collision-mode>>
+ { { t "on" } { f "off" } } <radio-buttons> ;
+
+: model-projection ( x -- space )
+ present-space> swap space-project ;
+
+: update-observer-projections ( -- )
+ view1> relayout-1
+ view2> relayout-1
+ view3> relayout-1
+ view4> relayout-1 ;
+
+: update-model-projections ( -- )
+ 0 model-projection <model> view1> model<<
+ 1 model-projection <model> view2> model<<
+ 2 model-projection <model> view3> model<<
+ 3 model-projection <model> view4> model<< ;
+
+: camera-action ( quot -- quot )
+ '[ drop _ observer3d>
+ with-self update-observer-projections ]
+ closed-quot ;
+
+: win3D ( text gadget -- )
+ "navigateur 4D : " rot append open-window ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 4D object manipulation
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (mvt-4D) ( quot -- )
+ present-space>
+ swap call space-ensure-solids
+ >present-space
+ update-model-projections
+ update-observer-projections ; inline
+
+: rotation-4D ( m -- )
+ '[ _ [ [ middle-of-space dup vneg ] keep
+ swap space-translate ] dip
+ space-transform
+ swap space-translate
+ ] (mvt-4D) ;
+
+: translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! menu
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: menu-rotations-4D ( -- gadget )
+ 3 3 <frame>
+ { 1 1 } >>filled-cell
+ <pile> 1 >>fill
+ "XY +" [ drop rotation-step 4D-Rxy rotation-4D ]
+ button* add-gadget
+ "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ]
+ button* add-gadget
+ @top-left grid-add
+ <pile> 1 >>fill
+ "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ]
+ button* add-gadget
+ "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ]
+ button* add-gadget
+ @top grid-add
+ <pile> 1 >>fill
+ "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ]
+ button* add-gadget
+ "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ]
+ button* add-gadget
+ @center grid-add
+ <pile> 1 >>fill
+ "XW +" [ drop rotation-step 4D-Rxw rotation-4D ]
+ button* add-gadget
+ "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ]
+ button* add-gadget
+ @top-right grid-add
+ <pile> 1 >>fill
+ "YW +" [ drop rotation-step 4D-Ryw rotation-4D ]
+ button* add-gadget
+ "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ]
+ button* add-gadget
+ @right grid-add
+ <pile> 1 >>fill
+ "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ]
+ button* add-gadget
+ "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ]
+ button* add-gadget
+ @bottom-right grid-add
+;
+
+: menu-translations-4D ( -- gadget )
+ 3 3 <frame>
+ { 1 1 } >>filled-cell
+ <pile> 1 >>fill
+ <shelf> 1 >>fill
+ "X+" [ drop { 1 0 0 0 } translation-step v*n
+ translation-4D ]
+ button* add-gadget
+ "X-" [ drop { -1 0 0 0 } translation-step v*n
+ translation-4D ]
+ button* add-gadget
+ add-gadget
+ "YZW" <label> add-gadget
+ @bottom-right grid-add
+ <pile> 1 >>fill
+ "XZW" <label> add-gadget
+ <shelf> 1 >>fill
+ "Y+" [ drop { 0 1 0 0 } translation-step v*n
+ translation-4D ]
+ button* add-gadget
+ "Y-" [ drop { 0 -1 0 0 } translation-step v*n
+ translation-4D ]
+ button* add-gadget
+ add-gadget
+ @top-right grid-add
+ <pile> 1 >>fill
+ "XYW" <label> add-gadget
+ <shelf> 1 >>fill
+ "Z+" [ drop { 0 0 1 0 } translation-step v*n
+ translation-4D ]
+ button* add-gadget
+ "Z-" [ drop { 0 0 -1 0 } translation-step v*n
+ translation-4D ]
+ button* add-gadget
+ add-gadget
+ @top-left grid-add
+ <pile> 1 >>fill
+ <shelf> 1 >>fill
+ "W+" [ drop { 0 0 0 1 } translation-step v*n
+ translation-4D ]
+ button* add-gadget
+ "W-" [ drop { 0 0 0 -1 } translation-step v*n
+ translation-4D ]
+ button* add-gadget
+ add-gadget
+ "XYZ" <label> add-gadget
+ @bottom-left grid-add
+ "X" <label> @center grid-add
+;
+
+: menu-4D ( -- gadget )
+ <shelf>
+ "rotations" <label> add-gadget
+ menu-rotations-4D add-gadget
+ "translations" <label> add-gadget
+ menu-translations-4D add-gadget
+ 0.5 >>align
+ { 0 10 } >>gap
+;
+
+
+! ------------------------------------------------------
+
+: redraw-model ( space -- )
+ >present-space
+ update-model-projections
+ update-observer-projections ;
+
+: load-model-file ( -- )
+ selected-file dup selected-file-model> set-model
+ read-model-file
+ redraw-model ;
+
+: mvt-3D-X ( turn pitch -- quot )
+ '[ turtle-pos> norm neg reset-turtle
+ _ turn-left
+ _ pitch-up
+ step-turtle ] ;
+
+: mvt-3D-1 ( -- quot ) 90 0 mvt-3D-X ; inline
+: mvt-3D-2 ( -- quot ) 0 90 mvt-3D-X ; inline
+: mvt-3D-3 ( -- quot ) 0 0 mvt-3D-X ; inline
+: mvt-3D-4 ( -- quot ) 45 45 mvt-3D-X ; inline
+
+: camera-button ( string quot -- button )
+ [ <label> ] dip camera-action <repeat-button> ;
+
+! ----------------------------------------------------------
+! file chooser
+! ----------------------------------------------------------
+: <run-file-button> ( file-name -- button )
+ dup '[ drop _ \ selected-file set-value load-model-file
+ ]
+ closed-quot <roll-button> { 0 0 } >>align ;
+
+: <list-runner> ( -- gadget )
+ "resource:extra/4DNav"
+ <pile> 1 >>fill
+ over dup directory-files
+ [ ".xml" tail? ] filter
+ [ append-path ] with map
+ [ <run-file-button> add-gadget ] each
+ swap <labeled-gadget> ;
+
+! -----------------------------------------------------
+
+: menu-rotations-3D ( -- gadget )
+ 3 3 <frame>
+ { 1 1 } >>filled-cell
+ "Turn\n left" [ rotation-step turn-left ]
+ camera-button @left grid-add
+ "Turn\n right" [ rotation-step turn-right ]
+ camera-button @right grid-add
+ "Pitch down" [ rotation-step pitch-down ]
+ camera-button @bottom grid-add
+ "Pitch up" [ rotation-step pitch-up ]
+ camera-button @top grid-add
+ <shelf> 1 >>fill
+ "Roll left\n (ctl)" [ rotation-step roll-left ]
+ camera-button add-gadget
+ "Roll right\n(ctl)" [ rotation-step roll-right ]
+ camera-button add-gadget
+ @center grid-add
+;
+
+: menu-translations-3D ( -- gadget )
+ 3 3 <frame>
+ { 1 1 } >>filled-cell
+ "left\n(alt)" [ translation-step strafe-left ]
+ camera-button @left grid-add
+ "right\n(alt)" [ translation-step strafe-right ]
+ camera-button @right grid-add
+ "Strafe up \n (alt)" [ translation-step strafe-up ]
+ camera-button @top grid-add
+ "Strafe down\n (alt)" [ translation-step strafe-down ]
+ camera-button @bottom grid-add
+ <pile> 1 >>fill
+ "Forward (ctl)" [ translation-step step-turtle ]
+ camera-button add-gadget
+ "Backward (ctl)"
+ [ translation-step neg step-turtle ]
+ camera-button add-gadget
+ @center grid-add
+;
+
+: menu-quick-views ( -- gadget )
+ <shelf>
+ "View 1 (1)" mvt-3D-1 camera-button add-gadget
+ "View 2 (2)" mvt-3D-2 camera-button add-gadget
+ "View 3 (3)" mvt-3D-3 camera-button add-gadget
+ "View 4 (4)" mvt-3D-4 camera-button add-gadget
+;
+
+: menu-3D ( -- gadget )
+ <pile>
+ <shelf>
+ menu-rotations-3D add-gadget
+ menu-translations-3D add-gadget
+ 0.5 >>align
+ { 0 10 } >>gap
+ add-gadget
+ menu-quick-views add-gadget ;
+
+TUPLE: handler < w:wrapper table ;
+
+: <handler> ( child -- handler ) handler w:new-wrapper ;
+
+M: handler handle-gesture ( gesture gadget -- ? )
+ tuck table>> at dup [ call( gadget -- ) f ] [ 2drop t ] if ;
+
+: add-keyboard-delegate ( obj -- obj )
+ <handler>
+H{
+ { T{ key-down f f "LEFT" }
+ [ [ rotation-step turn-left ] camera-action ] }
+ { T{ key-down f f "RIGHT" }
+ [ [ rotation-step turn-right ] camera-action ] }
+ { T{ key-down f f "UP" }
+ [ [ rotation-step pitch-down ] camera-action ] }
+ { T{ key-down f f "DOWN" }
+ [ [ rotation-step pitch-up ] camera-action ] }
+
+ { T{ key-down f { C+ } "UP" }
+ [ [ translation-step step-turtle ] camera-action ] }
+ { T{ key-down f { C+ } "DOWN" }
+ [ [ translation-step neg step-turtle ]
+ camera-action ] }
+ { T{ key-down f { C+ } "LEFT" }
+ [ [ rotation-step roll-left ] camera-action ] }
+ { T{ key-down f { C+ } "RIGHT" }
+ [ [ rotation-step roll-right ] camera-action ] }
+
+ { T{ key-down f { A+ } "LEFT" }
+ [ [ translation-step strafe-left ] camera-action ] }
+ { T{ key-down f { A+ } "RIGHT" }
+ [ [ translation-step strafe-right ] camera-action ] }
+ { T{ key-down f { A+ } "UP" }
+ [ [ translation-step strafe-up ] camera-action ] }
+ { T{ key-down f { A+ } "DOWN" }
+ [ [ translation-step strafe-down ] camera-action ] }
+
+
+ { T{ key-down f f "1" } [ mvt-3D-1 camera-action ] }
+ { T{ key-down f f "2" } [ mvt-3D-2 camera-action ] }
+ { T{ key-down f f "3" } [ mvt-3D-3 camera-action ] }
+ { T{ key-down f f "4" } [ mvt-3D-4 camera-action ] }
+
+ } >>table
+ ;
+
+! --------------------------------------------
+! print elements
+! --------------------------------------------
+! print-content
+
+GENERIC: adsoda-display-model ( x -- )
+
+M: light adsoda-display-model
+"\n light : " .
+ {
+ [ direction>> "direction : " pprint . ]
+ [ color>> "color : " pprint . ]
+ } cleave
+ ;
+
+M: face adsoda-display-model
+ {
+ [ halfspace>> "halfspace : " pprint . ]
+ [ touching-corners>> "touching corners : " pprint . ]
+ } cleave
+ ;
+M: solid adsoda-display-model
+ {
+ [ name>> "solid called : " pprint . ]
+ [ color>> "color : " pprint . ]
+ [ dimension>> "dimension : " pprint . ]
+ [ faces>> "composed of faces : " pprint
+ [ adsoda-display-model ] each ]
+ } cleave
+ ;
+M: space adsoda-display-model
+ {
+ [ dimension>> "dimension : " pprint . ]
+ [ ambient-color>> "ambient-color : " pprint . ]
+ [ solids>> "composed of solids : " pprint
+ [ adsoda-display-model ] each ]
+ [ lights>> "composed of lights : " pprint
+ [ adsoda-display-model ] each ]
+ } cleave
+ ;
+
+! ----------------------------------------------
+: menu-bar ( -- gadget )
+ <shelf>
+ "reinit" [ drop load-model-file ] button* add-gadget
+ selected-file-model> <label-control> add-gadget
+ ;
+
+
+: controller-window* ( -- gadget )
+ { 0 1 } <track>
+ menu-bar f track-add
+ <list-runner>
+ <scroller>
+ f track-add
+ <shelf>
+ "Projection mode : " <label> add-gadget
+ model-projection-chooser add-gadget
+ f track-add
+ <shelf>
+ "Collision detection (slow and buggy ) : "
+ <label> add-gadget
+ collision-detection-chooser add-gadget
+ f track-add
+ <pile>
+ 0.5 >>align
+ menu-4D add-gadget
+ COLOR: purple s:<solid> >>interior
+ "4D movements" <labeled-gadget>
+ f track-add
+ <pile>
+ 0.5 >>align
+ { 2 2 } >>gap
+ menu-3D add-gadget
+ COLOR: purple s:<solid> >>interior
+ "Camera 3D" <labeled-gadget>
+ f track-add
+ COLOR: gray s:<solid> >>interior
+ ;
+
+: viewer-windows* ( -- )
+ "YZW" view1> win3D
+ "XZW" view2> win3D
+ "XYW" view3> win3D
+ "XYZ" view4> win3D
+;
+
+: navigator-window* ( -- )
+ controller-window*
+ viewer-windows*
+ add-keyboard-delegate
+ "navigateur 4D" open-window
+;
+
+: windows ( -- ) [ [ navigator-window* ] with-scope ] with-ui ;
+
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-variables ( -- )
+ "choose a file" <model> >selected-file-model
+ <observer> >observer3d
+ [ observer3d> >self
+ reset-turtle
+ 45 turn-left
+ 45 pitch-up
+ -300 step-turtle
+ ] with-scope
+
+;
+
+
+: init-models ( -- )
+ 0 model-projection observer3d> <window3D> >view1
+ 1 model-projection observer3d> <window3D> >view2
+ 2 model-projection observer3d> <window3D> >view3
+ 3 model-projection observer3d> <window3D> >view4
+;
+
+: 4DNav ( -- )
+ init-variables
+ selected-file read-model-file >present-space
+ init-models
+ windows
+;
+
+MAIN: 4DNav
+
+
projects / factor.git / blobdiff