+++ /dev/null
-! Copyright (C) 2008 Jean-François Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations strings ;
-IN: 4DNav
-
-HELP: (mvt-4D)
-{ $values
- { "quot" quotation }
-}
-{ $description "" } ;
-
-HELP: 4D-Rxw
-{ $values
- { "angle" null }
- { "Rz" null }
-}
-{ $description "" } ;
-
-HELP: 4D-Rxy
-{ $values
- { "angle" null }
- { "Rx" null }
-}
-{ $description "" } ;
-
-HELP: 4D-Rxz
-{ $values
- { "angle" null }
- { "Ry" null }
-}
-{ $description "" } ;
-
-HELP: 4D-Ryw
-{ $values
- { "angle" null }
- { "Ry" null }
-}
-{ $description "" } ;
-
-HELP: 4D-Ryz
-{ $values
- { "angle" null }
- { "Rx" null }
-}
-{ $description "" } ;
-
-HELP: 4D-Rzw
-{ $values
- { "angle" null }
- { "Rz" null }
-}
-{ $description "" } ;
-
-HELP: 4DNav
-{ $description "" } ;
-
-HELP: >observer3d
-{ $values
- { "value" null }
-}
-{ $description "" } ;
-
-HELP: >present-space
-{ $values
- { "value" null }
-}
-{ $description "" } ;
-
-
-HELP: >view1
-{ $values
- { "value" null }
-}
-{ $description "" } ;
-
-HELP: >view2
-{ $values
- { "value" null }
-}
-{ $description "" } ;
-
-HELP: >view3
-{ $values
- { "value" null }
-}
-{ $description "" } ;
-
-HELP: >view4
-{ $values
- { "value" null }
-}
-{ $description "" } ;
-
-HELP: add-keyboard-delegate
-{ $values
- { "obj" object }
- { "obj" object }
-}
-{ $description "" } ;
-
-HELP: button*
-{ $values
- { "string" string } { "quot" quotation }
- { "button" null }
-}
-{ $description "" } ;
-
-HELP: camera-action
-{ $values
- { "quot" quotation }
- { "quot" quotation }
-}
-{ $description "" } ;
-
-HELP: camera-button
-{ $values
- { "string" string } { "quot" quotation }
- { "button" null }
-}
-{ $description "" } ;
-
-HELP: controller-window*
-{ $values
- { "gadget" "a gadget" }
-}
-{ $description "" } ;
-
-
-HELP: init-models
-{ $description "" } ;
-
-HELP: init-variables
-{ $description "" } ;
-
-HELP: menu-3D
-{ $values
- { "gadget" null }
-}
-{ $description "The menu dedicated to 3D movements of the camera" } ;
-
-HELP: menu-4D
-{ $values
-
- { "gadget" null }
-}
-{ $description "The menu dedicated to 4D movements of space" } ;
-
-HELP: menu-bar
-{ $values
-
- { "gadget" null }
-}
-{ $description "return gadget containing menu buttons" } ;
-
-HELP: model-projection
-{ $values
- { "x" null }
- { "space" null }
-}
-{ $description "Project space following coordinate x" } ;
-
-HELP: mvt-3D-1
-{ $values
-
- { "quot" quotation }
-}
-{ $description "return a quotation to orientate space to see it from first point of view" } ;
-
-HELP: mvt-3D-2
-{ $values
-
- { "quot" quotation }
-}
-{ $description "return a quotation to orientate space to see it from second point of view" } ;
-
-HELP: mvt-3D-3
-{ $values
-
- { "quot" quotation }
-}
-{ $description "return a quotation to orientate space to see it from third point of view" } ;
-
-HELP: mvt-3D-4
-{ $values
-
- { "quot" quotation }
-}
-{ $description "return a quotation to orientate space to see it from first point of view" } ;
-
-HELP: observer3d
-{ $description "" } ;
-
-HELP: observer3d>
-{ $values
-
- { "value" null }
-}
-{ $description "" } ;
-
-HELP: present-space
-{ $description "" } ;
-
-HELP: present-space>
-{ $values
-
- { "value" null }
-}
-{ $description "" } ;
-
-HELP: load-model-file
-{ $description "load space from file" } ;
-
-HELP: rotation-4D
-{ $values
- { "m" "a rotation matrix" }
-}
-{ $description "Apply a 4D rotation matrix" } ;
-
-HELP: translation-4D
-{ $values
- { "v" null }
-}
-{ $description "" } ;
-
-HELP: update-model-projections
-{ $description "" } ;
-
-HELP: update-observer-projections
-{ $description "" } ;
-
-HELP: view1
-{ $description "" } ;
-
-HELP: view1>
-{ $values
-
- { "value" null }
-}
-{ $description "" } ;
-
-HELP: view2
-{ $description "" } ;
-
-HELP: view2>
-{ $values
-
- { "value" null }
-}
-{ $description "" } ;
-
-HELP: view3
-{ $description "" } ;
-
-HELP: view3>
-{ $values
-
- { "value" null }
-}
-{ $description "" } ;
-
-HELP: view4
-{ $description "" } ;
-
-HELP: view4>
-{ $values
-
- { "value" null }
-}
-{ $description "" } ;
-
-HELP: viewer-windows*
-{ $description "" } ;
-
-HELP: win3D
-{ $values
- { "text" null } { "gadget" null }
-}
-{ $description "" } ;
-
-HELP: windows
-{ $description "" } ;
-
-ARTICLE: "Space file" "Create a new space file"
-"\nTo build a new space, create an XML file using " { $vocab-link "adsoda" } " model description. \nAn example is:"
-$nl
-
-"\n<model>"
-"\n<space>"
-"\n <dimension>4</dimension>"
-"\n <solid>"
-"\n <name>4cube1</name>"
-"\n <dimension>4</dimension>"
-"\n <face>1,0,0,0,100</face>"
-"\n <face>-1,0,0,0,-150</face>"
-"\n <face>0,1,0,0,100</face>"
-"\n <face>0,-1,0,0,-150</face>"
-"\n <face>0,0,1,0,100</face>"
-"\n <face>0,0,-1,0,-150</face>"
-"\n <face>0,0,0,1,100</face>"
-"\n <face>0,0,0,-1,-150</face>"
-"\n <color>1,0,0</color>"
-"\n </solid>"
-"\n <solid>"
-"\n <name>4triancube</name>"
-"\n <dimension>4</dimension>"
-"\n <face>1,0,0,0,160</face>"
-"\n <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>"
-"\n <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>"
-"\n <face>0,0,1,0,140</face>"
-"\n <face>0,0,-1,0,-180</face>"
-"\n <face>0,0,0,1,110</face>"
-"\n <face>0,0,0,-1,-180</face>"
-"\n <color>0,1,0</color>"
-"\n </solid>"
-"\n <solid>"
-"\n <name>triangone</name>"
-"\n <dimension>4</dimension>"
-"\n <face>1,0,0,0,60</face>"
-"\n <face>0.5,0.8660254037844386,0,0,60</face>"
-"\n <face>-0.5,0.8660254037844387,0,0,-20</face>"
-"\n <face>-1.0,0,0,0,-100</face>"
-"\n <face>-0.5,-0.8660254037844384,0,0,-100</face>"
-"\n <face>0.5,-0.8660254037844387,0,0,-20</face>"
-"\n <face>0,0,1,0,120</face>"
-"\n <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>"
-"\n <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>"
-"\n <color>0,1,1</color>"
-"\n </solid>"
-"\n <light>"
-"\n <direction>1,1,1,1</direction>"
-"\n <color>0.2,0.2,0.6</color>"
-"\n </light>"
-"\n <color>0.8,0.9,0.9</color>"
-"\n</space>"
-"\n</model>"
-
-
-;
-
-ARTICLE: "TODO" "Todo"
-{ $list
- "A file chooser"
- "A vocab to initialize parameters"
- "an editor mode"
- { $list "add a face to a solid"
- "add a solid to the space"
- "move a face"
- "move a solid"
- "select a solid in a list"
- "select a face"
- "display selected face"
- "edit a solid color"
- "add a light"
- "edit a light color"
- "move a light"
- }
- "add a tool wich give an hyperplane normal vector with enought points. Will use adsoda.intersect-hyperplanes with { { 0 } { 0 } { 1 } } "
- "decorrelate 3D camera and activate them with select buttons"
-
-
-
-} ;
-
-
-ARTICLE: "4DNav" "4DNav"
-{ $vocab-link "4DNav" }
-$nl
-{ $heading "4D Navigator" }
-"4DNav is a simple tool to visualize 4 dimensionnal objects."
-"\n"
-"It uses " { $vocab-link "adsoda" } " library to display a 4D space and navigate thru it."
-
-"It will display:"
-{ $list
- { "a menu window" }
- { "4 visualization windows" }
-}
-"Each window represents the projection of the 4D space on a particular 3D space."
-$nl
-
-{ $heading "Initialization" }
-"put the space file " { $strong "space-exemple.xml" } " in temp directory"
-" and then type:" { $code "\"4DNav\" run" }
-{ $heading "Navigation" }
-"4D submenu move the space in translations and rotation."
-"\n3D submenu move the camera in 3D space. Cameras in every 3D spaces are manipulated as a single one"
-$nl
-
-
-
-
-{ $heading "Links" }
-{ $subsection "Space file" }
-
-{ $subsection "TODO" }
-
-
-;
-
-ABOUT: "4DNav"
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel \r
-namespaces\r
-accessors\r
-make\r
-math\r
-math.functions\r
-math.trig\r
-math.parser\r
-hashtables\r
-sequences\r
-combinators\r
-continuations\r
-colors\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.handler\r
- ui.gadgets.slate\r
- ui.gadgets.theme\r
- ui.gadgets.frames\r
- ui.gadgets.tracks\r
- ui.gadgets.labels\r
- ui.gadgets.labelled \r
- ui.gadgets.lists\r
- ui.gadgets.buttons\r
- ui.gadgets.packs\r
- ui.gadgets.grids\r
- ui.gestures\r
- ui.tools.workspace\r
- ui.gadgets.scrollers\r
-splitting\r
-vectors\r
-math.vectors\r
-rewrite-closures\r
-self\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
-\r
-IN: 4DNav\r
-VALUE: selected-file\r
-VALUE: translation-step\r
-VALUE: rotation-step\r
-\r
-3 to: translation-step \r
-5 to: rotation-step\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
-! replacement of namespaces.lib\r
- \r
-: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;\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 ) closed-quot <repeat-button> ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: model-projection-chooser ( -- gadget )\r
- observer3d> projection-mode>>\r
- { { 1 "perspective" } { 0 "orthogonal" } } <toggle-buttons> ;\r
-\r
-: collision-detection-chooser ( -- gadget )\r
- observer3d> collision-mode>>\r
- { { t "on" } { f "off" } } <toggle-buttons>\r
-;\r
-\r
-: model-projection ( x -- space ) 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> with-self update-observer-projections ] \r
- make* closed-quot ;\r
-\r
-: win3D ( text gadget -- ) "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 ;\r
-\r
-: rotation-4D ( m -- ) \r
- '[ _ [ [ middle-of-space dup vneg ] keep 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
- <frame>\r
- <pile> 1 >>fill\r
- "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] button* add-gadget\r
- "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] button* add-gadget \r
- @top-left grid-add \r
- <pile> 1 >>fill\r
- "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] button* add-gadget\r
- "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] button* add-gadget \r
- @top grid-add \r
- <pile> 1 >>fill\r
- "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] button* add-gadget\r
- "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] button* add-gadget \r
- @center grid-add\r
- <pile> 1 >>fill\r
- "XW +" [ drop rotation-step 4D-Rxw rotation-4D ] button* add-gadget\r
- "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] button* add-gadget \r
- @top-right grid-add \r
- <pile> 1 >>fill\r
- "YW +" [ drop rotation-step 4D-Ryw rotation-4D ] button* add-gadget\r
- "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] button* add-gadget \r
- @right grid-add \r
- <pile> 1 >>fill\r
- "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] button* add-gadget\r
- "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] button* add-gadget \r
- @bottom-right grid-add \r
-;\r
-\r
-: menu-translations-4D ( -- gadget )\r
- <frame> \r
- <pile> 1 >>fill\r
- <shelf> 1 >>fill \r
- "X+" [ drop { 1 0 0 0 } translation-step v*n translation-4D ] \r
- button* add-gadget\r
- "X-" [ drop { -1 0 0 0 } translation-step v*n 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 translation-4D ] \r
- button* add-gadget\r
- "Y-" [ drop { 0 -1 0 0 } translation-step v*n 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 translation-4D ] \r
- button* add-gadget\r
- "Z-" [ drop { 0 0 -1 0 } translation-step v*n 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 translation-4D ] \r
- button* add-gadget\r
- "W-" [ drop { 0 0 0 -1 } translation-step v*n 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 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 <labelled-gadget> ;\r
-\r
-! -----------------------------------------------------\r
-\r
-: menu-rotations-3D ( -- gadget )\r
- <frame>\r
- "Turn\n left" [ rotation-step turn-left ] camera-button \r
- @left grid-add \r
- "Turn\n right" [ rotation-step turn-right ] camera-button \r
- @right grid-add \r
- "Pitch down" [ rotation-step pitch-down ] camera-button \r
- @bottom grid-add \r
- "Pitch up" [ rotation-step pitch-up ] camera-button \r
- @top grid-add \r
- <shelf> 1 >>fill\r
- "Roll left\n (ctl)" [ rotation-step roll-left ] camera-button\r
- add-gadget \r
- "Roll right\n(ctl)" [ rotation-step roll-right ] camera-button \r
- add-gadget \r
- @center grid-add \r
-;\r
-\r
-: menu-translations-3D ( -- gadget )\r
- <frame>\r
- "left\n(alt)" [ translation-step strafe-left ] camera-button\r
- @left grid-add \r
- "right\n(alt)" [ translation-step strafe-right ] camera-button\r
- @right grid-add \r
- "Strafe up \n (alt)" [ translation-step strafe-up ] camera-button\r
- @top grid-add\r
- "Strafe down \n (alt)" [ translation-step strafe-down ] camera-button\r
- @bottom grid-add \r
- <pile> 1 >>fill\r
- "Forward (ctl)" [ translation-step step-turtle ] camera-button\r
- add-gadget\r
- "Backward (ctl)" [ translation-step neg step-turtle ] camera-button\r
- 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
-: add-keyboard-delegate ( obj -- obj )\r
- <handler>\r
-{\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 ] 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
- } [ make* ] map >hashtable >>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 [ 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 [ adsoda-display-model ] each ]\r
- [ lights>> "composed of lights : " pprint [ 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
- <limited-scroller> \r
- { 200 400 } >>max-dim\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 ) : " <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
- light-purple solid-interior\r
- "4D movements" <labelled-gadget>\r
- f track-add\r
- <pile>\r
- 0.5 >>align\r
- { 2 2 } >>gap\r
- menu-3D add-gadget\r
- light-purple solid-interior \r
- "Camera 3D" <labelled-gadget>\r
- f track-add \r
- gray 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
+++ /dev/null
-Jeff Bigot
\ No newline at end of file
+++ /dev/null
-Adam Wendt
+++ /dev/null
-! Copyright (C) 2008 Jean-François Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel ;
-IN: 4DNav.camera
-
-HELP: camera-eye
-{ $values
-
- { "point" null }
-}
-{ $description "return the position of the camera" } ;
-
-HELP: camera-focus
-{ $values
-
- { "point" null }
-}
-{ $description "return the point the camera looks at" } ;
-
-HELP: camera-up
-{ $values
-
- { "dirvec" null }
-}
-{ $description "In order to precise the roling position of camera give an upward vector" } ;
-
-HELP: do-look-at
-{ $values
- { "camera" null }
-}
-{ $description "Word to use in replacement of gl-look-at when using a camera" } ;
-
-ARTICLE: "4DNav.camera" "4DNav.camera"
-{ $vocab-link "4DNav.camera" }
-"\n"
-"A camera is defined by:"
-{ $list
-{ "a position (" { $link camera-eye } ")" }
-{ "a focus direction (" { $link camera-focus } ")\n" }
-{ "an attitude information (" { $link camera-up } ")\n" }
-}
-"\nUse " { $link do-look-at } " in opengl statement in placement of gl-look-at"
-"\n\n"
-"A camera is a " { $vocab-link "4DNav.turtle" } " object. Its a special vocab to handle mouvements of a 3D object:"
-{ $list
-{ "To define a camera"
-{
- $unchecked-example
-
-"VAR: my-camera"
-": init-my-camera ( -- )"
-" <turtle> >my-camera"
-" [ my-camera> >self"
-" reset-turtle "
-" ] with-scope ;"
-} }
-{ "To move it"
-{
- $unchecked-example
-
-" [ my-camera> >self"
-" 45 pitch-up "
-" 5 step-turtle"
-" ] with-scope "
-} }
-{ "or"
-{
- $unchecked-example
-
-" [ my-camera> >self"
-" 5 strafe-left"
-" ] with-scope "
-}
-}
-{
-"to use it in an opengl statement"
-{
- $unchecked-example
- "my-camera> do-look-at"
-
-}
-}
-}
-
-
-;
-
-ABOUT: "4DNav.camera"
+++ /dev/null
-USING: kernel namespaces math.vectors opengl 4DNav.turtle self ;
-
-IN: 4DNav.camera
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: camera-eye ( -- point ) turtle-pos> ;
-
-: camera-focus ( -- point ) [ 1 step-turtle turtle-pos> ] save-self ;
-
-: camera-up ( -- dirvec )
-[ 90 pitch-up turtle-pos> 1 step-turtle turtle-pos> swap v- ] save-self ;
-
-: do-look-at ( camera -- )
-[ >self camera-eye camera-focus camera-up gl-look-at ] with-scope ;
+++ /dev/null
-! Copyright (C) 2008 Jean-François Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations sequences ;
-IN: 4DNav.deep
-
-! HELP: deep-cleave-quots
-! { $values
-! { "seq" sequence }
-! { "quot" quotation }
-! }
-! { $description "A word to build a soquence from a sequence of quotation" }
-!
-! { $examples
-! "It is useful to build matrix"
-! { $example "USING: math math.trig ; "
-! " 30 deg>rad "
-! " { { [ cos ] [ sin neg ] 0 } "
-! " { [ sin ] [ cos ] 0 } "
-! " { 0 0 1 } "
-! " } deep-cleave-quots "
-! " "
-!
-!
-! } }
-! ;
-
-ARTICLE: "4DNav.deep" "4DNav.deep"
-{ $vocab-link "4DNav.deep" }
-;
-
-ABOUT: "4DNav.deep"
+++ /dev/null
-USING: macros quotations math math.functions math.trig sequences.deep kernel make fry combinators grouping ;\r
-IN: 4DNav.deep\r
-\r
-! USING: bake ;\r
-! MACRO: deep-cleave-quots ( seq -- quot )\r
-! [ [ quotation? ] deep-filter ]\r
-! [ [ dup quotation? [ drop , ] when ] deep-map ]\r
-! bi '[ _ cleave _ bake ] ;\r
-\r
-: make-matrix ( quot width -- matrix ) [ { } make ] dip group ; inline\r
-\r
+++ /dev/null
-USING: tools.deploy.config ;
-H{
- { deploy-c-types? t }
- { deploy-word-props? t }
- { deploy-name "4DNav" }
- { deploy-ui? t }
- { deploy-math? t }
- { deploy-threads? t }
- { deploy-reflection 3 }
- { deploy-compiler? t }
- { deploy-unicode? t }
- { deploy-io 3 }
- { "stop-after-last-window?" t }
- { deploy-word-defs? t }
-}
+++ /dev/null
-Jeff Bigot
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING:\r
-kernel\r
-io.files\r
-io.backend\r
-io.directories\r
-io.files.info\r
-io.pathnames\r
-sequences\r
-models\r
-strings\r
-ui\r
-ui.operations\r
-ui.commands\r
-ui.gestures\r
-ui.gadgets\r
-ui.gadgets.buttons\r
-ui.gadgets.lists\r
-ui.gadgets.labels\r
-ui.gadgets.tracks\r
-ui.gadgets.packs\r
-ui.gadgets.panes\r
-ui.gadgets.scrollers\r
-prettyprint\r
-combinators\r
-rewrite-closures\r
-accessors\r
-values\r
-tools.walker\r
-fry\r
-;\r
-IN: 4DNav.file-chooser\r
-\r
-TUPLE: file-chooser < track \r
- path\r
- extension \r
- selected-file\r
- presenter\r
- hook \r
- list\r
- ;\r
-\r
-: find-file-list ( gadget -- list )\r
- [ file-chooser? ] find-parent list>> ;\r
-\r
-file-chooser H{\r
- { T{ key-down f f "UP" } [ find-file-list select-previous ] }\r
- { T{ key-down f f "DOWN" } [ find-file-list select-next ] }\r
- { T{ key-down f f "PAGE_UP" } [ find-file-list list-page-up ] }\r
- { T{ key-down f f "PAGE_DOWN" } [ find-file-list list-page-down ] }\r
- { T{ key-down f f "RET" } [ find-file-list invoke-value-action ] }\r
- { T{ button-down } request-focus }\r
- { T{ button-down f 1 } [ find-file-list invoke-value-action ] }\r
-} set-gestures\r
-\r
-: list-of-files ( file-chooser -- seq )\r
- [ path>> value>> directory-entries ] [ extension>> ] bi\r
- '[ [ name>> _ [ tail? ] with contains? ] [ directory? ] bi or ] filter\r
-;\r
-\r
-: update-filelist-model ( file-chooser -- file-chooser )\r
- [ list-of-files ] [ model>> ] bi set-model ;\r
-\r
-: init-filelist-model ( file-chooser -- file-chooser )\r
- dup list-of-files <model> >>model ; \r
-\r
-: (fc-go) ( file-chooser quot -- )\r
- [ [ file-chooser? ] find-parent dup path>> ] dip\r
- call\r
- normalize-path swap set-model\r
- update-filelist-model\r
- drop ;\r
-\r
-: fc-go-parent ( file-chooser -- )\r
- [ dup value>> parent-directory ] (fc-go) ;\r
-\r
-: fc-go-home ( file-chooser -- )\r
- [ home ] (fc-go) ;\r
-\r
-: fc-change-directory ( file-chooser file -- file-chooser )\r
- dupd [ path>> value>> normalize-path ] [ name>> ] bi* \r
- append-path over path>> set-model \r
- update-filelist-model\r
-;\r
-\r
-: fc-load-file ( file-chooser file -- )\r
- dupd [ selected-file>> ] [ name>> ] bi* swap set-model \r
- [ path>> value>> ] \r
- [ selected-file>> value>> append ] \r
- [ hook>> ] tri\r
- call\r
-; inline\r
-\r
-! : fc-ok-action ( file-chooser -- quot )\r
-! dup selected-file>> value>> "" =\r
-! [ drop [ drop ] ] [ \r
-! [ path>> value>> ] \r
-! [ selected-file>> value>> append ] \r
-! [ hook>> prefix ] tri\r
-! [ drop ] prepend\r
-! ] if ; \r
-\r
-: line-selected-action ( file-chooser -- )\r
- dup list>> list-value\r
- dup directory? \r
- [ fc-change-directory ] [ fc-load-file ] if ;\r
-\r
-: present-dir-element ( element -- string )\r
- [ name>> ] [ directory? ] bi [ "-> " prepend ] when ;\r
-\r
-: <file-list> ( file-chooser -- list )\r
- dup [ nip line-selected-action ] curry \r
- [ present-dir-element ] rot model>> <list> ;\r
-\r
-: <file-chooser> ( hook path extension -- gadget )\r
- { 0 1 } file-chooser new-track\r
- swap >>extension\r
- swap <model> >>path\r
- "" <model> >>selected-file\r
- swap >>hook\r
- init-filelist-model\r
- dup <file-list> >>list\r
- "choose a file in directory " <label> f track-add\r
- dup path>> <label-control> f track-add\r
- dup extension>> ", " join "limited to : " prepend <label> f track-add\r
- <shelf> \r
- "selected file : " <label> add-gadget\r
- over selected-file>> <label-control> add-gadget\r
- f track-add\r
- <shelf> \r
- over [ swap fc-go-parent ] curry "go up" swap <bevel-button> add-gadget\r
- over [ swap fc-go-home ] curry "go home" swap <bevel-button> add-gadget\r
- ! over [ swap fc-ok-action ] curry "OK" swap <bevel-button> add-gadget\r
- ! [ drop ] "Cancel" swap <bevel-button> add-gadget\r
- f track-add\r
- dup list>> <scroller> 1 track-add\r
-;\r
-\r
-M: file-chooser pref-dim* drop { 400 200 } ;\r
-\r
-: file-chooser-window ( -- )\r
-[ . ] home { "xml" "txt" } <file-chooser> "Choose a file" open-window ;\r
-\r
+++ /dev/null
-<model>\r
-<space>\r
- <name>hypercube</name>\r
- <dimension>4</dimension>\r
- <solid>\r
- <name>4cube1</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,100</face>\r
- <face>-1,0,0,0,-150</face>\r
- <face>0,1,0,0,100</face>\r
- <face>0,-1,0,0,-150</face>\r
- <face>0,0,1,0,100</face>\r
- <face>0,0,-1,0,-150</face>\r
- <face>0,0,0,1,100</face>\r
- <face>0,0,0,-1,-150</face>\r
- <color>1,0,0</color>\r
- </solid>\r
- <solid>\r
- <name>4cube1</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,100</face>\r
- <face>-1,0,0,0,-150</face>\r
- <face>0,1,0,0,100</face>\r
- <face>0,-1,0,0,-150</face>\r
- <face>0,0,1,0,100</face>\r
- <face>0,0,-1,0,-150</face>\r
- <face>0,0,0,1,100</face>\r
- <face>0,0,0,-1,-150</face>\r
- <color>1,0,0</color>\r
- </solid>\r
- <light>\r
- <direction>1,1,1,1</direction>\r
- <color>0.2,0.2,0.6</color>\r
- </light>\r
- <color>0.8,0.9,0.9</color>\r
-</space>\r
-</model>\r
+++ /dev/null
-<model>\r
-<space>\r
- <name>multi solids</name>\r
- <dimension>4</dimension>\r
- <solid>\r
- <name>4cube1</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,100</face>\r
- <face>-1,0,0,0,-150</face>\r
- <face>0,1,0,0,100</face>\r
- <face>0,-1,0,0,-150</face>\r
- <face>0,0,1,0,100</face>\r
- <face>0,0,-1,0,-150</face>\r
- <face>0,0,0,1,100</face>\r
- <face>0,0,0,-1,-150</face>\r
- <color>1,1,1</color>\r
- </solid>\r
- <solid>\r
- <name>4triancube</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,160</face>\r
- <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
- <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
- <face>0,0,1,0,140</face>\r
- <face>0,0,-1,0,-180</face>\r
- <face>0,0,0,1,110</face>\r
- <face>0,0,0,-1,-180</face>\r
- <color>1,1,1</color>\r
- </solid>\r
- <solid>\r
- <name>triangone</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,60</face>\r
- <face>0.5,0.8660254037844386,0,0,60</face>\r
- <face>-0.5,0.8660254037844387,0,0,-20</face>\r
- <face>-1.0,0,0,0,-100</face>\r
- <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
- <face>0.5,-0.8660254037844387,0,0,-20</face>\r
- <face>0,0,1,0,120</face>\r
- <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
- <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
- <color>1,1,1</color>\r
- </solid>\r
- <light>\r
- <direction>1,0,0,0</direction>\r
- <color>0,0,0,0.6</color>\r
- </light>\r
- <light>\r
- <direction>0,1,0,0</direction>\r
- <color>0,0.6,0,0</color>\r
- </light>\r
- <light>\r
- <direction>0,0,1,0</direction>\r
- <color>0,0,0.6,0</color>\r
- </light>\r
- <light>\r
- <direction>0,0,0,1</direction>\r
- <color>0.6,0.6,0.6</color>\r
- </light>\r
- <color>0.99,0.99,0.99</color>\r
-</space>\r
-</model>\r
+++ /dev/null
-<model>\r
-<space>\r
- <name>multi solids</name>\r
- <dimension>4</dimension>\r
- <solid>\r
- <name>4cube1</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,100</face>\r
- <face>-1,0,0,0,-150</face>\r
- <face>0,1,0,0,100</face>\r
- <face>0,-1,0,0,-150</face>\r
- <face>0,0,1,0,100</face>\r
- <face>0,0,-1,0,-150</face>\r
- <face>0,0,0,1,100</face>\r
- <face>0,0,0,-1,-150</face>\r
- <color>1,0,0</color>\r
- </solid>\r
- <solid>\r
- <name>4triancube</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,160</face>\r
- <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
- <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
- <face>0,0,1,0,140</face>\r
- <face>0,0,-1,0,-180</face>\r
- <face>0,0,0,1,110</face>\r
- <face>0,0,0,-1,-180</face>\r
- <color>0,1,0</color>\r
- </solid>\r
- <solid>\r
- <name>triangone</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,60</face>\r
- <face>0.5,0.8660254037844386,0,0,60</face>\r
- <face>-0.5,0.8660254037844387,0,0,-20</face>\r
- <face>-1.0,0,0,0,-100</face>\r
- <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
- <face>0.5,-0.8660254037844387,0,0,-20</face>\r
- <face>0,0,1,0,120</face>\r
- <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
- <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
- <color>0,1,1</color>\r
- </solid>\r
- <light>\r
- <direction>1,1,1,1</direction>\r
- <color>0.2,0.2,0.6</color>\r
- </light>\r
- <color>0.8,0.9,0.9</color>\r
-</space>\r
-</model>\r
+++ /dev/null
-<model>\r
-<space>\r
- <name>Prismetragone</name> \r
- <dimension>4</dimension>\r
- <solid>\r
- <name>triangone</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,60</face>\r
- <face>0.5,0.8660254037844386,0,0,60</face>\r
- <face>-0.5,0.8660254037844387,0,0,-20</face>\r
- <face>-1.0,0,0,0,-100</face>\r
- <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
- <face>0.5,-0.8660254037844387,0,0,-20</face>\r
- <face>0,0,1,0,120</face>\r
- <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
- <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
- <color>0,1,1</color>\r
- </solid>\r
- <light>\r
- <direction>1,1,1,1</direction>\r
- <color>0.2,0.2,0.6</color>\r
- </light>\r
- <color>0.8,0.9,0.9</color>\r
-</space>\r
-</model>\r
+++ /dev/null
-Jeff Bigot
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Jean-François Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel ;
-IN: 4DNav.space-file-decoder
-
-HELP: adsoda-read-model
-{ $values
- { "tag" null }
-}
-{ $description "" } ;
-
-HELP: decode-number-array
-{ $values
- { "x" null }
- { "y" null }
-}
-{ $description "" } ;
-
-HELP: read-model-file
-{ $values
-
- { "path" "path to the file to read" }
- { "x" null }
-}
-{ $description "" } ;
-
-ARTICLE: "4DNav.space-file-decoder" "4DNav.space-file-decoder"
-{ $vocab-link "4DNav.space-file-decoder" }
-;
-
-ABOUT: "4DNav.space-file-decoder"
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: adsoda xml xml.utilities xml.dispatch accessors combinators\r
-sequences math.parser kernel splitting values continuations ;\r
-IN: 4DNav.space-file-decoder\r
-\r
-: decode-number-array ( x -- y ) "," split [ string>number ] map ;\r
-\r
-PROCESS: adsoda-read-model ( tag -- )\r
-\r
-TAG: dimension adsoda-read-model children>> first string>number ;\r
-TAG: direction adsoda-read-model children>> first decode-number-array ;\r
-TAG: color adsoda-read-model children>> first decode-number-array ;\r
-TAG: name adsoda-read-model children>> first ;\r
-TAG: face adsoda-read-model children>> first decode-number-array ;\r
-\r
-TAG: solid adsoda-read-model \r
- <solid> swap \r
- { \r
- [ "dimension" tag-named adsoda-read-model >>dimension ] \r
- [ "name" tag-named adsoda-read-model >>name ] \r
- [ "color" tag-named adsoda-read-model >>color ] \r
- [ "face" tags-named [ adsoda-read-model cut-solid ] each ] \r
- } cleave\r
- ensure-adjacencies\r
-;\r
-\r
-TAG: light adsoda-read-model \r
- <light> swap \r
- { \r
- [ "direction" tag-named adsoda-read-model >>direction ] \r
- [ "color" tag-named adsoda-read-model >>color ] \r
- } cleave\r
-;\r
-\r
-TAG: space adsoda-read-model \r
- <space> swap \r
- { \r
- [ "dimension" tag-named adsoda-read-model >>dimension ] \r
- [ "name" tag-named adsoda-read-model >>name ] \r
- [ "color" tag-named adsoda-read-model >>ambient-color ] \r
- [ "solid" tags-named [ adsoda-read-model suffix-solids ] each ] \r
- [ "light" tags-named [ adsoda-read-model suffix-lights ] each ] \r
- } cleave\r
-;\r
-\r
-: read-model-file ( path -- x )\r
- dup\r
- [\r
- [ file>xml "space" tags-named first adsoda-read-model ] \r
- [ drop <space> ] recover \r
- ] [ drop <space> ] if \r
-\r
-;\r
-\r
+++ /dev/null
-4DNav : simmple tool to navigate thru a 4D space view as projections on 4 3D spaces.
\ No newline at end of file
+++ /dev/null
-4D viewer
\ No newline at end of file
+++ /dev/null
-<model>\r
-<space>\r
- <name>triancube</name> \r
- <dimension>4</dimension>\r
- <solid>\r
- <name>triancube</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,160</face>\r
- <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
- <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
- <face>0,0,1,0,140</face>\r
- <face>0,0,-1,0,-180</face>\r
- <face>0,0,0,1,110</face>\r
- <face>0,0,0,-1,-180</face>\r
- <color>0,1,0</color>\r
- </solid>\r
- <light>\r
- <direction>1,1,1,1</direction>\r
- <color>0.2,0.2,0.6</color>\r
- </light>\r
- <color>0.8,0.9,0.9</color>\r
-</space>\r
-</model>\r
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-! Copyright (C) 2008 Jean-François Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays help.markup help.syntax kernel sequences ;
-IN: 4DNav.turtle
-
-HELP: <turtle>
-{ $values
-
- { "turtle" null }
-}
-{ $description "" } ;
-
-HELP: >turtle-ori
-{ $values
- { "val" null }
-}
-{ $description "" } ;
-
-HELP: >turtle-pos
-{ $values
- { "val" null }
-}
-{ $description "" } ;
-
-HELP: Rx
-{ $values
- { "angle" null }
- { "Rz" null }
-}
-{ $description "" } ;
-
-HELP: Ry
-{ $values
- { "angle" null }
- { "Ry" null }
-}
-{ $description "" } ;
-
-HELP: Rz
-{ $values
- { "angle" null }
- { "Rx" null }
-}
-{ $description "" } ;
-
-HELP: V
-{ $values
-
- { "V" null }
-}
-{ $description "" } ;
-
-HELP: X
-{ $values
-
- { "3array" null }
-}
-{ $description "" } ;
-
-HELP: Y
-{ $values
-
- { "3array" null }
-}
-{ $description "" } ;
-
-HELP: Z
-{ $values
-
- { "3array" null }
-}
-{ $description "" } ;
-
-HELP: apply-rotation
-{ $values
- { "rotation" null }
-}
-{ $description "" } ;
-
-HELP: distance
-{ $values
- { "turtle" null } { "turtle" null }
- { "n" null }
-}
-{ $description "" } ;
-
-HELP: move-by
-{ $values
- { "point" null }
-}
-{ $description "" } ;
-
-HELP: pitch-down
-{ $values
- { "angle" null }
-}
-{ $description "" } ;
-
-HELP: pitch-up
-{ $values
- { "angle" null }
-}
-{ $description "" } ;
-
-HELP: reset-turtle
-{ $description "" } ;
-
-HELP: roll-left
-{ $values
- { "angle" null }
-}
-{ $description "" } ;
-
-HELP: roll-right
-{ $values
- { "angle" null }
-}
-{ $description "" } ;
-
-HELP: roll-until-horizontal
-{ $description "" } ;
-
-HELP: rotate-x
-{ $values
- { "angle" null }
-}
-{ $description "" } ;
-
-HELP: rotate-y
-{ $values
- { "angle" null }
-}
-{ $description "" } ;
-
-HELP: rotate-z
-{ $values
- { "angle" null }
-}
-{ $description "" } ;
-
-HELP: set-X
-{ $values
- { "seq" sequence }
-}
-{ $description "" } ;
-
-HELP: set-Y
-{ $values
- { "seq" sequence }
-}
-{ $description "" } ;
-
-HELP: set-Z
-{ $values
- { "seq" sequence }
-}
-{ $description "" } ;
-
-HELP: step-turtle
-{ $values
- { "length" null }
-}
-{ $description "" } ;
-
-HELP: step-vector
-{ $values
- { "length" null }
- { "array" array }
-}
-{ $description "" } ;
-
-HELP: strafe-down
-{ $values
- { "length" null }
-}
-{ $description "" } ;
-
-HELP: strafe-left
-{ $values
- { "length" null }
-}
-{ $description "" } ;
-
-HELP: strafe-right
-{ $values
- { "length" null }
-}
-{ $description "" } ;
-
-HELP: strafe-up
-{ $values
- { "length" null }
-}
-{ $description "" } ;
-
-HELP: turn-left
-{ $values
- { "angle" null }
-}
-{ $description "" } ;
-
-HELP: turn-right
-{ $values
- { "angle" null }
-}
-{ $description "" } ;
-
-HELP: turtle
-{ $description "" } ;
-
-HELP: turtle-ori>
-{ $values
-
- { "val" null }
-}
-{ $description "" } ;
-
-HELP: turtle-pos>
-{ $values
-
- { "val" null }
-}
-{ $description "" } ;
-
-ARTICLE: "4DNav.turtle" "4DNav.turtle"
-{ $vocab-link "4DNav.turtle" }
-;
-
-ABOUT: "4DNav.turtle"
+++ /dev/null
-USING: kernel math arrays math.vectors math.matrices
-namespaces make
-math.constants math.functions
-math.vectors
-splitting grouping self math.trig
- sequences accessors 4DNav.deep models ;
-IN: 4DNav.turtle
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: turtle pos ori ;
-
-: <turtle> ( -- turtle )
- turtle new
- { 0 0 0 } clone >>pos
- 3 identity-matrix >>ori
-;
-
-
-TUPLE: observer < turtle projection-mode collision-mode ;
-
-: <observer> ( -- object )
- observer new
- 0 <model> >>projection-mode
- f <model> >>collision-mode
- ;
-
-
-: turtle-pos> ( -- val ) self> pos>> ;
-: >turtle-pos ( val -- ) self> (>>pos) ;
-
-: turtle-ori> ( -- val ) self> ori>> ;
-: >turtle-ori ( val -- ) self> (>>ori) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! These rotation matrices are from
-! `Computer Graphics: Principles and Practice'
-
-
-! waiting for deep-cleave-quots
-
-! : Rz ( angle -- Rx ) deg>rad
-! { { [ cos ] [ sin neg ] 0 }
-! { [ sin ] [ cos ] 0 }
-! { 0 0 1 }
-! } deep-cleave-quots ;
-
-! : Ry ( angle -- Ry ) deg>rad
-! { { [ cos ] 0 [ sin ] }
-! { 0 1 0 }
-! { [ sin neg ] 0 [ cos ] }
-! } deep-cleave-quots ;
-
-! : Rx ( angle -- Rz ) deg>rad
-! { { 1 0 0 }
-! { 0 [ cos ] [ sin neg ] }
-! { 0 [ sin ] [ cos ] }
-! } deep-cleave-quots ;
-
-: Rz ( angle -- Rx ) deg>rad
-[ dup cos , dup sin neg , 0 ,
- dup sin , dup cos , 0 ,
- 0 , 0 , 1 , ] 3 make-matrix nip ;
-
-: Ry ( angle -- Ry ) deg>rad
-[ dup cos , 0 , dup sin ,
- 0 , 1 , 0 ,
- dup sin neg , 0 , dup cos , ] 3 make-matrix nip ;
-
-: Rx ( angle -- Rz ) deg>rad
-[ 1 , 0 , 0 ,
- 0 , dup cos , dup sin neg ,
- 0 , dup sin , dup cos , ] 3 make-matrix nip ;
-
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: apply-rotation ( rotation -- ) turtle-ori> swap m. >turtle-ori ;
-
-: rotate-x ( angle -- ) Rx apply-rotation ;
-: rotate-y ( angle -- ) Ry apply-rotation ;
-: rotate-z ( angle -- ) Rz apply-rotation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pitch-up ( angle -- ) neg rotate-x ;
-: pitch-down ( angle -- ) rotate-x ;
-
-: turn-left ( angle -- ) rotate-y ;
-: turn-right ( angle -- ) neg rotate-y ;
-
-: roll-left ( angle -- ) neg rotate-z ;
-: roll-right ( angle -- ) rotate-z ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! roll-until-horizontal
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: V ( -- V ) { 0 1 0 } ;
-
-: X ( -- 3array ) turtle-ori> [ first ] map ;
-: Y ( -- 3array ) turtle-ori> [ second ] map ;
-: Z ( -- 3array ) turtle-ori> [ third ] map ;
-
-: set-X ( seq -- ) turtle-ori> [ set-first ] 2each ;
-: set-Y ( seq -- ) turtle-ori> [ set-second ] 2each ;
-: set-Z ( seq -- ) turtle-ori> [ set-third ] 2each ;
-
-: roll-until-horizontal ( -- )
- V Z cross normalize set-X
- Z X cross normalize set-Y ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: distance ( turtle turtle -- n ) pos>> swap pos>> v- [ sq ] map sum sqrt ;
-
-: move-by ( point -- ) turtle-pos> v+ >turtle-pos ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: reset-turtle ( -- )
- { 0 0 0 } clone >turtle-pos 3 identity-matrix >turtle-ori ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: step-vector ( length -- array ) { 0 0 1 } n*v ;
-
-: step-turtle ( length -- )
- step-vector turtle-ori> swap m.v turtle-pos> v+ >turtle-pos ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: strafe-up ( length -- )
- 90 pitch-up
- step-turtle
- 90 pitch-down ;
-
-: strafe-down ( length -- )
- 90 pitch-down
- step-turtle
- 90 pitch-up ;
-
-: strafe-left ( length -- )
- 90 turn-left
- step-turtle
- 90 turn-right ;
-
-: strafe-right ( length -- )
- 90 turn-right
- step-turtle
- 90 turn-left ;
+++ /dev/null
-Jeff Bigot
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Jean-François Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel ;
-IN: 4DNav.window3D
-
-HELP: <window3D>
-{ $values
- { "model" null } { "observer" null }
- { "gadget" null }
-}
-{ $description "" } ;
-
-HELP: window3D
-{ $description "" } ;
-
-ARTICLE: "4DNav.window3D" "4DNav.window3D"
-{ $vocab-link "4DNav.window3D" }
-;
-
-ABOUT: "4DNav.window3D"
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel \r
-ui.gadgets\r
-ui.render\r
-opengl\r
-opengl.gl\r
-opengl.glu\r
-4DNav.camera\r
-4DNav.turtle\r
-math\r
-values\r
-alien.c-types\r
-accessors\r
-namespaces\r
-adsoda \r
-models\r
-accessors\r
-prettyprint\r
-;\r
-\r
-IN: 4DNav.window3D\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! drawing functions \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-TUPLE: window3D < gadget observer ; \r
-\r
-: <window3D> ( model observer -- gadget )\r
- window3D new-gadget \r
- swap 2dup \r
- projection-mode>> add-connection\r
- 2dup \r
- collision-mode>> add-connection\r
- >>observer \r
- swap <model> >>model \r
- t >>root?\r
-;\r
-\r
-M: window3D pref-dim* ( gadget -- dim ) drop { 300 300 } ;\r
-\r
-M: window3D draw-gadget* ( gadget -- )\r
-\r
- GL_PROJECTION glMatrixMode\r
- glLoadIdentity\r
- 0.6 0.6 0.6 .9 glClearColor\r
- dup observer>> projection-mode>> value>> 1 = \r
- [ 60.0 1.0 0.1 3000.0 gluPerspective ]\r
- [ -400.0 400.0 -400.0 400.0 0.0 4000.0 glOrtho ] if\r
- dup observer>> collision-mode>> value>> \r
- \ remove-hidden-solids? \r
- set-value\r
- dup observer>> do-look-at\r
- GL_MODELVIEW glMatrixMode\r
- glLoadIdentity \r
- 0.9 0.9 0.9 1.0 glClearColor\r
- 1.0 glClearDepth\r
- GL_LINE_SMOOTH glEnable\r
- GL_BLEND glEnable\r
- GL_DEPTH_TEST glEnable \r
- GL_LEQUAL glDepthFunc\r
- GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc\r
- GL_LINE_SMOOTH_HINT GL_NICEST glHint\r
- 1.25 glLineWidth\r
- GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear\r
- glLoadIdentity\r
- GL_LIGHTING glEnable\r
- GL_LIGHT0 glEnable\r
- GL_COLOR_MATERIAL glEnable\r
- GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial\r
- ! *************************\r
- \r
- model>> value>> \r
- [ space->GL ] when*\r
-\r
- ! *************************\r
-;\r
-\r
-M: window3D graft* drop ;\r
-\r
-M: window3D model-changed nip relayout ; \r
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.markup help.syntax ;\r
-\r
-IN: adsoda\r
-\r
-\r
-\r
-! --------------------------------------------------------------\r
-! faces\r
-! --------------------------------------------------------------\r
-ARTICLE: "face-page" "face in ADSODA"\r
-"explanation of faces"\r
-$nl\r
-"link to functions"\r
-"what is an halfspace"\r
-"halfspace touching-corners adjacent-faces"\r
-"touching-corners list of pointers to the corners which touch this face\n"\r
-\r
-"adjacent-faces list of pointers to the faces which touch this face\n"\r
-{ $subsection face }\r
-{ $subsection <face> }\r
-"test relative position"\r
-{ $subsection point-inside-or-on-face? } \r
-{ $subsection point-inside-face? }\r
-"handling face"\r
-{ $subsection flip-face }\r
-{ $subsection face-translate }\r
-{ $subsection face-transform }\r
-\r
-;\r
-\r
-HELP: face\r
-{ $class-description "a face is defined by"\r
-{ $list "halfspace equation" }\r
-{ $list "list of touching corners" }\r
-{ $list "list of adjacent faces" }\r
-$nl\r
-"Touching corners and adjacent faces are defined by algorithm thanks to other faces of the solid"\r
-}\r
-\r
-\r
-;\r
-HELP: <face> \r
-{ $values { "v" "an halfspace equation" } { "tuple" "a face" } } ;\r
-HELP: flip-face \r
-{ $values { "face" "a face" } { "face" "flipped face" } }\r
-{ $description "change the orientation of a face" }\r
-;\r
-\r
-HELP: face-translate \r
-{ $values { "face" "a face" } { "v" "a vector" } }\r
-{ $description \r
-"translate a face following a vector"\r
-$nl\r
-"a translation of an halfspace doesn't change the normal vector. this word just compute the new constant term" }\r
-\r
- \r
- ;\r
-HELP: face-transform \r
-{ $values { "face" "a face" } { "m" "a transformation matrix" } }\r
-{ $description "compute the transformation of a face using a transformation matrix" }\r
- \r
- ;\r
-! --------------------------------\r
-! solid\r
-! --------------------------------------------------------------\r
-ARTICLE: "solid-page" "solid in ADSODA"\r
-"explanation of solids"\r
-$nl\r
-"link to functions"\r
-{ $subsection solid }\r
-{ $subsection <solid> }\r
-"test relative position"\r
-{ $subsection point-inside-solid? }\r
-{ $subsection point-inside-or-on-solid? }\r
-"playing with faces and solids"\r
-{ $subsection add-face }\r
-{ $subsection cut-solid }\r
-{ $subsection slice-solid }\r
-"solid handling"\r
-{ $subsection solid-project }\r
-{ $subsection solid-translate }\r
-{ $subsection solid-transform }\r
-{ $subsection subtract }\r
-\r
-{ $subsection get-silhouette }\r
-\r
-{ $subsection solid= }\r
-\r
-\r
-;\r
-\r
-HELP: solid \r
-{ $class-description "dimension" $nl "silhouettes" $nl "faces" $nl "corners" $nl "adjacencies-valid" $nl "color" $nl "name" \r
-}\r
-;\r
-\r
-HELP: add-face \r
-{ $values { "solid" "a solid" } { "face" "a face" } }\r
-{ $description "reshape a solid with a face. The face truncate the solid." } ;\r
-\r
-HELP: cut-solid\r
-{ $values { "solid" "a solid" } { "halfspace" "an halfspace" } }\r
-{ $description "like add-face but just with halfspace equation" } ;\r
-\r
-HELP: slice-solid\r
-{ $values { "solid" "a solid" } { "face" "a face" } { "solid1" "the outer part of the former solid" } { "solid2" "the inner part of the former solid" } }\r
-{ $description "cut a solid into two parts. The face acts like a knife"\r
-} ;\r
-\r
-\r
-HELP: solid-project\r
-{ $values { "lights" "lights" } { "ambient" "ambient" } { "solid" "solid" } { "solids" "projection of solid" } }\r
-{ $description "Project the solid using pv vector" \r
-$nl\r
-"TODO: explain how to use lights"\r
-} ;\r
-\r
-HELP: solid-translate \r
-{ $values { "solid" "a solid" } { "v" "translating vector" } }\r
-{ $description "Translate a solid using a vector" \r
-$nl\r
-"v and solid must have the same dimension "\r
-} ;\r
-\r
-HELP: solid-transform \r
-{ $values { "solid" "a solid" } { "m" "transformation matrix" } }\r
-{ $description "Transform a solid using a matrix"\r
-$nl\r
-"v and solid must have the same dimension "\r
-} ;\r
-\r
-HELP: subtract \r
-{ $values { "solid1" "initial shape" } { "solid2" "shape to remove" } { "solids" "resulting shape" } }\r
-{ $description " " } ;\r
-\r
-\r
-! --------------------------------------------------------------\r
-! space \r
-! --------------------------------------------------------------\r
-ARTICLE: "space-page" "space in ADSODA"\r
-"A space is a collection of solids and lights."\r
-$nl\r
-"link to functions"\r
-$nl\r
-"Defining words"\r
-{ $subsection space }\r
-{ $subsection <space> } \r
-{ $subsection suffix-solids }\r
-{ $subsection suffix-lights }\r
-{ $subsection clear-space-solids }\r
-{ $subsection describe-space }\r
-\r
-\r
-"Handling space"\r
-{ $subsection space-ensure-solids }\r
-{ $subsection eliminate-empty-solids }\r
-{ $subsection space-transform }\r
-{ $subsection space-translate }\r
-{ $subsection remove-hidden-solids }\r
-{ $subsection space-project }\r
-\r
-\r
-;\r
-\r
-HELP: space \r
-{ $class-description \r
-"dimension" $nl " solids" $nl " ambient-color" $nl "lights" \r
-}\r
-;\r
-\r
-HELP: suffix-solids \r
-"( space solid -- space )"\r
-{ $values { "space" "a space" } { "solid" "a solid to add" } }\r
-{ $description "Add solid to space definition" } ;\r
-\r
-HELP: suffix-lights \r
-"( space light -- space ) "\r
-{ $values { "space" "a space" } { "light" "a light to add" } }\r
-{ $description "Add a light to space definition" } ;\r
-\r
-HELP: clear-space-solids \r
-"( space -- space )" \r
-{ $values { "space" "a space" } }\r
-{ $description "remove all solids in space" } ;\r
-\r
-HELP: space-ensure-solids \r
-{ $values { "space" "a space" } }\r
-{ $description "rebuild corners of all solids in space" } ;\r
-\r
-\r
-\r
-HELP: space-transform \r
-" ( space m -- space )" \r
-{ $values { "space" "a space" } { "m" "a matrix" } }\r
-{ $description "Transform a space using a matrix" } ;\r
-\r
-HELP: space-translate \r
-{ $values { "space" "a space" } { "v" "a vector" } }\r
-{ $description "Translate a space following a vector" } ;\r
-\r
-HELP: describe-space " ( space -- )"\r
-{ $values { "space" "a space" } }\r
-{ $description "return a description of space" } ;\r
-\r
-HELP: space-project \r
-{ $values { "space" "a space" } { "i" "an integer" } }\r
-{ $description "Project a space along ith coordinate" } ;\r
-\r
-! --------------------------------------------------------------\r
-! 3D rendering\r
-! --------------------------------------------------------------\r
-ARTICLE: "3D-rendering-page" "3D rendering in ADSODA"\r
-"explanation of 3D rendering"\r
-$nl\r
-"link to functions"\r
-{ $subsection face->GL }\r
-{ $subsection solid->GL }\r
-{ $subsection space->GL }\r
-\r
-;\r
-\r
-HELP: face->GL \r
-{ $values { "face" "a face" } { "color" "3 3 values array" } }\r
-{ $description "" } ;\r
-\r
-HELP: solid->GL \r
-{ $values { "solid" "a solid" } }\r
-{ $description "" } ;\r
-\r
-HELP: space->GL \r
-{ $values { "space" "a space" } }\r
-{ $description "" } ;\r
-\r
-! --------------------------------------------------------------\r
-! light\r
-! --------------------------------------------------------------\r
-\r
-ARTICLE: "light-page" "light in ADSODA"\r
-"explanation of light"\r
-$nl\r
-"link to functions"\r
-;\r
-\r
-ARTICLE: { "adsoda" "light" } "ADSODA : lights"\r
-"! HELP: light position color" \r
-"! <light> ( -- tuple ) light new ;"\r
-\r
-"! light est un vecteur avec 3 variables pour les couleurs\n"\r
-\r
-" void Light::Apply(Vector& normal, double &cRed, double &cGreen, double &cBlue)\n"\r
-" { \n"\r
-" // Dot the light direction with the normalized normal of Face."\r
-" register double intensity = -(normal * (*this));"\r
-\r
-" // Face is a backface, from light's perspective"\r
-" if (intensity < 0)"\r
-" return;"\r
-" "\r
-" // Add the intensity componentwise"\r
-" cRed += red * intensity;"\r
-" cGreen += green * intensity;"\r
-" cBlue += blue * intensity;"\r
-\r
-" // Clip to unit range"\r
-" if (cRed > 1.0) cRed = 1.0;"\r
-" if (cGreen > 1.0) cGreen = 1.0;"\r
-" if (cBlue > 1.0) cBlue = 1.0;"\r
-\r
-\r
-;\r
-\r
-\r
-\r
-ARTICLE: { "adsoda" "halfspace" } "ADSODA : halfspace"\r
-"! demi espace défini par un vecteur normal et une constante"\r
-" defined by the concatenation of the normal vector and a constant" \r
- ;\r
-\r
-\r
-\r
-ARTICLE: "adsoda-main-page" "ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm"\r
-"multidimensional handler :" \r
-$nl\r
-"design a solid using face delimitations. Only works on convex shapes"\r
-$nl\r
-{ $emphasis "written in C++ by Greg Ferrar" }\r
-$nl\r
-"full explanation on adsoda page at " { $url "http://www.flowerfire.com/ADSODA/" }\r
-$nl\r
-"Useful words are describe on the following pages: "\r
-{ $subsection "face-page" }\r
-{ $subsection "solid-page" }\r
-{ $subsection "space-page" }\r
-{ $subsection "light-page" }\r
-{ $subsection "3D-rendering-page" }\r
- ;\r
-\r
-ABOUT: "adsoda-main-page"\r
+++ /dev/null
-USING: adsoda\r
-kernel\r
-math\r
-accessors\r
-sequences\r
- adsoda.solution2\r
- fry\r
- tools.test \r
- arrays ;\r
-\r
-IN: adsoda.tests\r
-\r
-\r
-\r
-: s1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "s1" >>name\r
- { 1 1 1 } >>color\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
-;\r
-: solid1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid1" >>name\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-: solid2 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid2" >>name\r
- { -1 1 -10 } cut-solid \r
- { -1 -1 -28 } cut-solid \r
- { 1 0 13 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid3 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid3" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 16 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-\r
-;\r
-\r
-: solid4 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid4" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 21 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid5 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid5" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 6 } cut-solid \r
- { -1 0 -17 } cut-solid \r
- { 0 1 17 } cut-solid \r
- { 0 -1 -19 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid7 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid7" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 38 } cut-solid \r
- { 1 -5 -66 } cut-solid \r
- { -2 1 -75 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid6s ( -- seq )\r
- solid3 clone solid2 clone subtract\r
-;\r
-\r
-: space1 ( -- space )\r
- <space>\r
- 2 >>dimension\r
- ! solid3 suffix-solids\r
- solid1 suffix-solids\r
- solid2 suffix-solids\r
- ! solid6s [ suffix-solids ] each \r
- solid4 suffix-solids\r
- ! solid5 suffix-solids\r
- solid7 suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-;\r
-\r
-: space2 ( -- space )\r
- <space>\r
- 4 >>dimension\r
- ! 4cube suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-\r
- ;\r
-\r
-\r
-\r
-! {\r
-! { 1 0 0 0 }\r
-! { 0 1 0 0 }\r
-! { 0 0 0.984807753012208 -0.1736481776669303 }\r
-! { 0 0 0.1736481776669303 0.984807753012208 }\r
-! }\r
-\r
-! ------------------------------------------------------------\r
-! constant+\r
-[ { 1 2 5 } ] [ { 1 2 3 } 2 constant+ ] unit-test\r
-\r
-! ------------------------------------------------------------\r
-! translate\r
-[ { 1 -1 0 } ] [ { 1 -1 -5 } { 3 -2 } translate ] unit-test\r
-\r
-! ------------------------------------------------------------\r
-! transform\r
-[ { -1 -1 -5 21.0 } ] [ { -1 -1 -5 21 }\r
- { { 1 0 0 }\r
- { 0 1 0 }\r
- { 0 0 1 }\r
- } transform \r
-] unit-test\r
-\r
-! ------------------------------------------------------------\r
-! compare-nleft-to-identity-matrix\r
-[ t ] [ \r
- { \r
- { 1 0 0 1232 } \r
- { 0 1 0 0 321 } \r
- { 0 0 1 0 } } \r
- 3 compare-nleft-to-identity-matrix \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 } { 0 1 0 } { 0 0 0 } } \r
- 3 compare-nleft-to-identity-matrix \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 2 0 0 } { 0 1 0 } { 0 0 1 } } \r
- 3 compare-nleft-to-identity-matrix \r
-] unit-test\r
-! ------------------------------------------------------------\r
-[ t ] [ \r
- { { 1 0 0 }\r
- { 0 1 0 }\r
- { 0 0 1 } } 3 valid-solution? \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 1 }\r
- { 0 0 0 1 }\r
- { 0 0 1 0 } } 3 valid-solution? \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 1 }\r
- { 0 0 0 1 } } 3 valid-solution? \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 1 }\r
- { 0 0 0 1 }\r
- { 0 0 1 0 } } 2 valid-solution? \r
-] unit-test\r
-\r
-! ------------------------------------------------------------\r
-[ 3 ] [ { 1 2 3 } last ] unit-test \r
-\r
-[ { 1 2 5 } ] [ { 1 2 3 } dup [ 2 + ] change-last ] unit-test \r
-\r
-! ------------------------------------------------------------\r
-! position-point \r
-[ 0 ] [ \r
- { 1 -1 -5 } { 2 7 } position-point \r
-] unit-test\r
-\r
-! ------------------------------------------------------------\r
-\r
-! transform\r
-! TODO construire un exemple\r
-\r
-\r
-! ------------------------------------------------------------\r
-! slice-solid \r
-\r
-! ------------------------------------------------------------\r
-! solve-equation \r
-! deux cas de tests, avec solution et sans solution\r
-\r
-[ { 2 7 } ] \r
-[ { { 1 -1 -5 } { 1 2 16 } } intersect-hyperplanes ] \r
-unit-test\r
-\r
-[ f ] \r
-[ { { 1 -1 -5 } { 1 2 16 } { -1 -1 -21 } } intersect-hyperplanes ]\r
-unit-test\r
-\r
-[ f ] \r
-[ { { 1 0 -5 } { 1 0 16 } } intersect-hyperplanes ]\r
-unit-test\r
-\r
-! ------------------------------------------------------------\r
-! point-inside-halfspace\r
-[ t ] [ { 1 -1 -5 } { 0 0 } point-inside-halfspace? ] \r
-unit-test\r
-[ f ] [ { 1 -1 -5 } { 8 13 } point-inside-halfspace? ] \r
-unit-test\r
-[ t ] [ { 1 -1 -5 } { 8 13 } point-inside-or-on-halfspace? ] \r
-unit-test\r
-\r
-\r
-! ------------------------------\r
-! order solid\r
-\r
-[ 1 ] [ 0 >pv solid1 solid2 order-solid ] unit-test\r
-[ -1 ] [ 0 >pv solid2 solid1 order-solid ] unit-test\r
-[ f ] [ 1 >pv solid1 solid2 order-solid ] unit-test\r
-[ f ] [ 1 >pv solid2 solid1 order-solid ] unit-test\r
-\r
-\r
-! clip-solid\r
-[ { { 13 15 } { 15 13 } { 13 13 } } ]\r
- [ 0 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
-\r
-solid1 corners>> '[ _ ]\r
- [ 0 >pv solid1 solid1 clip-solid first corners>> ] unit-test\r
-\r
-solid1 corners>> '[ _ ]\r
- [ 0 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
-\r
-solid1 corners>> '[ _ ]\r
- [ 1 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
-solid2 corners>> '[ _ ]\r
- [ 1 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
-\r
-!\r
-[\r
- {\r
- { { 13 15 } { 15 13 } { 13 13 } }\r
- { { 16 17 } { 16 13 } { 36 17 } { 36 13 } }\r
- { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
- }\r
-] [ 0 >pv solid2 solid3 2array \r
- solid1 (solids-silhouette-subtract) \r
- [ corners>> ] map\r
- ] unit-test\r
-\r
-\r
-[\r
-{\r
- { { 8 13 } { 2 7 } { 12 9 } { 12 2 } }\r
- { { 13 15 } { 15 13 } { 13 13 } }\r
- { { 16 17 } { 16 15 } { 36 17 } { 36 15 } }\r
- { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
-}\r
-] [ \r
- 0 >pv <space> solid1 suffix-solids \r
- solid2 suffix-solids \r
- solid3 suffix-solids\r
- remove-hidden-solids\r
- solids>> [ corners>> ] map\r
-] unit-test\r
-\r
-! { }\r
-! { }\r
-! <light> { 0.2 0.3 0.4 } >>color { 1 -1 1 } >>direction suffix\r
-! <light> { 0.4 0.3 0.1 } >>color { -1 -1 -1 } >>direction suffix\r
-! suffix \r
-! { 0.1 0.1 0.1 } suffix ! ambient color\r
-! { 0.23 0.32 0.17 } suffix ! solid color\r
-! solid3 faces>> first \r
-\r
-! enlight-projection\r
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors\r
-arrays \r
-assocs\r
-combinators\r
-kernel \r
-fry\r
-math \r
-math.constants\r
-math.functions\r
-math.libm\r
-math.order\r
-math.vectors \r
-math.matrices \r
-math.parser\r
-namespaces\r
-prettyprint\r
-sequences\r
-sequences.deep\r
-sets\r
-slots\r
-sorting\r
-tools.time\r
-vars\r
-continuations\r
-words\r
-opengl\r
-opengl.gl\r
-colors\r
-adsoda.solution2\r
-adsoda.combinators\r
-opengl.demo-support\r
-values\r
-tools.walker\r
-;\r
-\r
-IN: adsoda\r
-\r
-DEFER: combinations\r
-VAR: pv\r
-\r
-\r
-! ---------------------------------------------------------------------\r
-! global values\r
-VALUE: remove-hidden-solids?\r
-VALUE: VERY-SMALL-NUM\r
-VALUE: ZERO-VALUE\r
-VALUE: MAX-FACE-PER-CORNER\r
-\r
-t to: remove-hidden-solids?\r
-0.0000001 to: VERY-SMALL-NUM\r
-0.0000001 to: ZERO-VALUE\r
-4 to: MAX-FACE-PER-CORNER\r
-! ---------------------------------------------------------------------\r
-! sequence complement\r
-\r
-: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
-\r
-: dimension ( array -- x ) length 1- ; inline \r
-: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline\r
-: change-last ( seq quot -- ) [ [ dimension ] keep ] dip change-nth ; \r
-\r
-! --------------------------------------------------------------\r
-! light\r
-! --------------------------------------------------------------\r
-\r
-TUPLE: light name { direction array } color ;\r
-: <light> ( -- tuple ) light new ;\r
-\r
-! -----------------------------------------------------------------------\r
-! halfspace manipulation\r
-! -----------------------------------------------------------------------\r
-\r
-: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;\r
-: translate ( u v -- w ) dupd v* sum constant+ ; \r
-\r
-: transform ( u matrix -- w )\r
- [ swap m.v ] 2keep ! compute new normal vector \r
- [\r
- [ [ abs ZERO-VALUE > ] find ] keep ! find a point on the frontier\r
- ! be sure it's not null vector\r
- last ! get constant\r
- swap /f neg swap ! intercept value\r
- ] dip \r
- flip \r
- nth\r
- [ * ] with map ! apply intercep value\r
- over v*\r
- sum neg\r
- suffix ! add value as constant at the end of equation\r
-;\r
-\r
-: position-point ( halfspace v -- x ) \r
- -1 suffix v* sum ; inline\r
-: point-inside-halfspace? ( halfspace v -- ? ) \r
- position-point VERY-SMALL-NUM > ; \r
-: point-inside-or-on-halfspace? ( halfspace v -- ? ) \r
- position-point VERY-SMALL-NUM neg > ;\r
-: project-vector ( seq -- seq ) pv> [ head ] [ 1+ tail ] 2bi append ; \r
-: get-intersection ( matrice -- seq ) [ 1 tail* ] map flip first ;\r
-\r
-: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;\r
-\r
-: compare-nleft-to-identity-matrix ( seq n -- ? ) \r
- [ [ head ] curry map ] keep identity-matrix m- \r
- flatten\r
- [ abs ZERO-VALUE < ] all?\r
-;\r
-\r
-: valid-solution? ( matrice n -- ? )\r
- islenght=?\r
- [ compare-nleft-to-identity-matrix ] \r
- [ 2drop f ] if ; inline\r
-\r
-: intersect-hyperplanes ( matrice -- seq )\r
- [ solution dup ] [ first dimension ] bi\r
- valid-solution? [ get-intersection ] [ drop f ] if ;\r
-\r
-! --------------------------------------------------------------\r
-! faces\r
-! --------------------------------------------------------------\r
-\r
-TUPLE: face { halfspace array } touching-corners adjacent-faces ;\r
-: <face> ( v -- tuple ) face new swap >>halfspace ;\r
-: flip-face ( face -- face ) [ vneg ] change-halfspace ;\r
-: erase-face-touching-corners ( face -- face ) f >>touching-corners ;\r
-: erase-face-adjacent-faces ( face -- face ) f >>adjacent-faces ;\r
-: faces-intersection ( faces -- v ) \r
- [ halfspace>> ] map intersect-hyperplanes ;\r
-: face-translate ( face v -- face ) \r
- [ translate ] curry change-halfspace ; inline\r
-: face-transform ( face m -- face )\r
- [ transform ] curry change-halfspace ; inline\r
-: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;\r
-: backface? ( face -- face ? ) dup face-orientation 0 <= ;\r
-: pv-factor ( face -- f face ) \r
- halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline\r
-: suffix-touching-corner ( face corner -- face ) \r
- [ suffix ] curry change-touching-corners ; inline\r
-: real-face? ( face -- ? )\r
- [ touching-corners>> length ] [ halfspace>> dimension ] bi >= ;\r
-\r
-: (add-to-adjacent-faces) ( face face -- face )\r
- over adjacent-faces>> 2dup member?\r
- [ 2drop ] [ swap suffix >>adjacent-faces ] if ;\r
-\r
-: add-to-adjacent-faces ( face face -- face )\r
- 2dup = [ drop ] [ (add-to-adjacent-faces) ] if ;\r
-\r
-: update-adjacent-faces ( faces corner -- )\r
- '[ [ _ suffix-touching-corner drop ] each ] keep \r
- 2 among [ \r
- [ first ] keep second \r
- [ add-to-adjacent-faces drop ] 2keep \r
- swap add-to-adjacent-faces drop \r
- ] each ; inline\r
-\r
-: face-project-dim ( face -- x ) halfspace>> length 2 - ;\r
-\r
-: apply-light ( color light normal -- u )\r
- over direction>> v. \r
- neg dup 0 > \r
- [ \r
- [ color>> swap ] dip \r
- [ * ] curry map v+ \r
- [ 1 min ] map \r
- ] \r
- [ 2drop ] \r
- if\r
-;\r
-\r
-: enlight-projection ( array face -- color )\r
- ! array = lights + ambient color\r
- [ [ third ] [ second ] [ first ] tri ]\r
- [ halfspace>> project-vector normalize ] bi*\r
- [ apply-light ] curry each\r
- v*\r
-;\r
-\r
-: (intersection-into-face) ( face-init face-adja quot -- face )\r
- [\r
- [ [ pv-factor ] bi@ \r
- roll \r
- [ map ] 2bi@\r
- v-\r
- ] 2keep\r
- [ touching-corners>> ] bi@\r
- [ swap [ = ] curry find nip f = ] curry find nip\r
- ] dip over\r
- [\r
- call\r
- dupd\r
- point-inside-halfspace? [ vneg ] unless \r
- <face> \r
- ] [ 3drop f ] if \r
- ; inline\r
-\r
-: intersection-into-face ( face-init face-adja -- face )\r
- [ [ project-vector ] bi@ ] (intersection-into-face) ;\r
-\r
-: intersection-into-silhouette-face ( face-init face-adja -- face )\r
- [ ] (intersection-into-face) ;\r
-\r
-: intersections-into-faces ( face -- faces )\r
- clone dup adjacent-faces>> [ intersection-into-face ] with map \r
- [ ] filter ;\r
-\r
-: (face-silhouette) ( face -- faces )\r
- clone dup adjacent-faces>>\r
- [ backface?\r
- [ intersection-into-silhouette-face ] [ 2drop f ] if \r
- ] with map \r
- [ ] filter\r
-; inline\r
-\r
-: face-silhouette ( face -- faces ) \r
- backface? [ drop f ] [ (face-silhouette) ] if ;\r
-\r
-! --------------------------------\r
-! solid\r
-! --------------------------------------------------------------\r
-TUPLE: solid dimension silhouettes faces corners adjacencies-valid color name ;\r
-\r
-: <solid> ( -- tuple ) solid new ;\r
-\r
-: suffix-silhouettes ( solid silhouette -- solid ) \r
- [ suffix ] curry change-silhouettes ;\r
-\r
-: suffix-face ( solid face -- solid ) [ suffix ] curry change-faces ;\r
-\r
-: suffix-corner ( solid corner -- solid ) [ suffix ] curry change-corners ; \r
-\r
-: erase-solid-corners ( solid -- solid ) f >>corners ;\r
-\r
-: erase-silhouettes ( solid -- solid ) dup dimension>> f <array> >>silhouettes ;\r
-\r
-: filter-real-faces ( solid -- solid ) [ [ real-face? ] filter ] change-faces ;\r
-\r
-: initiate-solid-from-face ( face -- solid ) \r
- face-project-dim <solid> swap >>dimension ;\r
-\r
-: erase-old-adjacencies ( solid -- solid )\r
- erase-solid-corners\r
- [ dup [ erase-face-touching-corners erase-face-adjacent-faces drop ] each ]\r
- change-faces ;\r
-\r
-: point-inside-or-on-face? ( face v -- ? ) \r
- [ halfspace>> ] dip point-inside-or-on-halfspace? ;\r
-\r
-: point-inside-face? ( face v -- ? ) \r
- [ halfspace>> ] dip point-inside-halfspace? ;\r
-\r
-: point-inside-solid? ( solid point -- ? )\r
- [ faces>> ] dip [ point-inside-face? ] curry all? ; inline\r
-\r
-: point-inside-or-on-solid? ( solid point -- ? )\r
- [ faces>> ] dip [ point-inside-or-on-face? ] curry all? ; inline\r
-\r
-: unvalid-adjacencies ( solid -- solid ) \r
- erase-old-adjacencies f >>adjacencies-valid erase-silhouettes ;\r
-\r
-: add-face ( solid face -- solid ) \r
- suffix-face unvalid-adjacencies ; \r
-\r
-: cut-solid ( solid halfspace -- solid ) <face> add-face ; \r
-\r
-: slice-solid ( solid face -- solid1 solid2 )\r
- [ [ clone ] bi@ flip-face add-face \r
- [ "/outer/" append ] change-name ] 2keep\r
- add-face [ "/inner/" append ] change-name ;\r
-\r
-! -------------\r
-\r
-\r
-: add-silhouette ( solid -- solid )\r
- dup \r
- ! find-adjacencies \r
- faces>> { } \r
- [ face-silhouette append ] reduce\r
- [ ] filter \r
- <solid> \r
- swap >>faces\r
- over dimension>> >>dimension \r
- over name>> " silhouette " append \r
- pv> number>string append \r
- >>name\r
- ! ensure-adjacencies\r
- suffix-silhouettes ; inline\r
-\r
-: find-silhouettes ( solid -- solid )\r
- { } >>silhouettes \r
- dup dimension>> [ [ add-silhouette ] with-pv ] each ;\r
-\r
-: ensure-silhouettes ( solid -- solid )\r
- dup silhouettes>> [ f = ] all?\r
- [ find-silhouettes ] when ; \r
-\r
-! ------------\r
-\r
-: corner-added? ( solid corner -- ? ) \r
- ! add corner to solid if it is inside solid\r
- [ ] \r
- [ point-inside-or-on-solid? ] \r
- [ swap corners>> member? not ] \r
- 2tri and\r
- [ suffix-corner drop t ] [ 2drop f ] if ;\r
-\r
-: process-corner ( solid faces corner -- )\r
- swapd \r
- [ corner-added? ] keep swap ! test if corner is inside solid\r
- [ update-adjacent-faces ] \r
- [ 2drop ]\r
- if ;\r
-\r
-: compute-intersection ( solid faces -- )\r
- dup faces-intersection\r
- dup f = [ 3drop ] [ process-corner ] if ;\r
-\r
-: test-faces-combinaisons ( solid n -- )\r
- [ dup faces>> ] dip among \r
- [ compute-intersection ] with each ;\r
-\r
-: compute-adjacencies ( solid -- solid )\r
- dup dimension>> [ >= ] curry \r
- [ keep swap ] curry MAX-FACE-PER-CORNER swap\r
- [ [ test-faces-combinaisons ] 2keep 1- ] [ ] while drop ;\r
-\r
-: find-adjacencies ( solid -- solid ) \r
- erase-old-adjacencies \r
- compute-adjacencies\r
- filter-real-faces \r
- t >>adjacencies-valid ;\r
-\r
-: ensure-adjacencies ( solid -- solid ) \r
- dup adjacencies-valid>> \r
- [ find-adjacencies ] unless \r
- ensure-silhouettes\r
- ;\r
-\r
-: (non-empty-solid?) ( solid -- ? ) [ dimension>> ] [ corners>> length ] bi < ;\r
-: non-empty-solid? ( solid -- ? ) ensure-adjacencies (non-empty-solid?) ;\r
-\r
-: compare-corners-roughly ( corner corner -- ? )\r
- 2drop t ;\r
-! : remove-inner-faces ( -- ) ;\r
-: face-project ( array face -- seq )\r
- backface? \r
- [ 2drop f ]\r
- [ [ enlight-projection ] \r
- [ initiate-solid-from-face ]\r
- [ intersections-into-faces ] tri\r
- >>faces\r
- swap >>color \r
- ] if ;\r
-\r
-: solid-project ( lights ambient solid -- solids )\r
- ensure-adjacencies\r
- [ color>> ] [ faces>> ] bi [ 3array ] dip\r
- [ face-project ] with map \r
- [ ] filter \r
- [ ensure-adjacencies ] map\r
-;\r
-\r
-: (solid-move) ( solid v move -- solid ) \r
- curry [ map ] curry \r
- [ dup faces>> ] dip call drop \r
- unvalid-adjacencies ; inline\r
-\r
-: solid-translate ( solid v -- solid ) [ face-translate ] (solid-move) ; \r
-: solid-transform ( solid m -- solid ) [ face-transform ] (solid-move) ; \r
-\r
-: find-corner-in-silhouette ( s1 s2 -- elt bool )\r
- pv> swap silhouettes>> nth \r
- swap corners>>\r
- [ point-inside-solid? ] with find swap ;\r
-\r
-: valid-face-for-order ( solid point -- face )\r
- [ point-inside-face? not ] \r
- [ drop face-orientation 0 = not ] 2bi and ;\r
-\r
-: check-orientation ( s1 s2 pt -- int )\r
- [ nip faces>> ] dip\r
- [ valid-face-for-order ] curry find swap\r
- [ face-orientation ] [ drop f ] if ;\r
-\r
-: (order-solid) ( s1 s2 -- int )\r
- 2dup find-corner-in-silhouette\r
- [ check-orientation ] [ 3drop f ] if ;\r
-\r
-: order-solid ( solid solid -- i ) \r
- 2dup (order-solid)\r
- [ 2nip ]\r
- [ swap (order-solid)\r
- [ neg ] [ f ] if*\r
- ] if* ;\r
-\r
-: subtract ( solid1 solid2 -- solids )\r
- faces>> swap clone ensure-adjacencies ensure-silhouettes \r
- [ swap slice-solid drop ] curry map\r
- [ non-empty-solid? ] filter\r
- [ ensure-adjacencies ] map\r
-; inline\r
-\r
-! --------------------------------------------------------------\r
-! space \r
-! --------------------------------------------------------------\r
-TUPLE: space name dimension solids ambient-color lights ;\r
-: <space> ( -- space ) space new ;\r
-: suffix-solids ( space solid -- space ) [ suffix ] curry change-solids ; inline\r
-: suffix-lights ( space light -- space ) [ suffix ] curry change-lights ; inline\r
-: clear-space-solids ( space -- space ) f >>solids ;\r
-\r
-: space-ensure-solids ( space -- space ) \r
- [ [ ensure-adjacencies ] map ] change-solids ;\r
-: eliminate-empty-solids ( space -- space ) \r
- [ [ non-empty-solid? ] filter ] change-solids ;\r
-\r
-: projected-space ( space solids -- space ) \r
- swap dimension>> 1- <space> swap >>dimension swap >>solids ;\r
-\r
-: get-silhouette ( solid -- silhouette ) silhouettes>> pv> swap nth ;\r
-: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;\r
-\r
-: space-apply ( space m quot -- space ) \r
- curry [ map ] curry [ dup solids>> ] dip\r
- [ call ] [ drop ] recover drop ;\r
-: space-transform ( space m -- space ) [ solid-transform ] space-apply ;\r
-: space-translate ( space v -- space ) [ solid-translate ] space-apply ; \r
-\r
-: describe-space ( space -- ) \r
- solids>> [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;\r
-\r
-: clip-solid ( solid solid -- solids )\r
- [ ]\r
- [ solid= not ]\r
- [ order-solid -1 = ] 2tri \r
- and\r
- [ get-silhouette subtract ] \r
- [ drop 1array ] \r
- if \r
- \r
- ;\r
-\r
-: (solids-silhouette-subtract) ( solids solid -- solids ) \r
- [ clip-solid append ] curry { } -rot each ; inline\r
-\r
-: solids-silhouette-subtract ( solids i solid -- solids )\r
-! solids is an array of 1 solid arrays\r
- [ (solids-silhouette-subtract) ] curry map-but \r
-; inline \r
-\r
-: remove-hidden-solids ( space -- space ) \r
-! We must include each solid in a sequence because during substration \r
-! a solid can be divided in more than on solid\r
- [ \r
- [ [ 1array ] map ] \r
- [ length ] \r
- [ ] \r
- tri \r
- [ solids-silhouette-subtract ] 2each\r
- { } [ append ] reduce \r
- ] change-solids\r
- eliminate-empty-solids ! TODO include into change-solids\r
-;\r
-\r
-: space-project ( space i -- space )\r
- [\r
- [ clone \r
- remove-hidden-solids? [ remove-hidden-solids ] when\r
- dup \r
- [ solids>> ] \r
- [ lights>> ] \r
- [ ambient-color>> ] tri \r
- [ rot solid-project ] 2curry \r
- map \r
- [ append ] { } -rot each \r
- ! TODO project lights\r
- projected-space \r
- ! remove-inner-faces \r
- ! \r
- eliminate-empty-solids\r
- ] with-pv \r
- ] [ 3drop <space> ] recover\r
- ; inline\r
-\r
-: middle-of-space ( space -- point )\r
- solids>> [ corners>> ] map concat\r
- [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n\r
-;\r
-\r
-! --------------------------------------------------------------\r
-! 3D rendering\r
-! --------------------------------------------------------------\r
-\r
-: face-reference ( face -- halfspace point vect )\r
- [ halfspace>> ] \r
- [ touching-corners>> first ] \r
- [ touching-corners>> second ] tri \r
- over v-\r
-;\r
-\r
-: theta ( v halfspace point vect -- v x )\r
- [ [ over ] dip v- ] dip \r
- [ cross dup norm >float ]\r
- [ v. >float ] \r
- 2bi \r
- fatan2\r
- -rot v. \r
- 0 < [ neg ] when\r
-;\r
-\r
-: ordered-face-points ( face -- corners ) \r
- [ touching-corners>> 1 head ] \r
- [ touching-corners>> 1 tail ] \r
- [ face-reference [ theta ] 3curry ] tri\r
- { } map>assoc sort-values keys \r
- append\r
- ; inline\r
-\r
-: point->GL ( point -- ) gl-vertex ;\r
-: points->GL ( array -- ) do-cycle [ point->GL ] each ;\r
-\r
-: face->GL ( face color -- )\r
- [ ordered-face-points ] dip\r
- [ first3 1.0 glColor4d GL_POLYGON [ [ point->GL ] each ] do-state ] curry\r
- [ 0 0 0 1 glColor4d GL_LINE_LOOP [ [ point->GL ] each ] do-state ]\r
- bi\r
- ; inline\r
-\r
-: solid->GL ( solid -- ) \r
- [ faces>> ] \r
- [ color>> ] bi\r
- [ face->GL ] curry each ; inline\r
-\r
-: space->GL ( space -- )\r
- solids>>\r
- [ solid->GL ] each ;\r
-\r
-\r
-\r
-\r
-\r
+++ /dev/null
-! : init-4D-demo ( -- space )\r
-! OK\r
-! espace de dimension 4 et de couleur 0,3 0.3 0.3\r
-<space> \r
- 4 >>dimension\r
- { 0.3 0.3 0.3 } >>ambient-color\r
- { 100 150 100 150 100 150 100 150 } "4cube1" 4cube suffix-solids\r
- { 160 180 160 180 160 180 160 180 } "4cube2" 4cube suffix-solids\r
- <light>\r
- { -100 -100 -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-! ;\r
-! : init-3D-demo ( -- space )\r
-! OK\r
-! espace de dimension 4 et de couleur 0,3 0.3 0.3\r
-<space> \r
- 3 >>dimension\r
- { 0.3 0.3 0.3 } >>ambient-color\r
- { 100 150 100 150 100 150 } "3cube1" 3cube suffix-solids\r
- ! { -150 -10 -150 -10 -150 -10 -150 -10 } "4cube2" 4cube suffix-solids\r
- <light>\r
- { -100 -100 -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-! ;\r
-\r
-\r
-: s1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "s1" >>name\r
- { 1 1 1 } >>color\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
-;\r
-: solid1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid1" >>name\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-: solid2 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid2" >>name\r
- { -1 1 -10 } cut-solid \r
- { -1 -1 -28 } cut-solid \r
- { 1 0 13 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid3 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid3" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 16 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-\r
-;\r
-\r
-: solid4 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid4" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 21 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid5 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid5" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 6 } cut-solid \r
- { -1 0 -17 } cut-solid \r
- { 0 1 17 } cut-solid \r
- { 0 -1 -19 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid7 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid7" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 38 } cut-solid \r
- { 1 -5 -66 } cut-solid \r
- { -2 1 -75 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid6s ( -- seq )\r
- solid3 clone solid2 clone subtract\r
-;\r
-\r
-: space1 ( -- space )\r
- <space>\r
- 2 >>dimension\r
- ! solid3 suffix-solids\r
- solid1 suffix-solids\r
- solid2 suffix-solids\r
- ! solid6s [ suffix-solids ] each \r
- solid4 suffix-solids\r
- ! solid5 suffix-solids\r
- solid7 suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-;\r
-\r
-: space2 ( -- space )\r
- <space>\r
- 4 >>dimension\r
- ! 4cube suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-\r
- ;\r
-\r
+++ /dev/null
-Jeff Bigot\r
-Greg Ferrar
\ No newline at end of file
+++ /dev/null
-JF Bigot, after Greg Ferrar
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Your name.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays help.markup help.syntax kernel sequences ;
-IN: adsoda.combinators
-
-HELP: among
-{ $values
- { "array" array } { "n" null }
- { "array" array }
-}
-{ $description "returns an array containings every possibilities of n choices among a given sequence" } ;
-
-HELP: columnize
-{ $values
- { "array" array }
- { "array" array }
-}
-{ $description "flip a sequence into a sequence of 1 element sequences" } ;
-
-HELP: concat-nth
-{ $values
- { "seq1" sequence } { "seq2" sequence }
- { "seq" sequence }
-}
-{ $description "merges 2 sequences of sequences appending corresponding elements" } ;
-
-HELP: do-cycle
-{ $values
- { "array" array }
- { "array" array }
-}
-{ $description "Copy the first element at the end of the sequence in order to close the cycle." } ;
-
-
-ARTICLE: "adsoda.combinators" "adsoda.combinators"
-{ $vocab-link "adsoda.combinators" }
-;
-
-ABOUT: "adsoda.combinators"
+++ /dev/null
-USING: adsoda.combinators\r
-sequences\r
- tools.test \r
- ;\r
-\r
-IN: adsoda.combinators.tests\r
-\r
-\r
-[ { "atoto" "b" "ctoto" } ] [ { "a" "b" "c" } 1 [ "toto" append ] map-but ] \r
- unit-test\r
-\r
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel arrays sequences fry math combinators ;\r
-\r
-IN: adsoda.combinators\r
-\r
-! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ; \r
-\r
-! : prefix-each [ prefix ] curry map ; inline\r
-\r
-! : combinations ( seq n -- seqs )\r
-! {\r
-! { [ dup 0 = ] [ 2drop { { } } ] }\r
-! { [ over empty? ] [ 2drop { } ] }\r
-! { [ t ] [ \r
-! [ [ 1- (combinations) ] [ drop first ] 2bi prefix-each ]\r
-! [ (combinations) ] 2bi append\r
-! ] }\r
-! } cond ;\r
-\r
-: columnize ( array -- array ) [ 1array ] map ; inline\r
-\r
-: among ( array n -- array )\r
- 2dup swap length \r
- {\r
- { [ over 1 = ] [ 3drop columnize ] }\r
- { [ over 0 = ] [ 2drop 2drop { } ] }\r
- { [ 2dup < ] [ 2drop [ 1 cut ] dip \r
- [ 1- among [ append ] with map ] \r
- [ among append ] 2bi\r
- ] }\r
- { [ 2dup = ] [ 3drop 1array ] }\r
- { [ 2dup > ] [ 2drop 2drop { } ] } \r
- } cond\r
-;\r
-\r
-: concat-nth ( seq1 seq2 -- seq ) [ nth append ] curry map-index ;\r
-\r
-: do-cycle ( array -- array ) dup first suffix ;\r
-\r
-: map-but ( seq i quot -- seq )\r
- ! quot : ( seq x -- seq )\r
- '[ _ = [ @ ] unless ] map-index ; inline\r
-\r
+++ /dev/null
-USING: kernel\r
-sequences\r
-namespaces\r
-\r
-math\r
-math.vectors\r
-math.matrices\r
-;\r
-IN: adsoda.solution2\r
-\r
-! -------------------\r
-! correctif solution\r
-! ---------------\r
-SYMBOL: matrix\r
-: MIN-VAL-adsoda ( -- x ) 0.00000001\r
-! 0.000000000001 \r
-;\r
-\r
-: zero? ( x -- ? ) \r
- abs MIN-VAL-adsoda <\r
-;\r
-\r
-! [ number>string string>number ] map \r
-\r
-: with-matrix ( matrix quot -- )\r
- [ swap matrix set call matrix get ] with-scope ; inline\r
-\r
-: nth-row ( row# -- seq ) matrix get nth ;\r
-\r
-: change-row ( row# quot -- seq ) ! row# quot -- | quot: seq -- seq )\r
- matrix get swap change-nth ; inline\r
-\r
-: exchange-rows ( row# row# -- ) matrix get exchange ;\r
-\r
-: rows ( -- n ) matrix get length ;\r
-\r
-: cols ( -- n ) 0 nth-row length ;\r
-\r
-: skip ( i seq quot -- n )\r
- over [ find-from drop ] dip length or ; inline\r
-\r
-: first-col ( row# -- n )\r
- #! First non-zero column\r
- 0 swap nth-row [ zero? not ] skip ;\r
-\r
-: clear-scale ( col# pivot-row i-row -- n )\r
- [ over ] dip nth dup zero? [\r
- 3drop 0\r
- ] [\r
- [ nth dup zero? ] dip swap [\r
- 2drop 0\r
- ] [\r
- swap / neg\r
- ] if\r
- ] if ;\r
-\r
-: (clear-col) ( col# pivot-row i -- )\r
- [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;\r
-\r
-: rows-from ( row# -- slice )\r
- rows dup <slice> ;\r
-\r
-: clear-col ( col# row# rows -- )\r
- [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;\r
-\r
-: do-row ( exchange-with row# -- )\r
- [ exchange-rows ] keep\r
- [ first-col ] keep\r
- dup 1+ rows-from clear-col ;\r
-\r
-: find-row ( row# quot -- i elt )\r
- [ rows-from ] dip find ; inline\r
-\r
-: pivot-row ( col# row# -- n )\r
- [ dupd nth-row nth zero? not ] find-row 2nip ;\r
-\r
-: (echelon) ( col# row# -- )\r
- over cols < over rows < and [\r
- 2dup pivot-row [ over do-row 1+ ] when*\r
- [ 1+ ] dip (echelon)\r
- ] [\r
- 2drop\r
- ] if ;\r
-\r
-: echelon ( matrix -- matrix' )\r
- [ 0 0 (echelon) ] with-matrix ;\r
-\r
-: nonzero-rows ( matrix -- matrix' )\r
- [ [ zero? ] all? not ] filter ;\r
-\r
-: null/rank ( matrix -- null rank )\r
- echelon dup length swap nonzero-rows length [ - ] keep ;\r
-\r
-: leading ( seq -- n elt ) [ zero? not ] find ;\r
-\r
-: reduced ( matrix' -- matrix'' )\r
- [\r
- rows <reversed> [\r
- dup nth-row leading drop\r
- dup [ swap dup clear-col ] [ 2drop ] if\r
- ] each\r
- ] with-matrix ;\r
-\r
-: basis-vector ( row col# -- )\r
- [ clone ] dip\r
- [ swap nth neg recip ] 2keep\r
- [ 0 spin set-nth ] 2keep\r
- [ n*v ] dip\r
- matrix get set-nth ;\r
-\r
-: nullspace ( matrix -- seq )\r
- echelon reduced dup empty? [\r
- dup first length identity-matrix [\r
- [\r
- dup leading drop\r
- dup [ basis-vector ] [ 2drop ] if\r
- ] each\r
- ] with-matrix flip nonzero-rows\r
- ] unless ;\r
-\r
-: 1-pivots ( matrix -- matrix )\r
- [ dup leading nip [ recip v*n ] when* ] map ;\r
-\r
-: solution ( matrix -- matrix )\r
- echelon nonzero-rows reduced 1-pivots ;\r
-\r
+++ /dev/null
-A modification of solution to approximate solutions
\ No newline at end of file
+++ /dev/null
-ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm
\ No newline at end of file
+++ /dev/null
-adsoda 4D viewer
\ No newline at end of file
+++ /dev/null
-Jeff Bigot
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays help.markup help.syntax kernel sequences ;
-IN: adsoda.tools
-
-HELP: 3cube
-{ $values
- { "array" "array" } { "name" "name" }
- { "solid" "solid" }
-}
-{ $description "array : xmin xmax ymin ymax zmin zmax"
-"\n returns a 3D solid with given limits"
-} ;
-
-HELP: 4cube
-{ $values
- { "array" "array" } { "name" "name" }
- { "solid" "solid" }
-}
-{ $description "array : xmin xmax ymin ymax zmin zmax wmin wmax"
-"\n returns a 4D solid with given limits"
-} ;
-
-
-HELP: coord-max
-{ $values
- { "x" null } { "array" array }
- { "array" array }
-}
-{ $description "" } ;
-
-HELP: coord-min
-{ $values
- { "x" null } { "array" array }
- { "array" array }
-}
-{ $description "" } ;
-
-HELP: equation-system-for-normal
-{ $values
- { "points" "a list of n points" }
- { "matrix" "matrix" }
-}
-{ $description "From a list of points, return the matrix"
-"to solve in order to find the vector normal to the plan defined by the points" }
-;
-
-HELP: normal-vector
-{ $values
- { "points" "a list of n points" }
- { "v" "a vector" }
-}
-{ $description "From a list of points, returns the vector normal to the plan defined by the points"
-"\nWith n points, creates n-1 vectors and then find a vector orthogonal to every others"
-"\n returns { f } if a normal vector can not be found" }
-;
-
-HELP: points-to-hyperplane
-{ $values
- { "points" "a list of n points" }
- { "hyperplane" "an hyperplane equation" }
-}
-{ $description "From a list of points, returns the equation of the hyperplan"
-"\n Finds a normal vector and then translate it so that it includes one of the points"
-
-}
-;
-
-ARTICLE: "adsoda.tools" "adsoda.tools"
-{ $vocab-link "adsoda.tools" }
-"\nTools to help in building an " { $vocab-link "adsoda" } "-space"
-;
-
-ABOUT: "adsoda.tools"
-
-
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: \r
-adsoda.tools\r
-tools.test\r
-;\r
-\r
-IN: adsoda.tools.tests\r
-\r
-\r
- [ { 1 0 } ] [ { { 0 0 } { 0 1 } } normal-vector ] unit-test\r
- [ f ] [ { { 0 0 } { 0 0 } } normal-vector ] unit-test\r
-\r
- [ { 1/2 1/2 1+1/2 } ] [ { { 1 2 } { 2 1 } } points-to-hyperplane ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: \r
-kernel\r
-sequences\r
-math\r
-accessors\r
-adsoda\r
-math.vectors \r
-math.matrices\r
-bunny.model\r
-io.encodings.ascii\r
-io.files\r
-sequences.deep\r
-combinators\r
-adsoda.combinators\r
-fry\r
-io.files.temp\r
-grouping\r
-;\r
-\r
-IN: adsoda.tools\r
-\r
-\r
-\r
-\r
-\r
-! ---------------------------------\r
-: coord-min ( x array -- array ) swap suffix ;\r
-: coord-max ( x array -- array ) swap neg suffix ;\r
-\r
-: 4cube ( array name -- solid )\r
-! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
- <solid> \r
- 4 >>dimension\r
- swap >>name\r
- swap\r
- { \r
- [ { 1 0 0 0 } coord-min ] [ { -1 0 0 0 } coord-max ] \r
- [ { 0 1 0 0 } coord-min ] [ { 0 -1 0 0 } coord-max ]\r
- [ { 0 0 1 0 } coord-min ] [ { 0 0 -1 0 } coord-max ] \r
- [ { 0 0 0 1 } coord-min ] [ { 0 0 0 -1 } coord-max ]\r
- }\r
- [ curry call ] 2map \r
- [ cut-solid ] each \r
- ensure-adjacencies\r
- \r
-; inline\r
-\r
-: 3cube ( array name -- solid )\r
-! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
- <solid> \r
- 3 >>dimension\r
- swap >>name\r
- swap\r
- { \r
- [ { 1 0 0 } coord-min ] [ { -1 0 0 } coord-max ] \r
- [ { 0 1 0 } coord-min ] [ { 0 -1 0 } coord-max ]\r
- [ { 0 0 1 } coord-min ] [ { 0 0 -1 } coord-max ] \r
- }\r
- [ curry call ] 2map \r
- [ cut-solid ] each \r
- ensure-adjacencies\r
- \r
-; inline\r
-\r
-\r
-: equation-system-for-normal ( points -- matrix )\r
- unclip [ v- 0 suffix ] curry map\r
- dup first [ drop 1 ] map suffix\r
-;\r
-\r
-: normal-vector ( points -- v ) \r
- equation-system-for-normal\r
- intersect-hyperplanes ;\r
-\r
-: points-to-hyperplane ( points -- hyperplane )\r
- [ normal-vector 0 suffix ] [ first ] bi\r
- translate ;\r
-\r
-: refs-to-points ( points faces -- faces )\r
- [ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] with map\r
-;\r
-! V{ { 0.1 0.2 } { 1.1 1.3 } } V{ { 1 0 } { 0 1 } }\r
-! V{ { { 1.1 1.3 } { 0.1 0.2 } } { { 0.1 0.2 } { 1.1 1.3 } } }\r
-\r
-: ply-model-path ( -- path )\r
-\r
-! "bun_zipper.ply" \r
-"screw2.ply"\r
-temp-file \r
-;\r
-\r
-: read-bunny-model ( -- v )\r
-ply-model-path ascii [ parse-model ] with-file-reader\r
-\r
-refs-to-points\r
-;\r
-\r
-: 3points-to-normal ( seq -- v )\r
- unclip [ v- ] curry map first2 cross normalize\r
-;\r
-: 2-faces-to-prism ( seq seq -- seq )\r
- 2dup\r
- [ do-cycle 2 clump ] bi@ concat-nth ! 3 faces rectangulaires\r
- swap prefix\r
- swap prefix\r
-; \r
-\r
-: Xpoints-to-prisme ( seq height -- cube )\r
- ! from 3 points gives a list of faces representing a cube of height "height"\r
- ! and of based on the three points\r
- ! a face is a group of 3 or mode points. \r
- [ dup dup 3points-to-normal ] dip \r
- v*n [ v+ ] curry map ! 2 eme face triangulaire \r
- 2-faces-to-prism \r
-\r
-! [ dup number? [ 1 + ] when ] deep-map\r
-! dup keep \r
-;\r
-\r
-\r
-: Xpoints-to-plane4D ( seq x y -- 4Dplane )\r
- ! from 3 points gives a list of faces representing a cube in 4th dim\r
- ! from x to y (height = y-x)\r
- ! and of based on the X points\r
- ! a face is a group of 3 or mode points. \r
- '[ [ [ _ suffix ] map ] [ [ _ suffix ] map ] bi ] call\r
- 2-faces-to-prism\r
-;\r
-\r
-: 3pointsfaces-to-3Dsolidfaces ( seq -- seq )\r
- [ 1 Xpoints-to-prisme [ 100 110 Xpoints-to-plane4D ] map concat ] map \r
-\r
-;\r
-\r
-: test-figure ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
-;\r
-\r
+++ /dev/null
-
-USING: kernel quotations arrays sequences math math.ranges fry
- opengl opengl.gl ui.render ui.gadgets.cartesian processing.shapes
- accessors
- help.syntax
- easy-help ;
-
-IN: ui.gadgets.plot
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "ui.gadgets.plot" "Plot Gadget"
-
-Summary:
-
- A simple gadget for ploting two dimentional functions.
-
- Use the arrow keys to move around.
-
- Use 'a' and 'z' keys to zoom in and out. ..
-
-Example:
-
- <plot> [ sin ] add-function gadget. ..
-
-Example:
-
- <plot>
- [ sin ] red function boa add-function
- [ cos ] blue function boa add-function
- gadget. ..
-
-;
-
-ABOUT: "ui.gadgets.plot"
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: plot < cartesian functions points ;
-
-: init-plot ( plot -- plot )
- init-cartesian
- { } >>functions
- 100 >>points ;
-
-: <plot> ( -- plot ) plot new init-plot ;
-
-: step-size ( plot -- step-size )
- [ [ x-max>> ] [ x-min>> ] bi - ] [ points>> ] bi / ;
-
-: plot-range ( plot -- range )
- [ x-min>> ] [ x-max>> ] [ step-size ] tri <range> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: function function color ;
-
-GENERIC: plot-function ( plot object -- plot )
-
-M: callable plot-function ( plot quotation -- plot )
- [ dup plot-range ] dip '[ dup @ 2array ] map line-strip ;
-
-M: function plot-function ( plot function -- plot )
- dup color>> dup [ >stroke-color ] [ drop ] if
- [ dup plot-range ] dip function>> '[ dup @ 2array ] map line-strip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: plot-functions ( plot -- plot ) dup functions>> [ plot-function ] each ;
-
-: draw-axis ( plot -- plot )
- dup
- [ [ x-min>> ] [ drop 0 ] bi 2array ]
- [ [ x-max>> ] [ drop 0 ] bi 2array ] bi line*
- dup
- [ [ drop 0 ] [ y-min>> ] bi 2array ]
- [ [ drop 0 ] [ y-max>> ] bi 2array ] bi line* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: ui.gadgets.slate ;
-
-M: plot draw-slate ( plot -- plot )
- 2 glLineWidth
- draw-axis
- plot-functions
- fill-mode
- 1 glLineWidth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: add-function ( plot function -- plot )
- over functions>> swap suffix >>functions ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: x-span ( plot -- span ) [ x-max>> ] [ x-min>> ] bi - ;
-: y-span ( plot -- span ) [ y-max>> ] [ y-min>> ] bi - ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: ui.gestures ui.gadgets ;
-
-: left ( plot -- plot )
- dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
- dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max
- dup relayout-1 ;
-
-: right ( plot -- plot )
- dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
- dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max
- dup relayout-1 ;
-
-: down ( plot -- plot )
- dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
- dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max
- dup relayout-1 ;
-
-: up ( plot -- plot )
- dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
- dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max
- dup relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: zoom-in-horizontal ( plot -- plot )
- dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
- dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max ;
-
-: zoom-in-vertical ( plot -- plot )
- dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
- dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max ;
-
-: zoom-in ( plot -- plot )
- zoom-in-horizontal
- zoom-in-vertical
- dup relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: zoom-out-horizontal ( plot -- plot )
- dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
- dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max ;
-
-: zoom-out-vertical ( plot -- plot )
- dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
- dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max ;
-
-: zoom-out ( plot -- plot )
- zoom-out-horizontal
- zoom-out-vertical
- dup relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-plot
- H{
- { T{ mouse-enter } [ request-focus ] }
- { T{ key-down f f "LEFT" } [ left drop ] }
- { T{ key-down f f "RIGHT" } [ right drop ] }
- { T{ key-down f f "DOWN" } [ down drop ] }
- { T{ key-down f f "UP" } [ up drop ] }
- { T{ key-down f f "a" } [ zoom-in drop ] }
- { T{ key-down f f "z" } [ zoom-out drop ] }
- }
-set-gestures
\ No newline at end of file
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces opengl ui.render ui.gadgets accessors
- help.syntax
- easy-help ;
-
-IN: ui.gadgets.slate
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "slate" "Slate Gadget"
-
-Summary:
-
- A gadget with an 'action' slot which should be set to a callable. ..
-
-Example:
-
- ! Load the right vocabs for the examples
-
- USING: processing.shapes ui.gadgets.slate ; ..
-
-Example:
-
- [ { { 10 10 } { 50 30 } { 10 50 } } polygon fill-mode ] <slate>
- gadget. ..
-
-;
-
-ABOUT: "slate"
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: slate < gadget action pdim graft ungraft ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-slate ( slate -- slate )
- init-gadget
- [ ] >>action
- { 200 200 } >>pdim
- [ ] >>graft
- [ ] >>ungraft ;
-
-: <slate> ( action -- slate )
- slate new
- init-slate
- swap >>action ;
-
-M: slate pref-dim* ( slate -- dim ) pdim>> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: combinators arrays sequences math math.geometry
- opengl.gl ui.gadgets.worlds ;
-
-: screen-y* ( gadget -- loc )
- {
- [ find-world height ]
- [ screen-loc second ]
- [ height ]
- }
- cleave
- + - ;
-
-: screen-loc* ( gadget -- loc )
- {
- [ screen-loc first ]
- [ screen-y* ]
- }
- cleave
- 2array ;
-
-: setup-viewport ( gadget -- gadget )
- dup
- {
- [ screen-loc* ]
- [ dim>> ]
- }
- cleave
- gl-viewport ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: default-coordinate-system ( gadget -- gadget )
- dup
- {
- [ drop 0 ]
- [ width 1 - ]
- [ height 1 - ]
- [ drop 0 ]
- }
- cleave
- -1 1
- glOrtho ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate graft* ( slate -- ) graft>> call ;
-M: slate ungraft* ( slate -- ) ungraft>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: establish-coordinate-system ( gadget -- gadget )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate establish-coordinate-system ( slate -- slate )
- default-coordinate-system ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: draw-slate ( slate -- slate )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate draw-slate ( slate -- slate ) dup action>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate draw-gadget* ( slate -- )
-
- GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity
-
- establish-coordinate-system
-
- GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity
-
- setup-viewport
-
- draw-slate
-
- GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
- GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity
-
- dup
- find-world
- ! The world coordinate system is a little wacky:
- dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
- setup-viewport
- drop
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+++ /dev/null
-
-USING: kernel sequences math math.order
- ui.gadgets ui.gadgets.tracks ui.gestures accessors fry
- help.syntax
- easy-help ;
-
-IN: ui.gadgets.tiling
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "ui.gadgets.tiling" "Tiling Layout Gadgets"
-
-Summary:
-
- A gadget which tiles it's children.
-
- A tiling gadget may contain any number of children, but only a
- fixed number is displayed at one time. How many are displayed can
- be controlled via Control-[ and Control-].
-
- The focus may be switched with Alt-Left and Alt-Right.
-
- The focused child may be moved via Shift-Alt-Left and
- Shift-Alt-Right. ..
-
-Example:
-
- <tiling-shelf>
- "resource:" directory-files
- [ [ drop ] <bevel-button> tiling-add ]
- each
- "Files" open-window ..
-
-;
-
-ABOUT: "ui.gadgets.tiling"
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: tiling < track gadgets tiles first focused ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-tiling ( tiling -- tiling )
- init-track
- { 1 0 } >>orientation
- V{ } clone >>gadgets
- 2 >>tiles
- 0 >>first
- 0 >>focused ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: <tiling> ( -- gadget ) tiling new init-tiling ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bounded-subseq ( seq a b -- seq )
- [ 0 max ] dip
- pick length [ min ] curry bi@
- rot
- subseq ;
-
-: tiling-gadgets-to-map ( tiling -- gadgets )
- [ gadgets>> ]
- [ first>> ]
- [ [ first>> ] [ tiles>> ] bi + ]
- tri
- bounded-subseq ;
-
-: tiling-map-gadgets ( tiling -- tiling )
- dup clear-track
- dup tiling-gadgets-to-map [ 1 track-add ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: tiling-add ( tiling gadget -- tiling )
- over gadgets>> push
- tiling-map-gadgets ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: first-gadget ( tiling -- index ) drop 0 ;
-
-: last-gadget ( tiling -- index ) gadgets>> length 1 - ;
-
-: first-viewable ( tiling -- index ) first>> ;
-
-: last-viewable ( tiling -- index ) [ first>> ] [ tiles>> ] bi + 1 - ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-focused-mapped ( tiling -- tiling )
-
- dup [ focused>> ] [ first>> ] bi <
- [ dup first>> 1 - >>first ]
- [ ]
- if
-
- dup [ last-viewable ] [ focused>> ] bi <
- [ dup first>> 1 + >>first ]
- [ ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: check-focused-bounds ( tiling -- tiling )
- dup focused>> 0 max over gadgets>> length 1 - min >>focused ;
-
-: focus-prev ( tiling -- tiling )
- dup focused>> 1 - >>focused
- check-focused-bounds
- make-focused-mapped
- tiling-map-gadgets
- dup request-focus ;
-
-: focus-next ( tiling -- tiling )
- dup focused>> 1 + >>focused
- check-focused-bounds
- make-focused-mapped
- tiling-map-gadgets
- dup request-focus ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: exchanged! ( seq a b -- )
- [ 0 max ] bi@
- pick length 1 - '[ _ min ] bi@
- rot exchange ;
-
-: move-prev ( tiling -- tiling )
- dup [ gadgets>> ] [ focused>> 1 - ] [ focused>> ] tri exchanged!
- focus-prev ;
-
-: move-next ( tiling -- tiling )
- dup [ gadgets>> ] [ focused>> ] [ focused>> 1 + ] tri exchanged!
- focus-next ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: add-tile ( tiling -- tiling )
- dup tiles>> 1 + >>tiles
- tiling-map-gadgets ;
-
-: del-tile ( tiling -- tiling )
- dup tiles>> 1 - 1 max >>tiles
- tiling-map-gadgets ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: tiling focusable-child* ( tiling -- child/t )
- [ focused>> ] [ gadgets>> ] bi nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: tiling-shelf < tiling ;
-TUPLE: tiling-pile < tiling ;
-
-: <tiling-shelf> ( -- gadget )
- tiling-shelf new init-tiling { 1 0 } >>orientation ;
-
-: <tiling-pile> ( -- gadget )
- tiling-pile new init-tiling { 0 1 } >>orientation ;
-
-tiling-shelf
- H{
- { T{ key-down f { A+ } "LEFT" } [ focus-prev drop ] }
- { T{ key-down f { A+ } "RIGHT" } [ focus-next drop ] }
- { T{ key-down f { S+ A+ } "LEFT" } [ move-prev drop ] }
- { T{ key-down f { S+ A+ } "RIGHT" } [ move-next drop ] }
- { T{ key-down f { C+ } "[" } [ del-tile drop ] }
- { T{ key-down f { C+ } "]" } [ add-tile drop ] }
- }
-set-gestures
-
-tiling-pile
- H{
- { T{ key-down f { A+ } "UP" } [ focus-prev drop ] }
- { T{ key-down f { A+ } "DOWN" } [ focus-next drop ] }
- { T{ key-down f { S+ A+ } "UP" } [ move-prev drop ] }
- { T{ key-down f { S+ A+ } "DOWN" } [ move-next drop ] }
- { T{ key-down f { C+ } "[" } [ del-tile drop ] }
- { T{ key-down f { C+ } "]" } [ add-tile drop ] }
- }
-set-gestures
--- /dev/null
+! Copyright (C) 2008 Jean-François Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations strings ;
+IN: 4DNav
+
+HELP: (mvt-4D)
+{ $values
+ { "quot" quotation }
+}
+{ $description "" } ;
+
+HELP: 4D-Rxw
+{ $values
+ { "angle" null }
+ { "Rz" null }
+}
+{ $description "" } ;
+
+HELP: 4D-Rxy
+{ $values
+ { "angle" null }
+ { "Rx" null }
+}
+{ $description "" } ;
+
+HELP: 4D-Rxz
+{ $values
+ { "angle" null }
+ { "Ry" null }
+}
+{ $description "" } ;
+
+HELP: 4D-Ryw
+{ $values
+ { "angle" null }
+ { "Ry" null }
+}
+{ $description "" } ;
+
+HELP: 4D-Ryz
+{ $values
+ { "angle" null }
+ { "Rx" null }
+}
+{ $description "" } ;
+
+HELP: 4D-Rzw
+{ $values
+ { "angle" null }
+ { "Rz" null }
+}
+{ $description "" } ;
+
+HELP: 4DNav
+{ $description "" } ;
+
+HELP: >observer3d
+{ $values
+ { "value" null }
+}
+{ $description "" } ;
+
+HELP: >present-space
+{ $values
+ { "value" null }
+}
+{ $description "" } ;
+
+
+HELP: >view1
+{ $values
+ { "value" null }
+}
+{ $description "" } ;
+
+HELP: >view2
+{ $values
+ { "value" null }
+}
+{ $description "" } ;
+
+HELP: >view3
+{ $values
+ { "value" null }
+}
+{ $description "" } ;
+
+HELP: >view4
+{ $values
+ { "value" null }
+}
+{ $description "" } ;
+
+HELP: add-keyboard-delegate
+{ $values
+ { "obj" object }
+ { "obj" object }
+}
+{ $description "" } ;
+
+HELP: button*
+{ $values
+ { "string" string } { "quot" quotation }
+ { "button" null }
+}
+{ $description "" } ;
+
+HELP: camera-action
+{ $values
+ { "quot" quotation }
+ { "quot" quotation }
+}
+{ $description "" } ;
+
+HELP: camera-button
+{ $values
+ { "string" string } { "quot" quotation }
+ { "button" null }
+}
+{ $description "" } ;
+
+HELP: controller-window*
+{ $values
+ { "gadget" "a gadget" }
+}
+{ $description "" } ;
+
+
+HELP: init-models
+{ $description "" } ;
+
+HELP: init-variables
+{ $description "" } ;
+
+HELP: menu-3D
+{ $values
+ { "gadget" null }
+}
+{ $description "The menu dedicated to 3D movements of the camera" } ;
+
+HELP: menu-4D
+{ $values
+
+ { "gadget" null }
+}
+{ $description "The menu dedicated to 4D movements of space" } ;
+
+HELP: menu-bar
+{ $values
+
+ { "gadget" null }
+}
+{ $description "return gadget containing menu buttons" } ;
+
+HELP: model-projection
+{ $values
+ { "x" null }
+ { "space" null }
+}
+{ $description "Project space following coordinate x" } ;
+
+HELP: mvt-3D-1
+{ $values
+
+ { "quot" quotation }
+}
+{ $description "return a quotation to orientate space to see it from first point of view" } ;
+
+HELP: mvt-3D-2
+{ $values
+
+ { "quot" quotation }
+}
+{ $description "return a quotation to orientate space to see it from second point of view" } ;
+
+HELP: mvt-3D-3
+{ $values
+
+ { "quot" quotation }
+}
+{ $description "return a quotation to orientate space to see it from third point of view" } ;
+
+HELP: mvt-3D-4
+{ $values
+
+ { "quot" quotation }
+}
+{ $description "return a quotation to orientate space to see it from first point of view" } ;
+
+HELP: observer3d
+{ $description "" } ;
+
+HELP: observer3d>
+{ $values
+
+ { "value" null }
+}
+{ $description "" } ;
+
+HELP: present-space
+{ $description "" } ;
+
+HELP: present-space>
+{ $values
+
+ { "value" null }
+}
+{ $description "" } ;
+
+HELP: load-model-file
+{ $description "load space from file" } ;
+
+HELP: rotation-4D
+{ $values
+ { "m" "a rotation matrix" }
+}
+{ $description "Apply a 4D rotation matrix" } ;
+
+HELP: translation-4D
+{ $values
+ { "v" null }
+}
+{ $description "" } ;
+
+HELP: update-model-projections
+{ $description "" } ;
+
+HELP: update-observer-projections
+{ $description "" } ;
+
+HELP: view1
+{ $description "" } ;
+
+HELP: view1>
+{ $values
+
+ { "value" null }
+}
+{ $description "" } ;
+
+HELP: view2
+{ $description "" } ;
+
+HELP: view2>
+{ $values
+
+ { "value" null }
+}
+{ $description "" } ;
+
+HELP: view3
+{ $description "" } ;
+
+HELP: view3>
+{ $values
+
+ { "value" null }
+}
+{ $description "" } ;
+
+HELP: view4
+{ $description "" } ;
+
+HELP: view4>
+{ $values
+
+ { "value" null }
+}
+{ $description "" } ;
+
+HELP: viewer-windows*
+{ $description "" } ;
+
+HELP: win3D
+{ $values
+ { "text" null } { "gadget" null }
+}
+{ $description "" } ;
+
+HELP: windows
+{ $description "" } ;
+
+ARTICLE: "Space file" "Create a new space file"
+"\nTo build a new space, create an XML file using " { $vocab-link "adsoda" } " model description. \nAn example is:"
+$nl
+
+"\n<model>"
+"\n<space>"
+"\n <dimension>4</dimension>"
+"\n <solid>"
+"\n <name>4cube1</name>"
+"\n <dimension>4</dimension>"
+"\n <face>1,0,0,0,100</face>"
+"\n <face>-1,0,0,0,-150</face>"
+"\n <face>0,1,0,0,100</face>"
+"\n <face>0,-1,0,0,-150</face>"
+"\n <face>0,0,1,0,100</face>"
+"\n <face>0,0,-1,0,-150</face>"
+"\n <face>0,0,0,1,100</face>"
+"\n <face>0,0,0,-1,-150</face>"
+"\n <color>1,0,0</color>"
+"\n </solid>"
+"\n <solid>"
+"\n <name>4triancube</name>"
+"\n <dimension>4</dimension>"
+"\n <face>1,0,0,0,160</face>"
+"\n <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>"
+"\n <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>"
+"\n <face>0,0,1,0,140</face>"
+"\n <face>0,0,-1,0,-180</face>"
+"\n <face>0,0,0,1,110</face>"
+"\n <face>0,0,0,-1,-180</face>"
+"\n <color>0,1,0</color>"
+"\n </solid>"
+"\n <solid>"
+"\n <name>triangone</name>"
+"\n <dimension>4</dimension>"
+"\n <face>1,0,0,0,60</face>"
+"\n <face>0.5,0.8660254037844386,0,0,60</face>"
+"\n <face>-0.5,0.8660254037844387,0,0,-20</face>"
+"\n <face>-1.0,0,0,0,-100</face>"
+"\n <face>-0.5,-0.8660254037844384,0,0,-100</face>"
+"\n <face>0.5,-0.8660254037844387,0,0,-20</face>"
+"\n <face>0,0,1,0,120</face>"
+"\n <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>"
+"\n <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>"
+"\n <color>0,1,1</color>"
+"\n </solid>"
+"\n <light>"
+"\n <direction>1,1,1,1</direction>"
+"\n <color>0.2,0.2,0.6</color>"
+"\n </light>"
+"\n <color>0.8,0.9,0.9</color>"
+"\n</space>"
+"\n</model>"
+
+
+;
+
+ARTICLE: "TODO" "Todo"
+{ $list
+ "A file chooser"
+ "A vocab to initialize parameters"
+ "an editor mode"
+ { $list "add a face to a solid"
+ "add a solid to the space"
+ "move a face"
+ "move a solid"
+ "select a solid in a list"
+ "select a face"
+ "display selected face"
+ "edit a solid color"
+ "add a light"
+ "edit a light color"
+ "move a light"
+ }
+ "add a tool wich give an hyperplane normal vector with enought points. Will use adsoda.intersect-hyperplanes with { { 0 } { 0 } { 1 } } "
+ "decorrelate 3D camera and activate them with select buttons"
+
+
+
+} ;
+
+
+ARTICLE: "4DNav" "4DNav"
+{ $vocab-link "4DNav" }
+$nl
+{ $heading "4D Navigator" }
+"4DNav is a simple tool to visualize 4 dimensionnal objects."
+"\n"
+"It uses " { $vocab-link "adsoda" } " library to display a 4D space and navigate thru it."
+
+"It will display:"
+{ $list
+ { "a menu window" }
+ { "4 visualization windows" }
+}
+"Each window represents the projection of the 4D space on a particular 3D space."
+$nl
+
+{ $heading "Initialization" }
+"put the space file " { $strong "space-exemple.xml" } " in temp directory"
+" and then type:" { $code "\"4DNav\" run" }
+{ $heading "Navigation" }
+"4D submenu move the space in translations and rotation."
+"\n3D submenu move the camera in 3D space. Cameras in every 3D spaces are manipulated as a single one"
+$nl
+
+
+
+
+{ $heading "Links" }
+{ $subsection "Space file" }
+
+{ $subsection "TODO" }
+
+
+;
+
+ABOUT: "4DNav"
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel \r
+namespaces\r
+accessors\r
+make\r
+math\r
+math.functions\r
+math.trig\r
+math.parser\r
+hashtables\r
+sequences\r
+combinators\r
+continuations\r
+colors\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.handler\r
+ ui.gadgets.slate\r
+ ui.gadgets.theme\r
+ ui.gadgets.frames\r
+ ui.gadgets.tracks\r
+ ui.gadgets.labels\r
+ ui.gadgets.labelled \r
+ ui.gadgets.lists\r
+ ui.gadgets.buttons\r
+ ui.gadgets.packs\r
+ ui.gadgets.grids\r
+ ui.gestures\r
+ ui.tools.workspace\r
+ ui.gadgets.scrollers\r
+splitting\r
+vectors\r
+math.vectors\r
+rewrite-closures\r
+self\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
+\r
+IN: 4DNav\r
+VALUE: selected-file\r
+VALUE: translation-step\r
+VALUE: rotation-step\r
+\r
+3 to: translation-step \r
+5 to: rotation-step\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
+! replacement of namespaces.lib\r
+ \r
+: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;\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 ) closed-quot <repeat-button> ;\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! \r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+\r
+: model-projection-chooser ( -- gadget )\r
+ observer3d> projection-mode>>\r
+ { { 1 "perspective" } { 0 "orthogonal" } } <toggle-buttons> ;\r
+\r
+: collision-detection-chooser ( -- gadget )\r
+ observer3d> collision-mode>>\r
+ { { t "on" } { f "off" } } <toggle-buttons>\r
+;\r
+\r
+: model-projection ( x -- space ) 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> with-self update-observer-projections ] \r
+ make* closed-quot ;\r
+\r
+: win3D ( text gadget -- ) "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 ;\r
+\r
+: rotation-4D ( m -- ) \r
+ '[ _ [ [ middle-of-space dup vneg ] keep 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
+ <frame>\r
+ <pile> 1 >>fill\r
+ "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] button* add-gadget\r
+ "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] button* add-gadget \r
+ @top-left grid-add \r
+ <pile> 1 >>fill\r
+ "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] button* add-gadget\r
+ "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] button* add-gadget \r
+ @top grid-add \r
+ <pile> 1 >>fill\r
+ "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] button* add-gadget\r
+ "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] button* add-gadget \r
+ @center grid-add\r
+ <pile> 1 >>fill\r
+ "XW +" [ drop rotation-step 4D-Rxw rotation-4D ] button* add-gadget\r
+ "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] button* add-gadget \r
+ @top-right grid-add \r
+ <pile> 1 >>fill\r
+ "YW +" [ drop rotation-step 4D-Ryw rotation-4D ] button* add-gadget\r
+ "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] button* add-gadget \r
+ @right grid-add \r
+ <pile> 1 >>fill\r
+ "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] button* add-gadget\r
+ "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] button* add-gadget \r
+ @bottom-right grid-add \r
+;\r
+\r
+: menu-translations-4D ( -- gadget )\r
+ <frame> \r
+ <pile> 1 >>fill\r
+ <shelf> 1 >>fill \r
+ "X+" [ drop { 1 0 0 0 } translation-step v*n translation-4D ] \r
+ button* add-gadget\r
+ "X-" [ drop { -1 0 0 0 } translation-step v*n 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 translation-4D ] \r
+ button* add-gadget\r
+ "Y-" [ drop { 0 -1 0 0 } translation-step v*n 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 translation-4D ] \r
+ button* add-gadget\r
+ "Z-" [ drop { 0 0 -1 0 } translation-step v*n 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 translation-4D ] \r
+ button* add-gadget\r
+ "W-" [ drop { 0 0 0 -1 } translation-step v*n 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 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 <labelled-gadget> ;\r
+\r
+! -----------------------------------------------------\r
+\r
+: menu-rotations-3D ( -- gadget )\r
+ <frame>\r
+ "Turn\n left" [ rotation-step turn-left ] camera-button \r
+ @left grid-add \r
+ "Turn\n right" [ rotation-step turn-right ] camera-button \r
+ @right grid-add \r
+ "Pitch down" [ rotation-step pitch-down ] camera-button \r
+ @bottom grid-add \r
+ "Pitch up" [ rotation-step pitch-up ] camera-button \r
+ @top grid-add \r
+ <shelf> 1 >>fill\r
+ "Roll left\n (ctl)" [ rotation-step roll-left ] camera-button\r
+ add-gadget \r
+ "Roll right\n(ctl)" [ rotation-step roll-right ] camera-button \r
+ add-gadget \r
+ @center grid-add \r
+;\r
+\r
+: menu-translations-3D ( -- gadget )\r
+ <frame>\r
+ "left\n(alt)" [ translation-step strafe-left ] camera-button\r
+ @left grid-add \r
+ "right\n(alt)" [ translation-step strafe-right ] camera-button\r
+ @right grid-add \r
+ "Strafe up \n (alt)" [ translation-step strafe-up ] camera-button\r
+ @top grid-add\r
+ "Strafe down \n (alt)" [ translation-step strafe-down ] camera-button\r
+ @bottom grid-add \r
+ <pile> 1 >>fill\r
+ "Forward (ctl)" [ translation-step step-turtle ] camera-button\r
+ add-gadget\r
+ "Backward (ctl)" [ translation-step neg step-turtle ] camera-button\r
+ 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
+: add-keyboard-delegate ( obj -- obj )\r
+ <handler>\r
+{\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 ] 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
+ } [ make* ] map >hashtable >>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 [ 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 [ adsoda-display-model ] each ]\r
+ [ lights>> "composed of lights : " pprint [ 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
+ <limited-scroller> \r
+ { 200 400 } >>max-dim\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 ) : " <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
+ light-purple solid-interior\r
+ "4D movements" <labelled-gadget>\r
+ f track-add\r
+ <pile>\r
+ 0.5 >>align\r
+ { 2 2 } >>gap\r
+ menu-3D add-gadget\r
+ light-purple solid-interior \r
+ "Camera 3D" <labelled-gadget>\r
+ f track-add \r
+ gray 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
--- /dev/null
+Jeff Bigot
\ No newline at end of file
--- /dev/null
+Adam Wendt
--- /dev/null
+! Copyright (C) 2008 Jean-François Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel ;
+IN: 4DNav.camera
+
+HELP: camera-eye
+{ $values
+
+ { "point" null }
+}
+{ $description "return the position of the camera" } ;
+
+HELP: camera-focus
+{ $values
+
+ { "point" null }
+}
+{ $description "return the point the camera looks at" } ;
+
+HELP: camera-up
+{ $values
+
+ { "dirvec" null }
+}
+{ $description "In order to precise the roling position of camera give an upward vector" } ;
+
+HELP: do-look-at
+{ $values
+ { "camera" null }
+}
+{ $description "Word to use in replacement of gl-look-at when using a camera" } ;
+
+ARTICLE: "4DNav.camera" "4DNav.camera"
+{ $vocab-link "4DNav.camera" }
+"\n"
+"A camera is defined by:"
+{ $list
+{ "a position (" { $link camera-eye } ")" }
+{ "a focus direction (" { $link camera-focus } ")\n" }
+{ "an attitude information (" { $link camera-up } ")\n" }
+}
+"\nUse " { $link do-look-at } " in opengl statement in placement of gl-look-at"
+"\n\n"
+"A camera is a " { $vocab-link "4DNav.turtle" } " object. Its a special vocab to handle mouvements of a 3D object:"
+{ $list
+{ "To define a camera"
+{
+ $unchecked-example
+
+"VAR: my-camera"
+": init-my-camera ( -- )"
+" <turtle> >my-camera"
+" [ my-camera> >self"
+" reset-turtle "
+" ] with-scope ;"
+} }
+{ "To move it"
+{
+ $unchecked-example
+
+" [ my-camera> >self"
+" 45 pitch-up "
+" 5 step-turtle"
+" ] with-scope "
+} }
+{ "or"
+{
+ $unchecked-example
+
+" [ my-camera> >self"
+" 5 strafe-left"
+" ] with-scope "
+}
+}
+{
+"to use it in an opengl statement"
+{
+ $unchecked-example
+ "my-camera> do-look-at"
+
+}
+}
+}
+
+
+;
+
+ABOUT: "4DNav.camera"
--- /dev/null
+USING: kernel namespaces math.vectors opengl 4DNav.turtle self ;
+
+IN: 4DNav.camera
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: camera-eye ( -- point ) turtle-pos> ;
+
+: camera-focus ( -- point ) [ 1 step-turtle turtle-pos> ] save-self ;
+
+: camera-up ( -- dirvec )
+[ 90 pitch-up turtle-pos> 1 step-turtle turtle-pos> swap v- ] save-self ;
+
+: do-look-at ( camera -- )
+[ >self camera-eye camera-focus camera-up gl-look-at ] with-scope ;
--- /dev/null
+! Copyright (C) 2008 Jean-François Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations sequences ;
+IN: 4DNav.deep
+
+! HELP: deep-cleave-quots
+! { $values
+! { "seq" sequence }
+! { "quot" quotation }
+! }
+! { $description "A word to build a soquence from a sequence of quotation" }
+!
+! { $examples
+! "It is useful to build matrix"
+! { $example "USING: math math.trig ; "
+! " 30 deg>rad "
+! " { { [ cos ] [ sin neg ] 0 } "
+! " { [ sin ] [ cos ] 0 } "
+! " { 0 0 1 } "
+! " } deep-cleave-quots "
+! " "
+!
+!
+! } }
+! ;
+
+ARTICLE: "4DNav.deep" "4DNav.deep"
+{ $vocab-link "4DNav.deep" }
+;
+
+ABOUT: "4DNav.deep"
--- /dev/null
+USING: macros quotations math math.functions math.trig sequences.deep kernel make fry combinators grouping ;\r
+IN: 4DNav.deep\r
+\r
+! USING: bake ;\r
+! MACRO: deep-cleave-quots ( seq -- quot )\r
+! [ [ quotation? ] deep-filter ]\r
+! [ [ dup quotation? [ drop , ] when ] deep-map ]\r
+! bi '[ _ cleave _ bake ] ;\r
+\r
+: make-matrix ( quot width -- matrix ) [ { } make ] dip group ; inline\r
+\r
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-c-types? t }
+ { deploy-word-props? t }
+ { deploy-name "4DNav" }
+ { deploy-ui? t }
+ { deploy-math? t }
+ { deploy-threads? t }
+ { deploy-reflection 3 }
+ { deploy-compiler? t }
+ { deploy-unicode? t }
+ { deploy-io 3 }
+ { "stop-after-last-window?" t }
+ { deploy-word-defs? t }
+}
--- /dev/null
+Jeff Bigot
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING:\r
+kernel\r
+io.files\r
+io.backend\r
+io.directories\r
+io.files.info\r
+io.pathnames\r
+sequences\r
+models\r
+strings\r
+ui\r
+ui.operations\r
+ui.commands\r
+ui.gestures\r
+ui.gadgets\r
+ui.gadgets.buttons\r
+ui.gadgets.lists\r
+ui.gadgets.labels\r
+ui.gadgets.tracks\r
+ui.gadgets.packs\r
+ui.gadgets.panes\r
+ui.gadgets.scrollers\r
+prettyprint\r
+combinators\r
+rewrite-closures\r
+accessors\r
+values\r
+tools.walker\r
+fry\r
+;\r
+IN: 4DNav.file-chooser\r
+\r
+TUPLE: file-chooser < track \r
+ path\r
+ extension \r
+ selected-file\r
+ presenter\r
+ hook \r
+ list\r
+ ;\r
+\r
+: find-file-list ( gadget -- list )\r
+ [ file-chooser? ] find-parent list>> ;\r
+\r
+file-chooser H{\r
+ { T{ key-down f f "UP" } [ find-file-list select-previous ] }\r
+ { T{ key-down f f "DOWN" } [ find-file-list select-next ] }\r
+ { T{ key-down f f "PAGE_UP" } [ find-file-list list-page-up ] }\r
+ { T{ key-down f f "PAGE_DOWN" } [ find-file-list list-page-down ] }\r
+ { T{ key-down f f "RET" } [ find-file-list invoke-value-action ] }\r
+ { T{ button-down } request-focus }\r
+ { T{ button-down f 1 } [ find-file-list invoke-value-action ] }\r
+} set-gestures\r
+\r
+: list-of-files ( file-chooser -- seq )\r
+ [ path>> value>> directory-entries ] [ extension>> ] bi\r
+ '[ [ name>> _ [ tail? ] with contains? ] [ directory? ] bi or ] filter\r
+;\r
+\r
+: update-filelist-model ( file-chooser -- file-chooser )\r
+ [ list-of-files ] [ model>> ] bi set-model ;\r
+\r
+: init-filelist-model ( file-chooser -- file-chooser )\r
+ dup list-of-files <model> >>model ; \r
+\r
+: (fc-go) ( file-chooser quot -- )\r
+ [ [ file-chooser? ] find-parent dup path>> ] dip\r
+ call\r
+ normalize-path swap set-model\r
+ update-filelist-model\r
+ drop ;\r
+\r
+: fc-go-parent ( file-chooser -- )\r
+ [ dup value>> parent-directory ] (fc-go) ;\r
+\r
+: fc-go-home ( file-chooser -- )\r
+ [ home ] (fc-go) ;\r
+\r
+: fc-change-directory ( file-chooser file -- file-chooser )\r
+ dupd [ path>> value>> normalize-path ] [ name>> ] bi* \r
+ append-path over path>> set-model \r
+ update-filelist-model\r
+;\r
+\r
+: fc-load-file ( file-chooser file -- )\r
+ dupd [ selected-file>> ] [ name>> ] bi* swap set-model \r
+ [ path>> value>> ] \r
+ [ selected-file>> value>> append ] \r
+ [ hook>> ] tri\r
+ call\r
+; inline\r
+\r
+! : fc-ok-action ( file-chooser -- quot )\r
+! dup selected-file>> value>> "" =\r
+! [ drop [ drop ] ] [ \r
+! [ path>> value>> ] \r
+! [ selected-file>> value>> append ] \r
+! [ hook>> prefix ] tri\r
+! [ drop ] prepend\r
+! ] if ; \r
+\r
+: line-selected-action ( file-chooser -- )\r
+ dup list>> list-value\r
+ dup directory? \r
+ [ fc-change-directory ] [ fc-load-file ] if ;\r
+\r
+: present-dir-element ( element -- string )\r
+ [ name>> ] [ directory? ] bi [ "-> " prepend ] when ;\r
+\r
+: <file-list> ( file-chooser -- list )\r
+ dup [ nip line-selected-action ] curry \r
+ [ present-dir-element ] rot model>> <list> ;\r
+\r
+: <file-chooser> ( hook path extension -- gadget )\r
+ { 0 1 } file-chooser new-track\r
+ swap >>extension\r
+ swap <model> >>path\r
+ "" <model> >>selected-file\r
+ swap >>hook\r
+ init-filelist-model\r
+ dup <file-list> >>list\r
+ "choose a file in directory " <label> f track-add\r
+ dup path>> <label-control> f track-add\r
+ dup extension>> ", " join "limited to : " prepend <label> f track-add\r
+ <shelf> \r
+ "selected file : " <label> add-gadget\r
+ over selected-file>> <label-control> add-gadget\r
+ f track-add\r
+ <shelf> \r
+ over [ swap fc-go-parent ] curry "go up" swap <bevel-button> add-gadget\r
+ over [ swap fc-go-home ] curry "go home" swap <bevel-button> add-gadget\r
+ ! over [ swap fc-ok-action ] curry "OK" swap <bevel-button> add-gadget\r
+ ! [ drop ] "Cancel" swap <bevel-button> add-gadget\r
+ f track-add\r
+ dup list>> <scroller> 1 track-add\r
+;\r
+\r
+M: file-chooser pref-dim* drop { 400 200 } ;\r
+\r
+: file-chooser-window ( -- )\r
+[ . ] home { "xml" "txt" } <file-chooser> "Choose a file" open-window ;\r
+\r
--- /dev/null
+<model>\r
+<space>\r
+ <name>hypercube</name>\r
+ <dimension>4</dimension>\r
+ <solid>\r
+ <name>4cube1</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,100</face>\r
+ <face>-1,0,0,0,-150</face>\r
+ <face>0,1,0,0,100</face>\r
+ <face>0,-1,0,0,-150</face>\r
+ <face>0,0,1,0,100</face>\r
+ <face>0,0,-1,0,-150</face>\r
+ <face>0,0,0,1,100</face>\r
+ <face>0,0,0,-1,-150</face>\r
+ <color>1,0,0</color>\r
+ </solid>\r
+ <solid>\r
+ <name>4cube1</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,100</face>\r
+ <face>-1,0,0,0,-150</face>\r
+ <face>0,1,0,0,100</face>\r
+ <face>0,-1,0,0,-150</face>\r
+ <face>0,0,1,0,100</face>\r
+ <face>0,0,-1,0,-150</face>\r
+ <face>0,0,0,1,100</face>\r
+ <face>0,0,0,-1,-150</face>\r
+ <color>1,0,0</color>\r
+ </solid>\r
+ <light>\r
+ <direction>1,1,1,1</direction>\r
+ <color>0.2,0.2,0.6</color>\r
+ </light>\r
+ <color>0.8,0.9,0.9</color>\r
+</space>\r
+</model>\r
--- /dev/null
+<model>\r
+<space>\r
+ <name>multi solids</name>\r
+ <dimension>4</dimension>\r
+ <solid>\r
+ <name>4cube1</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,100</face>\r
+ <face>-1,0,0,0,-150</face>\r
+ <face>0,1,0,0,100</face>\r
+ <face>0,-1,0,0,-150</face>\r
+ <face>0,0,1,0,100</face>\r
+ <face>0,0,-1,0,-150</face>\r
+ <face>0,0,0,1,100</face>\r
+ <face>0,0,0,-1,-150</face>\r
+ <color>1,1,1</color>\r
+ </solid>\r
+ <solid>\r
+ <name>4triancube</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,160</face>\r
+ <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
+ <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
+ <face>0,0,1,0,140</face>\r
+ <face>0,0,-1,0,-180</face>\r
+ <face>0,0,0,1,110</face>\r
+ <face>0,0,0,-1,-180</face>\r
+ <color>1,1,1</color>\r
+ </solid>\r
+ <solid>\r
+ <name>triangone</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,60</face>\r
+ <face>0.5,0.8660254037844386,0,0,60</face>\r
+ <face>-0.5,0.8660254037844387,0,0,-20</face>\r
+ <face>-1.0,0,0,0,-100</face>\r
+ <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
+ <face>0.5,-0.8660254037844387,0,0,-20</face>\r
+ <face>0,0,1,0,120</face>\r
+ <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
+ <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
+ <color>1,1,1</color>\r
+ </solid>\r
+ <light>\r
+ <direction>1,0,0,0</direction>\r
+ <color>0,0,0,0.6</color>\r
+ </light>\r
+ <light>\r
+ <direction>0,1,0,0</direction>\r
+ <color>0,0.6,0,0</color>\r
+ </light>\r
+ <light>\r
+ <direction>0,0,1,0</direction>\r
+ <color>0,0,0.6,0</color>\r
+ </light>\r
+ <light>\r
+ <direction>0,0,0,1</direction>\r
+ <color>0.6,0.6,0.6</color>\r
+ </light>\r
+ <color>0.99,0.99,0.99</color>\r
+</space>\r
+</model>\r
--- /dev/null
+<model>\r
+<space>\r
+ <name>multi solids</name>\r
+ <dimension>4</dimension>\r
+ <solid>\r
+ <name>4cube1</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,100</face>\r
+ <face>-1,0,0,0,-150</face>\r
+ <face>0,1,0,0,100</face>\r
+ <face>0,-1,0,0,-150</face>\r
+ <face>0,0,1,0,100</face>\r
+ <face>0,0,-1,0,-150</face>\r
+ <face>0,0,0,1,100</face>\r
+ <face>0,0,0,-1,-150</face>\r
+ <color>1,0,0</color>\r
+ </solid>\r
+ <solid>\r
+ <name>4triancube</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,160</face>\r
+ <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
+ <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
+ <face>0,0,1,0,140</face>\r
+ <face>0,0,-1,0,-180</face>\r
+ <face>0,0,0,1,110</face>\r
+ <face>0,0,0,-1,-180</face>\r
+ <color>0,1,0</color>\r
+ </solid>\r
+ <solid>\r
+ <name>triangone</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,60</face>\r
+ <face>0.5,0.8660254037844386,0,0,60</face>\r
+ <face>-0.5,0.8660254037844387,0,0,-20</face>\r
+ <face>-1.0,0,0,0,-100</face>\r
+ <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
+ <face>0.5,-0.8660254037844387,0,0,-20</face>\r
+ <face>0,0,1,0,120</face>\r
+ <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
+ <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
+ <color>0,1,1</color>\r
+ </solid>\r
+ <light>\r
+ <direction>1,1,1,1</direction>\r
+ <color>0.2,0.2,0.6</color>\r
+ </light>\r
+ <color>0.8,0.9,0.9</color>\r
+</space>\r
+</model>\r
--- /dev/null
+<model>\r
+<space>\r
+ <name>Prismetragone</name> \r
+ <dimension>4</dimension>\r
+ <solid>\r
+ <name>triangone</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,60</face>\r
+ <face>0.5,0.8660254037844386,0,0,60</face>\r
+ <face>-0.5,0.8660254037844387,0,0,-20</face>\r
+ <face>-1.0,0,0,0,-100</face>\r
+ <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
+ <face>0.5,-0.8660254037844387,0,0,-20</face>\r
+ <face>0,0,1,0,120</face>\r
+ <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
+ <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
+ <color>0,1,1</color>\r
+ </solid>\r
+ <light>\r
+ <direction>1,1,1,1</direction>\r
+ <color>0.2,0.2,0.6</color>\r
+ </light>\r
+ <color>0.8,0.9,0.9</color>\r
+</space>\r
+</model>\r
--- /dev/null
+Jeff Bigot
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Jean-François Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel ;
+IN: 4DNav.space-file-decoder
+
+HELP: adsoda-read-model
+{ $values
+ { "tag" null }
+}
+{ $description "" } ;
+
+HELP: decode-number-array
+{ $values
+ { "x" null }
+ { "y" null }
+}
+{ $description "" } ;
+
+HELP: read-model-file
+{ $values
+
+ { "path" "path to the file to read" }
+ { "x" null }
+}
+{ $description "" } ;
+
+ARTICLE: "4DNav.space-file-decoder" "4DNav.space-file-decoder"
+{ $vocab-link "4DNav.space-file-decoder" }
+;
+
+ABOUT: "4DNav.space-file-decoder"
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: adsoda xml xml.utilities xml.dispatch accessors combinators\r
+sequences math.parser kernel splitting values continuations ;\r
+IN: 4DNav.space-file-decoder\r
+\r
+: decode-number-array ( x -- y ) "," split [ string>number ] map ;\r
+\r
+PROCESS: adsoda-read-model ( tag -- )\r
+\r
+TAG: dimension adsoda-read-model children>> first string>number ;\r
+TAG: direction adsoda-read-model children>> first decode-number-array ;\r
+TAG: color adsoda-read-model children>> first decode-number-array ;\r
+TAG: name adsoda-read-model children>> first ;\r
+TAG: face adsoda-read-model children>> first decode-number-array ;\r
+\r
+TAG: solid adsoda-read-model \r
+ <solid> swap \r
+ { \r
+ [ "dimension" tag-named adsoda-read-model >>dimension ] \r
+ [ "name" tag-named adsoda-read-model >>name ] \r
+ [ "color" tag-named adsoda-read-model >>color ] \r
+ [ "face" tags-named [ adsoda-read-model cut-solid ] each ] \r
+ } cleave\r
+ ensure-adjacencies\r
+;\r
+\r
+TAG: light adsoda-read-model \r
+ <light> swap \r
+ { \r
+ [ "direction" tag-named adsoda-read-model >>direction ] \r
+ [ "color" tag-named adsoda-read-model >>color ] \r
+ } cleave\r
+;\r
+\r
+TAG: space adsoda-read-model \r
+ <space> swap \r
+ { \r
+ [ "dimension" tag-named adsoda-read-model >>dimension ] \r
+ [ "name" tag-named adsoda-read-model >>name ] \r
+ [ "color" tag-named adsoda-read-model >>ambient-color ] \r
+ [ "solid" tags-named [ adsoda-read-model suffix-solids ] each ] \r
+ [ "light" tags-named [ adsoda-read-model suffix-lights ] each ] \r
+ } cleave\r
+;\r
+\r
+: read-model-file ( path -- x )\r
+ dup\r
+ [\r
+ [ file>xml "space" tags-named first adsoda-read-model ] \r
+ [ drop <space> ] recover \r
+ ] [ drop <space> ] if \r
+\r
+;\r
+\r
--- /dev/null
+4DNav : simmple tool to navigate thru a 4D space view as projections on 4 3D spaces.
\ No newline at end of file
--- /dev/null
+4D viewer
\ No newline at end of file
--- /dev/null
+<model>\r
+<space>\r
+ <name>triancube</name> \r
+ <dimension>4</dimension>\r
+ <solid>\r
+ <name>triancube</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,160</face>\r
+ <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
+ <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
+ <face>0,0,1,0,140</face>\r
+ <face>0,0,-1,0,-180</face>\r
+ <face>0,0,0,1,110</face>\r
+ <face>0,0,0,-1,-180</face>\r
+ <color>0,1,0</color>\r
+ </solid>\r
+ <light>\r
+ <direction>1,1,1,1</direction>\r
+ <color>0.2,0.2,0.6</color>\r
+ </light>\r
+ <color>0.8,0.9,0.9</color>\r
+</space>\r
+</model>\r
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+! Copyright (C) 2008 Jean-François Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays help.markup help.syntax kernel sequences ;
+IN: 4DNav.turtle
+
+HELP: <turtle>
+{ $values
+
+ { "turtle" null }
+}
+{ $description "" } ;
+
+HELP: >turtle-ori
+{ $values
+ { "val" null }
+}
+{ $description "" } ;
+
+HELP: >turtle-pos
+{ $values
+ { "val" null }
+}
+{ $description "" } ;
+
+HELP: Rx
+{ $values
+ { "angle" null }
+ { "Rz" null }
+}
+{ $description "" } ;
+
+HELP: Ry
+{ $values
+ { "angle" null }
+ { "Ry" null }
+}
+{ $description "" } ;
+
+HELP: Rz
+{ $values
+ { "angle" null }
+ { "Rx" null }
+}
+{ $description "" } ;
+
+HELP: V
+{ $values
+
+ { "V" null }
+}
+{ $description "" } ;
+
+HELP: X
+{ $values
+
+ { "3array" null }
+}
+{ $description "" } ;
+
+HELP: Y
+{ $values
+
+ { "3array" null }
+}
+{ $description "" } ;
+
+HELP: Z
+{ $values
+
+ { "3array" null }
+}
+{ $description "" } ;
+
+HELP: apply-rotation
+{ $values
+ { "rotation" null }
+}
+{ $description "" } ;
+
+HELP: distance
+{ $values
+ { "turtle" null } { "turtle" null }
+ { "n" null }
+}
+{ $description "" } ;
+
+HELP: move-by
+{ $values
+ { "point" null }
+}
+{ $description "" } ;
+
+HELP: pitch-down
+{ $values
+ { "angle" null }
+}
+{ $description "" } ;
+
+HELP: pitch-up
+{ $values
+ { "angle" null }
+}
+{ $description "" } ;
+
+HELP: reset-turtle
+{ $description "" } ;
+
+HELP: roll-left
+{ $values
+ { "angle" null }
+}
+{ $description "" } ;
+
+HELP: roll-right
+{ $values
+ { "angle" null }
+}
+{ $description "" } ;
+
+HELP: roll-until-horizontal
+{ $description "" } ;
+
+HELP: rotate-x
+{ $values
+ { "angle" null }
+}
+{ $description "" } ;
+
+HELP: rotate-y
+{ $values
+ { "angle" null }
+}
+{ $description "" } ;
+
+HELP: rotate-z
+{ $values
+ { "angle" null }
+}
+{ $description "" } ;
+
+HELP: set-X
+{ $values
+ { "seq" sequence }
+}
+{ $description "" } ;
+
+HELP: set-Y
+{ $values
+ { "seq" sequence }
+}
+{ $description "" } ;
+
+HELP: set-Z
+{ $values
+ { "seq" sequence }
+}
+{ $description "" } ;
+
+HELP: step-turtle
+{ $values
+ { "length" null }
+}
+{ $description "" } ;
+
+HELP: step-vector
+{ $values
+ { "length" null }
+ { "array" array }
+}
+{ $description "" } ;
+
+HELP: strafe-down
+{ $values
+ { "length" null }
+}
+{ $description "" } ;
+
+HELP: strafe-left
+{ $values
+ { "length" null }
+}
+{ $description "" } ;
+
+HELP: strafe-right
+{ $values
+ { "length" null }
+}
+{ $description "" } ;
+
+HELP: strafe-up
+{ $values
+ { "length" null }
+}
+{ $description "" } ;
+
+HELP: turn-left
+{ $values
+ { "angle" null }
+}
+{ $description "" } ;
+
+HELP: turn-right
+{ $values
+ { "angle" null }
+}
+{ $description "" } ;
+
+HELP: turtle
+{ $description "" } ;
+
+HELP: turtle-ori>
+{ $values
+
+ { "val" null }
+}
+{ $description "" } ;
+
+HELP: turtle-pos>
+{ $values
+
+ { "val" null }
+}
+{ $description "" } ;
+
+ARTICLE: "4DNav.turtle" "4DNav.turtle"
+{ $vocab-link "4DNav.turtle" }
+;
+
+ABOUT: "4DNav.turtle"
--- /dev/null
+USING: kernel math arrays math.vectors math.matrices
+namespaces make
+math.constants math.functions
+math.vectors
+splitting grouping self math.trig
+ sequences accessors 4DNav.deep models ;
+IN: 4DNav.turtle
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: turtle pos ori ;
+
+: <turtle> ( -- turtle )
+ turtle new
+ { 0 0 0 } clone >>pos
+ 3 identity-matrix >>ori
+;
+
+
+TUPLE: observer < turtle projection-mode collision-mode ;
+
+: <observer> ( -- object )
+ observer new
+ 0 <model> >>projection-mode
+ f <model> >>collision-mode
+ ;
+
+
+: turtle-pos> ( -- val ) self> pos>> ;
+: >turtle-pos ( val -- ) self> (>>pos) ;
+
+: turtle-ori> ( -- val ) self> ori>> ;
+: >turtle-ori ( val -- ) self> (>>ori) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! These rotation matrices are from
+! `Computer Graphics: Principles and Practice'
+
+
+! waiting for deep-cleave-quots
+
+! : Rz ( angle -- Rx ) deg>rad
+! { { [ cos ] [ sin neg ] 0 }
+! { [ sin ] [ cos ] 0 }
+! { 0 0 1 }
+! } deep-cleave-quots ;
+
+! : Ry ( angle -- Ry ) deg>rad
+! { { [ cos ] 0 [ sin ] }
+! { 0 1 0 }
+! { [ sin neg ] 0 [ cos ] }
+! } deep-cleave-quots ;
+
+! : Rx ( angle -- Rz ) deg>rad
+! { { 1 0 0 }
+! { 0 [ cos ] [ sin neg ] }
+! { 0 [ sin ] [ cos ] }
+! } deep-cleave-quots ;
+
+: Rz ( angle -- Rx ) deg>rad
+[ dup cos , dup sin neg , 0 ,
+ dup sin , dup cos , 0 ,
+ 0 , 0 , 1 , ] 3 make-matrix nip ;
+
+: Ry ( angle -- Ry ) deg>rad
+[ dup cos , 0 , dup sin ,
+ 0 , 1 , 0 ,
+ dup sin neg , 0 , dup cos , ] 3 make-matrix nip ;
+
+: Rx ( angle -- Rz ) deg>rad
+[ 1 , 0 , 0 ,
+ 0 , dup cos , dup sin neg ,
+ 0 , dup sin , dup cos , ] 3 make-matrix nip ;
+
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: apply-rotation ( rotation -- ) turtle-ori> swap m. >turtle-ori ;
+
+: rotate-x ( angle -- ) Rx apply-rotation ;
+: rotate-y ( angle -- ) Ry apply-rotation ;
+: rotate-z ( angle -- ) Rz apply-rotation ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pitch-up ( angle -- ) neg rotate-x ;
+: pitch-down ( angle -- ) rotate-x ;
+
+: turn-left ( angle -- ) rotate-y ;
+: turn-right ( angle -- ) neg rotate-y ;
+
+: roll-left ( angle -- ) neg rotate-z ;
+: roll-right ( angle -- ) rotate-z ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! roll-until-horizontal
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: V ( -- V ) { 0 1 0 } ;
+
+: X ( -- 3array ) turtle-ori> [ first ] map ;
+: Y ( -- 3array ) turtle-ori> [ second ] map ;
+: Z ( -- 3array ) turtle-ori> [ third ] map ;
+
+: set-X ( seq -- ) turtle-ori> [ set-first ] 2each ;
+: set-Y ( seq -- ) turtle-ori> [ set-second ] 2each ;
+: set-Z ( seq -- ) turtle-ori> [ set-third ] 2each ;
+
+: roll-until-horizontal ( -- )
+ V Z cross normalize set-X
+ Z X cross normalize set-Y ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: distance ( turtle turtle -- n ) pos>> swap pos>> v- [ sq ] map sum sqrt ;
+
+: move-by ( point -- ) turtle-pos> v+ >turtle-pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: reset-turtle ( -- )
+ { 0 0 0 } clone >turtle-pos 3 identity-matrix >turtle-ori ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: step-vector ( length -- array ) { 0 0 1 } n*v ;
+
+: step-turtle ( length -- )
+ step-vector turtle-ori> swap m.v turtle-pos> v+ >turtle-pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: strafe-up ( length -- )
+ 90 pitch-up
+ step-turtle
+ 90 pitch-down ;
+
+: strafe-down ( length -- )
+ 90 pitch-down
+ step-turtle
+ 90 pitch-up ;
+
+: strafe-left ( length -- )
+ 90 turn-left
+ step-turtle
+ 90 turn-right ;
+
+: strafe-right ( length -- )
+ 90 turn-right
+ step-turtle
+ 90 turn-left ;
--- /dev/null
+Jeff Bigot
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Jean-François Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel ;
+IN: 4DNav.window3D
+
+HELP: <window3D>
+{ $values
+ { "model" null } { "observer" null }
+ { "gadget" null }
+}
+{ $description "" } ;
+
+HELP: window3D
+{ $description "" } ;
+
+ARTICLE: "4DNav.window3D" "4DNav.window3D"
+{ $vocab-link "4DNav.window3D" }
+;
+
+ABOUT: "4DNav.window3D"
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel \r
+ui.gadgets\r
+ui.render\r
+opengl\r
+opengl.gl\r
+opengl.glu\r
+4DNav.camera\r
+4DNav.turtle\r
+math\r
+values\r
+alien.c-types\r
+accessors\r
+namespaces\r
+adsoda \r
+models\r
+accessors\r
+prettyprint\r
+;\r
+\r
+IN: 4DNav.window3D\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! drawing functions \r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+\r
+TUPLE: window3D < gadget observer ; \r
+\r
+: <window3D> ( model observer -- gadget )\r
+ window3D new-gadget \r
+ swap 2dup \r
+ projection-mode>> add-connection\r
+ 2dup \r
+ collision-mode>> add-connection\r
+ >>observer \r
+ swap <model> >>model \r
+ t >>root?\r
+;\r
+\r
+M: window3D pref-dim* ( gadget -- dim ) drop { 300 300 } ;\r
+\r
+M: window3D draw-gadget* ( gadget -- )\r
+\r
+ GL_PROJECTION glMatrixMode\r
+ glLoadIdentity\r
+ 0.6 0.6 0.6 .9 glClearColor\r
+ dup observer>> projection-mode>> value>> 1 = \r
+ [ 60.0 1.0 0.1 3000.0 gluPerspective ]\r
+ [ -400.0 400.0 -400.0 400.0 0.0 4000.0 glOrtho ] if\r
+ dup observer>> collision-mode>> value>> \r
+ \ remove-hidden-solids? \r
+ set-value\r
+ dup observer>> do-look-at\r
+ GL_MODELVIEW glMatrixMode\r
+ glLoadIdentity \r
+ 0.9 0.9 0.9 1.0 glClearColor\r
+ 1.0 glClearDepth\r
+ GL_LINE_SMOOTH glEnable\r
+ GL_BLEND glEnable\r
+ GL_DEPTH_TEST glEnable \r
+ GL_LEQUAL glDepthFunc\r
+ GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc\r
+ GL_LINE_SMOOTH_HINT GL_NICEST glHint\r
+ 1.25 glLineWidth\r
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear\r
+ glLoadIdentity\r
+ GL_LIGHTING glEnable\r
+ GL_LIGHT0 glEnable\r
+ GL_COLOR_MATERIAL glEnable\r
+ GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial\r
+ ! *************************\r
+ \r
+ model>> value>> \r
+ [ space->GL ] when*\r
+\r
+ ! *************************\r
+;\r
+\r
+M: window3D graft* drop ;\r
+\r
+M: window3D model-changed nip relayout ; \r
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: help.markup help.syntax ;\r
+\r
+IN: adsoda\r
+\r
+\r
+\r
+! --------------------------------------------------------------\r
+! faces\r
+! --------------------------------------------------------------\r
+ARTICLE: "face-page" "face in ADSODA"\r
+"explanation of faces"\r
+$nl\r
+"link to functions"\r
+"what is an halfspace"\r
+"halfspace touching-corners adjacent-faces"\r
+"touching-corners list of pointers to the corners which touch this face\n"\r
+\r
+"adjacent-faces list of pointers to the faces which touch this face\n"\r
+{ $subsection face }\r
+{ $subsection <face> }\r
+"test relative position"\r
+{ $subsection point-inside-or-on-face? } \r
+{ $subsection point-inside-face? }\r
+"handling face"\r
+{ $subsection flip-face }\r
+{ $subsection face-translate }\r
+{ $subsection face-transform }\r
+\r
+;\r
+\r
+HELP: face\r
+{ $class-description "a face is defined by"\r
+{ $list "halfspace equation" }\r
+{ $list "list of touching corners" }\r
+{ $list "list of adjacent faces" }\r
+$nl\r
+"Touching corners and adjacent faces are defined by algorithm thanks to other faces of the solid"\r
+}\r
+\r
+\r
+;\r
+HELP: <face> \r
+{ $values { "v" "an halfspace equation" } { "tuple" "a face" } } ;\r
+HELP: flip-face \r
+{ $values { "face" "a face" } { "face" "flipped face" } }\r
+{ $description "change the orientation of a face" }\r
+;\r
+\r
+HELP: face-translate \r
+{ $values { "face" "a face" } { "v" "a vector" } }\r
+{ $description \r
+"translate a face following a vector"\r
+$nl\r
+"a translation of an halfspace doesn't change the normal vector. this word just compute the new constant term" }\r
+\r
+ \r
+ ;\r
+HELP: face-transform \r
+{ $values { "face" "a face" } { "m" "a transformation matrix" } }\r
+{ $description "compute the transformation of a face using a transformation matrix" }\r
+ \r
+ ;\r
+! --------------------------------\r
+! solid\r
+! --------------------------------------------------------------\r
+ARTICLE: "solid-page" "solid in ADSODA"\r
+"explanation of solids"\r
+$nl\r
+"link to functions"\r
+{ $subsection solid }\r
+{ $subsection <solid> }\r
+"test relative position"\r
+{ $subsection point-inside-solid? }\r
+{ $subsection point-inside-or-on-solid? }\r
+"playing with faces and solids"\r
+{ $subsection add-face }\r
+{ $subsection cut-solid }\r
+{ $subsection slice-solid }\r
+"solid handling"\r
+{ $subsection solid-project }\r
+{ $subsection solid-translate }\r
+{ $subsection solid-transform }\r
+{ $subsection subtract }\r
+\r
+{ $subsection get-silhouette }\r
+\r
+{ $subsection solid= }\r
+\r
+\r
+;\r
+\r
+HELP: solid \r
+{ $class-description "dimension" $nl "silhouettes" $nl "faces" $nl "corners" $nl "adjacencies-valid" $nl "color" $nl "name" \r
+}\r
+;\r
+\r
+HELP: add-face \r
+{ $values { "solid" "a solid" } { "face" "a face" } }\r
+{ $description "reshape a solid with a face. The face truncate the solid." } ;\r
+\r
+HELP: cut-solid\r
+{ $values { "solid" "a solid" } { "halfspace" "an halfspace" } }\r
+{ $description "like add-face but just with halfspace equation" } ;\r
+\r
+HELP: slice-solid\r
+{ $values { "solid" "a solid" } { "face" "a face" } { "solid1" "the outer part of the former solid" } { "solid2" "the inner part of the former solid" } }\r
+{ $description "cut a solid into two parts. The face acts like a knife"\r
+} ;\r
+\r
+\r
+HELP: solid-project\r
+{ $values { "lights" "lights" } { "ambient" "ambient" } { "solid" "solid" } { "solids" "projection of solid" } }\r
+{ $description "Project the solid using pv vector" \r
+$nl\r
+"TODO: explain how to use lights"\r
+} ;\r
+\r
+HELP: solid-translate \r
+{ $values { "solid" "a solid" } { "v" "translating vector" } }\r
+{ $description "Translate a solid using a vector" \r
+$nl\r
+"v and solid must have the same dimension "\r
+} ;\r
+\r
+HELP: solid-transform \r
+{ $values { "solid" "a solid" } { "m" "transformation matrix" } }\r
+{ $description "Transform a solid using a matrix"\r
+$nl\r
+"v and solid must have the same dimension "\r
+} ;\r
+\r
+HELP: subtract \r
+{ $values { "solid1" "initial shape" } { "solid2" "shape to remove" } { "solids" "resulting shape" } }\r
+{ $description " " } ;\r
+\r
+\r
+! --------------------------------------------------------------\r
+! space \r
+! --------------------------------------------------------------\r
+ARTICLE: "space-page" "space in ADSODA"\r
+"A space is a collection of solids and lights."\r
+$nl\r
+"link to functions"\r
+$nl\r
+"Defining words"\r
+{ $subsection space }\r
+{ $subsection <space> } \r
+{ $subsection suffix-solids }\r
+{ $subsection suffix-lights }\r
+{ $subsection clear-space-solids }\r
+{ $subsection describe-space }\r
+\r
+\r
+"Handling space"\r
+{ $subsection space-ensure-solids }\r
+{ $subsection eliminate-empty-solids }\r
+{ $subsection space-transform }\r
+{ $subsection space-translate }\r
+{ $subsection remove-hidden-solids }\r
+{ $subsection space-project }\r
+\r
+\r
+;\r
+\r
+HELP: space \r
+{ $class-description \r
+"dimension" $nl " solids" $nl " ambient-color" $nl "lights" \r
+}\r
+;\r
+\r
+HELP: suffix-solids \r
+"( space solid -- space )"\r
+{ $values { "space" "a space" } { "solid" "a solid to add" } }\r
+{ $description "Add solid to space definition" } ;\r
+\r
+HELP: suffix-lights \r
+"( space light -- space ) "\r
+{ $values { "space" "a space" } { "light" "a light to add" } }\r
+{ $description "Add a light to space definition" } ;\r
+\r
+HELP: clear-space-solids \r
+"( space -- space )" \r
+{ $values { "space" "a space" } }\r
+{ $description "remove all solids in space" } ;\r
+\r
+HELP: space-ensure-solids \r
+{ $values { "space" "a space" } }\r
+{ $description "rebuild corners of all solids in space" } ;\r
+\r
+\r
+\r
+HELP: space-transform \r
+" ( space m -- space )" \r
+{ $values { "space" "a space" } { "m" "a matrix" } }\r
+{ $description "Transform a space using a matrix" } ;\r
+\r
+HELP: space-translate \r
+{ $values { "space" "a space" } { "v" "a vector" } }\r
+{ $description "Translate a space following a vector" } ;\r
+\r
+HELP: describe-space " ( space -- )"\r
+{ $values { "space" "a space" } }\r
+{ $description "return a description of space" } ;\r
+\r
+HELP: space-project \r
+{ $values { "space" "a space" } { "i" "an integer" } }\r
+{ $description "Project a space along ith coordinate" } ;\r
+\r
+! --------------------------------------------------------------\r
+! 3D rendering\r
+! --------------------------------------------------------------\r
+ARTICLE: "3D-rendering-page" "3D rendering in ADSODA"\r
+"explanation of 3D rendering"\r
+$nl\r
+"link to functions"\r
+{ $subsection face->GL }\r
+{ $subsection solid->GL }\r
+{ $subsection space->GL }\r
+\r
+;\r
+\r
+HELP: face->GL \r
+{ $values { "face" "a face" } { "color" "3 3 values array" } }\r
+{ $description "" } ;\r
+\r
+HELP: solid->GL \r
+{ $values { "solid" "a solid" } }\r
+{ $description "" } ;\r
+\r
+HELP: space->GL \r
+{ $values { "space" "a space" } }\r
+{ $description "" } ;\r
+\r
+! --------------------------------------------------------------\r
+! light\r
+! --------------------------------------------------------------\r
+\r
+ARTICLE: "light-page" "light in ADSODA"\r
+"explanation of light"\r
+$nl\r
+"link to functions"\r
+;\r
+\r
+ARTICLE: { "adsoda" "light" } "ADSODA : lights"\r
+"! HELP: light position color" \r
+"! <light> ( -- tuple ) light new ;"\r
+\r
+"! light est un vecteur avec 3 variables pour les couleurs\n"\r
+\r
+" void Light::Apply(Vector& normal, double &cRed, double &cGreen, double &cBlue)\n"\r
+" { \n"\r
+" // Dot the light direction with the normalized normal of Face."\r
+" register double intensity = -(normal * (*this));"\r
+\r
+" // Face is a backface, from light's perspective"\r
+" if (intensity < 0)"\r
+" return;"\r
+" "\r
+" // Add the intensity componentwise"\r
+" cRed += red * intensity;"\r
+" cGreen += green * intensity;"\r
+" cBlue += blue * intensity;"\r
+\r
+" // Clip to unit range"\r
+" if (cRed > 1.0) cRed = 1.0;"\r
+" if (cGreen > 1.0) cGreen = 1.0;"\r
+" if (cBlue > 1.0) cBlue = 1.0;"\r
+\r
+\r
+;\r
+\r
+\r
+\r
+ARTICLE: { "adsoda" "halfspace" } "ADSODA : halfspace"\r
+"! demi espace défini par un vecteur normal et une constante"\r
+" defined by the concatenation of the normal vector and a constant" \r
+ ;\r
+\r
+\r
+\r
+ARTICLE: "adsoda-main-page" "ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm"\r
+"multidimensional handler :" \r
+$nl\r
+"design a solid using face delimitations. Only works on convex shapes"\r
+$nl\r
+{ $emphasis "written in C++ by Greg Ferrar" }\r
+$nl\r
+"full explanation on adsoda page at " { $url "http://www.flowerfire.com/ADSODA/" }\r
+$nl\r
+"Useful words are describe on the following pages: "\r
+{ $subsection "face-page" }\r
+{ $subsection "solid-page" }\r
+{ $subsection "space-page" }\r
+{ $subsection "light-page" }\r
+{ $subsection "3D-rendering-page" }\r
+ ;\r
+\r
+ABOUT: "adsoda-main-page"\r
--- /dev/null
+USING: adsoda\r
+kernel\r
+math\r
+accessors\r
+sequences\r
+ adsoda.solution2\r
+ fry\r
+ tools.test \r
+ arrays ;\r
+\r
+IN: adsoda.tests\r
+\r
+\r
+\r
+: s1 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "s1" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+;\r
+: solid1 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid1" >>name\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+: solid2 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid2" >>name\r
+ { -1 1 -10 } cut-solid \r
+ { -1 -1 -28 } cut-solid \r
+ { 1 0 13 } cut-solid \r
+ ! { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid3 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid3" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 16 } cut-solid \r
+ { -1 0 -36 } cut-solid \r
+ { 0 1 1 } cut-solid \r
+ { 0 -1 -17 } cut-solid \r
+ ! { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+\r
+;\r
+\r
+: solid4 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid4" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 21 } cut-solid \r
+ { -1 0 -36 } cut-solid \r
+ { 0 1 1 } cut-solid \r
+ { 0 -1 -17 } cut-solid \r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid5 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid5" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 6 } cut-solid \r
+ { -1 0 -17 } cut-solid \r
+ { 0 1 17 } cut-solid \r
+ { 0 -1 -19 } cut-solid \r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid7 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid7" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 38 } cut-solid \r
+ { 1 -5 -66 } cut-solid \r
+ { -2 1 -75 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid6s ( -- seq )\r
+ solid3 clone solid2 clone subtract\r
+;\r
+\r
+: space1 ( -- space )\r
+ <space>\r
+ 2 >>dimension\r
+ ! solid3 suffix-solids\r
+ solid1 suffix-solids\r
+ solid2 suffix-solids\r
+ ! solid6s [ suffix-solids ] each \r
+ solid4 suffix-solids\r
+ ! solid5 suffix-solids\r
+ solid7 suffix-solids\r
+ { 1 1 1 } >>ambient-color\r
+ <light>\r
+ { -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+;\r
+\r
+: space2 ( -- space )\r
+ <space>\r
+ 4 >>dimension\r
+ ! 4cube suffix-solids\r
+ { 1 1 1 } >>ambient-color\r
+ <light>\r
+ { -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+\r
+ ;\r
+\r
+\r
+\r
+! {\r
+! { 1 0 0 0 }\r
+! { 0 1 0 0 }\r
+! { 0 0 0.984807753012208 -0.1736481776669303 }\r
+! { 0 0 0.1736481776669303 0.984807753012208 }\r
+! }\r
+\r
+! ------------------------------------------------------------\r
+! constant+\r
+[ { 1 2 5 } ] [ { 1 2 3 } 2 constant+ ] unit-test\r
+\r
+! ------------------------------------------------------------\r
+! translate\r
+[ { 1 -1 0 } ] [ { 1 -1 -5 } { 3 -2 } translate ] unit-test\r
+\r
+! ------------------------------------------------------------\r
+! transform\r
+[ { -1 -1 -5 21.0 } ] [ { -1 -1 -5 21 }\r
+ { { 1 0 0 }\r
+ { 0 1 0 }\r
+ { 0 0 1 }\r
+ } transform \r
+] unit-test\r
+\r
+! ------------------------------------------------------------\r
+! compare-nleft-to-identity-matrix\r
+[ t ] [ \r
+ { \r
+ { 1 0 0 1232 } \r
+ { 0 1 0 0 321 } \r
+ { 0 0 1 0 } } \r
+ 3 compare-nleft-to-identity-matrix \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 1 0 0 } { 0 1 0 } { 0 0 0 } } \r
+ 3 compare-nleft-to-identity-matrix \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 2 0 0 } { 0 1 0 } { 0 0 1 } } \r
+ 3 compare-nleft-to-identity-matrix \r
+] unit-test\r
+! ------------------------------------------------------------\r
+[ t ] [ \r
+ { { 1 0 0 }\r
+ { 0 1 0 }\r
+ { 0 0 1 } } 3 valid-solution? \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 1 0 0 1 }\r
+ { 0 0 0 1 }\r
+ { 0 0 1 0 } } 3 valid-solution? \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 1 0 0 1 }\r
+ { 0 0 0 1 } } 3 valid-solution? \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 1 0 0 1 }\r
+ { 0 0 0 1 }\r
+ { 0 0 1 0 } } 2 valid-solution? \r
+] unit-test\r
+\r
+! ------------------------------------------------------------\r
+[ 3 ] [ { 1 2 3 } last ] unit-test \r
+\r
+[ { 1 2 5 } ] [ { 1 2 3 } dup [ 2 + ] change-last ] unit-test \r
+\r
+! ------------------------------------------------------------\r
+! position-point \r
+[ 0 ] [ \r
+ { 1 -1 -5 } { 2 7 } position-point \r
+] unit-test\r
+\r
+! ------------------------------------------------------------\r
+\r
+! transform\r
+! TODO construire un exemple\r
+\r
+\r
+! ------------------------------------------------------------\r
+! slice-solid \r
+\r
+! ------------------------------------------------------------\r
+! solve-equation \r
+! deux cas de tests, avec solution et sans solution\r
+\r
+[ { 2 7 } ] \r
+[ { { 1 -1 -5 } { 1 2 16 } } intersect-hyperplanes ] \r
+unit-test\r
+\r
+[ f ] \r
+[ { { 1 -1 -5 } { 1 2 16 } { -1 -1 -21 } } intersect-hyperplanes ]\r
+unit-test\r
+\r
+[ f ] \r
+[ { { 1 0 -5 } { 1 0 16 } } intersect-hyperplanes ]\r
+unit-test\r
+\r
+! ------------------------------------------------------------\r
+! point-inside-halfspace\r
+[ t ] [ { 1 -1 -5 } { 0 0 } point-inside-halfspace? ] \r
+unit-test\r
+[ f ] [ { 1 -1 -5 } { 8 13 } point-inside-halfspace? ] \r
+unit-test\r
+[ t ] [ { 1 -1 -5 } { 8 13 } point-inside-or-on-halfspace? ] \r
+unit-test\r
+\r
+\r
+! ------------------------------\r
+! order solid\r
+\r
+[ 1 ] [ 0 >pv solid1 solid2 order-solid ] unit-test\r
+[ -1 ] [ 0 >pv solid2 solid1 order-solid ] unit-test\r
+[ f ] [ 1 >pv solid1 solid2 order-solid ] unit-test\r
+[ f ] [ 1 >pv solid2 solid1 order-solid ] unit-test\r
+\r
+\r
+! clip-solid\r
+[ { { 13 15 } { 15 13 } { 13 13 } } ]\r
+ [ 0 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
+\r
+solid1 corners>> '[ _ ]\r
+ [ 0 >pv solid1 solid1 clip-solid first corners>> ] unit-test\r
+\r
+solid1 corners>> '[ _ ]\r
+ [ 0 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
+\r
+solid1 corners>> '[ _ ]\r
+ [ 1 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
+solid2 corners>> '[ _ ]\r
+ [ 1 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
+\r
+!\r
+[\r
+ {\r
+ { { 13 15 } { 15 13 } { 13 13 } }\r
+ { { 16 17 } { 16 13 } { 36 17 } { 36 13 } }\r
+ { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
+ }\r
+] [ 0 >pv solid2 solid3 2array \r
+ solid1 (solids-silhouette-subtract) \r
+ [ corners>> ] map\r
+ ] unit-test\r
+\r
+\r
+[\r
+{\r
+ { { 8 13 } { 2 7 } { 12 9 } { 12 2 } }\r
+ { { 13 15 } { 15 13 } { 13 13 } }\r
+ { { 16 17 } { 16 15 } { 36 17 } { 36 15 } }\r
+ { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
+}\r
+] [ \r
+ 0 >pv <space> solid1 suffix-solids \r
+ solid2 suffix-solids \r
+ solid3 suffix-solids\r
+ remove-hidden-solids\r
+ solids>> [ corners>> ] map\r
+] unit-test\r
+\r
+! { }\r
+! { }\r
+! <light> { 0.2 0.3 0.4 } >>color { 1 -1 1 } >>direction suffix\r
+! <light> { 0.4 0.3 0.1 } >>color { -1 -1 -1 } >>direction suffix\r
+! suffix \r
+! { 0.1 0.1 0.1 } suffix ! ambient color\r
+! { 0.23 0.32 0.17 } suffix ! solid color\r
+! solid3 faces>> first \r
+\r
+! enlight-projection\r
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors\r
+arrays \r
+assocs\r
+combinators\r
+kernel \r
+fry\r
+math \r
+math.constants\r
+math.functions\r
+math.libm\r
+math.order\r
+math.vectors \r
+math.matrices \r
+math.parser\r
+namespaces\r
+prettyprint\r
+sequences\r
+sequences.deep\r
+sets\r
+slots\r
+sorting\r
+tools.time\r
+vars\r
+continuations\r
+words\r
+opengl\r
+opengl.gl\r
+colors\r
+adsoda.solution2\r
+adsoda.combinators\r
+opengl.demo-support\r
+values\r
+tools.walker\r
+;\r
+\r
+IN: adsoda\r
+\r
+DEFER: combinations\r
+VAR: pv\r
+\r
+\r
+! ---------------------------------------------------------------------\r
+! global values\r
+VALUE: remove-hidden-solids?\r
+VALUE: VERY-SMALL-NUM\r
+VALUE: ZERO-VALUE\r
+VALUE: MAX-FACE-PER-CORNER\r
+\r
+t to: remove-hidden-solids?\r
+0.0000001 to: VERY-SMALL-NUM\r
+0.0000001 to: ZERO-VALUE\r
+4 to: MAX-FACE-PER-CORNER\r
+! ---------------------------------------------------------------------\r
+! sequence complement\r
+\r
+: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
+\r
+: dimension ( array -- x ) length 1- ; inline \r
+: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline\r
+: change-last ( seq quot -- ) [ [ dimension ] keep ] dip change-nth ; \r
+\r
+! --------------------------------------------------------------\r
+! light\r
+! --------------------------------------------------------------\r
+\r
+TUPLE: light name { direction array } color ;\r
+: <light> ( -- tuple ) light new ;\r
+\r
+! -----------------------------------------------------------------------\r
+! halfspace manipulation\r
+! -----------------------------------------------------------------------\r
+\r
+: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;\r
+: translate ( u v -- w ) dupd v* sum constant+ ; \r
+\r
+: transform ( u matrix -- w )\r
+ [ swap m.v ] 2keep ! compute new normal vector \r
+ [\r
+ [ [ abs ZERO-VALUE > ] find ] keep ! find a point on the frontier\r
+ ! be sure it's not null vector\r
+ last ! get constant\r
+ swap /f neg swap ! intercept value\r
+ ] dip \r
+ flip \r
+ nth\r
+ [ * ] with map ! apply intercep value\r
+ over v*\r
+ sum neg\r
+ suffix ! add value as constant at the end of equation\r
+;\r
+\r
+: position-point ( halfspace v -- x ) \r
+ -1 suffix v* sum ; inline\r
+: point-inside-halfspace? ( halfspace v -- ? ) \r
+ position-point VERY-SMALL-NUM > ; \r
+: point-inside-or-on-halfspace? ( halfspace v -- ? ) \r
+ position-point VERY-SMALL-NUM neg > ;\r
+: project-vector ( seq -- seq ) pv> [ head ] [ 1+ tail ] 2bi append ; \r
+: get-intersection ( matrice -- seq ) [ 1 tail* ] map flip first ;\r
+\r
+: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;\r
+\r
+: compare-nleft-to-identity-matrix ( seq n -- ? ) \r
+ [ [ head ] curry map ] keep identity-matrix m- \r
+ flatten\r
+ [ abs ZERO-VALUE < ] all?\r
+;\r
+\r
+: valid-solution? ( matrice n -- ? )\r
+ islenght=?\r
+ [ compare-nleft-to-identity-matrix ] \r
+ [ 2drop f ] if ; inline\r
+\r
+: intersect-hyperplanes ( matrice -- seq )\r
+ [ solution dup ] [ first dimension ] bi\r
+ valid-solution? [ get-intersection ] [ drop f ] if ;\r
+\r
+! --------------------------------------------------------------\r
+! faces\r
+! --------------------------------------------------------------\r
+\r
+TUPLE: face { halfspace array } touching-corners adjacent-faces ;\r
+: <face> ( v -- tuple ) face new swap >>halfspace ;\r
+: flip-face ( face -- face ) [ vneg ] change-halfspace ;\r
+: erase-face-touching-corners ( face -- face ) f >>touching-corners ;\r
+: erase-face-adjacent-faces ( face -- face ) f >>adjacent-faces ;\r
+: faces-intersection ( faces -- v ) \r
+ [ halfspace>> ] map intersect-hyperplanes ;\r
+: face-translate ( face v -- face ) \r
+ [ translate ] curry change-halfspace ; inline\r
+: face-transform ( face m -- face )\r
+ [ transform ] curry change-halfspace ; inline\r
+: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;\r
+: backface? ( face -- face ? ) dup face-orientation 0 <= ;\r
+: pv-factor ( face -- f face ) \r
+ halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline\r
+: suffix-touching-corner ( face corner -- face ) \r
+ [ suffix ] curry change-touching-corners ; inline\r
+: real-face? ( face -- ? )\r
+ [ touching-corners>> length ] [ halfspace>> dimension ] bi >= ;\r
+\r
+: (add-to-adjacent-faces) ( face face -- face )\r
+ over adjacent-faces>> 2dup member?\r
+ [ 2drop ] [ swap suffix >>adjacent-faces ] if ;\r
+\r
+: add-to-adjacent-faces ( face face -- face )\r
+ 2dup = [ drop ] [ (add-to-adjacent-faces) ] if ;\r
+\r
+: update-adjacent-faces ( faces corner -- )\r
+ '[ [ _ suffix-touching-corner drop ] each ] keep \r
+ 2 among [ \r
+ [ first ] keep second \r
+ [ add-to-adjacent-faces drop ] 2keep \r
+ swap add-to-adjacent-faces drop \r
+ ] each ; inline\r
+\r
+: face-project-dim ( face -- x ) halfspace>> length 2 - ;\r
+\r
+: apply-light ( color light normal -- u )\r
+ over direction>> v. \r
+ neg dup 0 > \r
+ [ \r
+ [ color>> swap ] dip \r
+ [ * ] curry map v+ \r
+ [ 1 min ] map \r
+ ] \r
+ [ 2drop ] \r
+ if\r
+;\r
+\r
+: enlight-projection ( array face -- color )\r
+ ! array = lights + ambient color\r
+ [ [ third ] [ second ] [ first ] tri ]\r
+ [ halfspace>> project-vector normalize ] bi*\r
+ [ apply-light ] curry each\r
+ v*\r
+;\r
+\r
+: (intersection-into-face) ( face-init face-adja quot -- face )\r
+ [\r
+ [ [ pv-factor ] bi@ \r
+ roll \r
+ [ map ] 2bi@\r
+ v-\r
+ ] 2keep\r
+ [ touching-corners>> ] bi@\r
+ [ swap [ = ] curry find nip f = ] curry find nip\r
+ ] dip over\r
+ [\r
+ call\r
+ dupd\r
+ point-inside-halfspace? [ vneg ] unless \r
+ <face> \r
+ ] [ 3drop f ] if \r
+ ; inline\r
+\r
+: intersection-into-face ( face-init face-adja -- face )\r
+ [ [ project-vector ] bi@ ] (intersection-into-face) ;\r
+\r
+: intersection-into-silhouette-face ( face-init face-adja -- face )\r
+ [ ] (intersection-into-face) ;\r
+\r
+: intersections-into-faces ( face -- faces )\r
+ clone dup adjacent-faces>> [ intersection-into-face ] with map \r
+ [ ] filter ;\r
+\r
+: (face-silhouette) ( face -- faces )\r
+ clone dup adjacent-faces>>\r
+ [ backface?\r
+ [ intersection-into-silhouette-face ] [ 2drop f ] if \r
+ ] with map \r
+ [ ] filter\r
+; inline\r
+\r
+: face-silhouette ( face -- faces ) \r
+ backface? [ drop f ] [ (face-silhouette) ] if ;\r
+\r
+! --------------------------------\r
+! solid\r
+! --------------------------------------------------------------\r
+TUPLE: solid dimension silhouettes faces corners adjacencies-valid color name ;\r
+\r
+: <solid> ( -- tuple ) solid new ;\r
+\r
+: suffix-silhouettes ( solid silhouette -- solid ) \r
+ [ suffix ] curry change-silhouettes ;\r
+\r
+: suffix-face ( solid face -- solid ) [ suffix ] curry change-faces ;\r
+\r
+: suffix-corner ( solid corner -- solid ) [ suffix ] curry change-corners ; \r
+\r
+: erase-solid-corners ( solid -- solid ) f >>corners ;\r
+\r
+: erase-silhouettes ( solid -- solid ) dup dimension>> f <array> >>silhouettes ;\r
+\r
+: filter-real-faces ( solid -- solid ) [ [ real-face? ] filter ] change-faces ;\r
+\r
+: initiate-solid-from-face ( face -- solid ) \r
+ face-project-dim <solid> swap >>dimension ;\r
+\r
+: erase-old-adjacencies ( solid -- solid )\r
+ erase-solid-corners\r
+ [ dup [ erase-face-touching-corners erase-face-adjacent-faces drop ] each ]\r
+ change-faces ;\r
+\r
+: point-inside-or-on-face? ( face v -- ? ) \r
+ [ halfspace>> ] dip point-inside-or-on-halfspace? ;\r
+\r
+: point-inside-face? ( face v -- ? ) \r
+ [ halfspace>> ] dip point-inside-halfspace? ;\r
+\r
+: point-inside-solid? ( solid point -- ? )\r
+ [ faces>> ] dip [ point-inside-face? ] curry all? ; inline\r
+\r
+: point-inside-or-on-solid? ( solid point -- ? )\r
+ [ faces>> ] dip [ point-inside-or-on-face? ] curry all? ; inline\r
+\r
+: unvalid-adjacencies ( solid -- solid ) \r
+ erase-old-adjacencies f >>adjacencies-valid erase-silhouettes ;\r
+\r
+: add-face ( solid face -- solid ) \r
+ suffix-face unvalid-adjacencies ; \r
+\r
+: cut-solid ( solid halfspace -- solid ) <face> add-face ; \r
+\r
+: slice-solid ( solid face -- solid1 solid2 )\r
+ [ [ clone ] bi@ flip-face add-face \r
+ [ "/outer/" append ] change-name ] 2keep\r
+ add-face [ "/inner/" append ] change-name ;\r
+\r
+! -------------\r
+\r
+\r
+: add-silhouette ( solid -- solid )\r
+ dup \r
+ ! find-adjacencies \r
+ faces>> { } \r
+ [ face-silhouette append ] reduce\r
+ [ ] filter \r
+ <solid> \r
+ swap >>faces\r
+ over dimension>> >>dimension \r
+ over name>> " silhouette " append \r
+ pv> number>string append \r
+ >>name\r
+ ! ensure-adjacencies\r
+ suffix-silhouettes ; inline\r
+\r
+: find-silhouettes ( solid -- solid )\r
+ { } >>silhouettes \r
+ dup dimension>> [ [ add-silhouette ] with-pv ] each ;\r
+\r
+: ensure-silhouettes ( solid -- solid )\r
+ dup silhouettes>> [ f = ] all?\r
+ [ find-silhouettes ] when ; \r
+\r
+! ------------\r
+\r
+: corner-added? ( solid corner -- ? ) \r
+ ! add corner to solid if it is inside solid\r
+ [ ] \r
+ [ point-inside-or-on-solid? ] \r
+ [ swap corners>> member? not ] \r
+ 2tri and\r
+ [ suffix-corner drop t ] [ 2drop f ] if ;\r
+\r
+: process-corner ( solid faces corner -- )\r
+ swapd \r
+ [ corner-added? ] keep swap ! test if corner is inside solid\r
+ [ update-adjacent-faces ] \r
+ [ 2drop ]\r
+ if ;\r
+\r
+: compute-intersection ( solid faces -- )\r
+ dup faces-intersection\r
+ dup f = [ 3drop ] [ process-corner ] if ;\r
+\r
+: test-faces-combinaisons ( solid n -- )\r
+ [ dup faces>> ] dip among \r
+ [ compute-intersection ] with each ;\r
+\r
+: compute-adjacencies ( solid -- solid )\r
+ dup dimension>> [ >= ] curry \r
+ [ keep swap ] curry MAX-FACE-PER-CORNER swap\r
+ [ [ test-faces-combinaisons ] 2keep 1- ] [ ] while drop ;\r
+\r
+: find-adjacencies ( solid -- solid ) \r
+ erase-old-adjacencies \r
+ compute-adjacencies\r
+ filter-real-faces \r
+ t >>adjacencies-valid ;\r
+\r
+: ensure-adjacencies ( solid -- solid ) \r
+ dup adjacencies-valid>> \r
+ [ find-adjacencies ] unless \r
+ ensure-silhouettes\r
+ ;\r
+\r
+: (non-empty-solid?) ( solid -- ? ) [ dimension>> ] [ corners>> length ] bi < ;\r
+: non-empty-solid? ( solid -- ? ) ensure-adjacencies (non-empty-solid?) ;\r
+\r
+: compare-corners-roughly ( corner corner -- ? )\r
+ 2drop t ;\r
+! : remove-inner-faces ( -- ) ;\r
+: face-project ( array face -- seq )\r
+ backface? \r
+ [ 2drop f ]\r
+ [ [ enlight-projection ] \r
+ [ initiate-solid-from-face ]\r
+ [ intersections-into-faces ] tri\r
+ >>faces\r
+ swap >>color \r
+ ] if ;\r
+\r
+: solid-project ( lights ambient solid -- solids )\r
+ ensure-adjacencies\r
+ [ color>> ] [ faces>> ] bi [ 3array ] dip\r
+ [ face-project ] with map \r
+ [ ] filter \r
+ [ ensure-adjacencies ] map\r
+;\r
+\r
+: (solid-move) ( solid v move -- solid ) \r
+ curry [ map ] curry \r
+ [ dup faces>> ] dip call drop \r
+ unvalid-adjacencies ; inline\r
+\r
+: solid-translate ( solid v -- solid ) [ face-translate ] (solid-move) ; \r
+: solid-transform ( solid m -- solid ) [ face-transform ] (solid-move) ; \r
+\r
+: find-corner-in-silhouette ( s1 s2 -- elt bool )\r
+ pv> swap silhouettes>> nth \r
+ swap corners>>\r
+ [ point-inside-solid? ] with find swap ;\r
+\r
+: valid-face-for-order ( solid point -- face )\r
+ [ point-inside-face? not ] \r
+ [ drop face-orientation 0 = not ] 2bi and ;\r
+\r
+: check-orientation ( s1 s2 pt -- int )\r
+ [ nip faces>> ] dip\r
+ [ valid-face-for-order ] curry find swap\r
+ [ face-orientation ] [ drop f ] if ;\r
+\r
+: (order-solid) ( s1 s2 -- int )\r
+ 2dup find-corner-in-silhouette\r
+ [ check-orientation ] [ 3drop f ] if ;\r
+\r
+: order-solid ( solid solid -- i ) \r
+ 2dup (order-solid)\r
+ [ 2nip ]\r
+ [ swap (order-solid)\r
+ [ neg ] [ f ] if*\r
+ ] if* ;\r
+\r
+: subtract ( solid1 solid2 -- solids )\r
+ faces>> swap clone ensure-adjacencies ensure-silhouettes \r
+ [ swap slice-solid drop ] curry map\r
+ [ non-empty-solid? ] filter\r
+ [ ensure-adjacencies ] map\r
+; inline\r
+\r
+! --------------------------------------------------------------\r
+! space \r
+! --------------------------------------------------------------\r
+TUPLE: space name dimension solids ambient-color lights ;\r
+: <space> ( -- space ) space new ;\r
+: suffix-solids ( space solid -- space ) [ suffix ] curry change-solids ; inline\r
+: suffix-lights ( space light -- space ) [ suffix ] curry change-lights ; inline\r
+: clear-space-solids ( space -- space ) f >>solids ;\r
+\r
+: space-ensure-solids ( space -- space ) \r
+ [ [ ensure-adjacencies ] map ] change-solids ;\r
+: eliminate-empty-solids ( space -- space ) \r
+ [ [ non-empty-solid? ] filter ] change-solids ;\r
+\r
+: projected-space ( space solids -- space ) \r
+ swap dimension>> 1- <space> swap >>dimension swap >>solids ;\r
+\r
+: get-silhouette ( solid -- silhouette ) silhouettes>> pv> swap nth ;\r
+: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;\r
+\r
+: space-apply ( space m quot -- space ) \r
+ curry [ map ] curry [ dup solids>> ] dip\r
+ [ call ] [ drop ] recover drop ;\r
+: space-transform ( space m -- space ) [ solid-transform ] space-apply ;\r
+: space-translate ( space v -- space ) [ solid-translate ] space-apply ; \r
+\r
+: describe-space ( space -- ) \r
+ solids>> [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;\r
+\r
+: clip-solid ( solid solid -- solids )\r
+ [ ]\r
+ [ solid= not ]\r
+ [ order-solid -1 = ] 2tri \r
+ and\r
+ [ get-silhouette subtract ] \r
+ [ drop 1array ] \r
+ if \r
+ \r
+ ;\r
+\r
+: (solids-silhouette-subtract) ( solids solid -- solids ) \r
+ [ clip-solid append ] curry { } -rot each ; inline\r
+\r
+: solids-silhouette-subtract ( solids i solid -- solids )\r
+! solids is an array of 1 solid arrays\r
+ [ (solids-silhouette-subtract) ] curry map-but \r
+; inline \r
+\r
+: remove-hidden-solids ( space -- space ) \r
+! We must include each solid in a sequence because during substration \r
+! a solid can be divided in more than on solid\r
+ [ \r
+ [ [ 1array ] map ] \r
+ [ length ] \r
+ [ ] \r
+ tri \r
+ [ solids-silhouette-subtract ] 2each\r
+ { } [ append ] reduce \r
+ ] change-solids\r
+ eliminate-empty-solids ! TODO include into change-solids\r
+;\r
+\r
+: space-project ( space i -- space )\r
+ [\r
+ [ clone \r
+ remove-hidden-solids? [ remove-hidden-solids ] when\r
+ dup \r
+ [ solids>> ] \r
+ [ lights>> ] \r
+ [ ambient-color>> ] tri \r
+ [ rot solid-project ] 2curry \r
+ map \r
+ [ append ] { } -rot each \r
+ ! TODO project lights\r
+ projected-space \r
+ ! remove-inner-faces \r
+ ! \r
+ eliminate-empty-solids\r
+ ] with-pv \r
+ ] [ 3drop <space> ] recover\r
+ ; inline\r
+\r
+: middle-of-space ( space -- point )\r
+ solids>> [ corners>> ] map concat\r
+ [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n\r
+;\r
+\r
+! --------------------------------------------------------------\r
+! 3D rendering\r
+! --------------------------------------------------------------\r
+\r
+: face-reference ( face -- halfspace point vect )\r
+ [ halfspace>> ] \r
+ [ touching-corners>> first ] \r
+ [ touching-corners>> second ] tri \r
+ over v-\r
+;\r
+\r
+: theta ( v halfspace point vect -- v x )\r
+ [ [ over ] dip v- ] dip \r
+ [ cross dup norm >float ]\r
+ [ v. >float ] \r
+ 2bi \r
+ fatan2\r
+ -rot v. \r
+ 0 < [ neg ] when\r
+;\r
+\r
+: ordered-face-points ( face -- corners ) \r
+ [ touching-corners>> 1 head ] \r
+ [ touching-corners>> 1 tail ] \r
+ [ face-reference [ theta ] 3curry ] tri\r
+ { } map>assoc sort-values keys \r
+ append\r
+ ; inline\r
+\r
+: point->GL ( point -- ) gl-vertex ;\r
+: points->GL ( array -- ) do-cycle [ point->GL ] each ;\r
+\r
+: face->GL ( face color -- )\r
+ [ ordered-face-points ] dip\r
+ [ first3 1.0 glColor4d GL_POLYGON [ [ point->GL ] each ] do-state ] curry\r
+ [ 0 0 0 1 glColor4d GL_LINE_LOOP [ [ point->GL ] each ] do-state ]\r
+ bi\r
+ ; inline\r
+\r
+: solid->GL ( solid -- ) \r
+ [ faces>> ] \r
+ [ color>> ] bi\r
+ [ face->GL ] curry each ; inline\r
+\r
+: space->GL ( space -- )\r
+ solids>>\r
+ [ solid->GL ] each ;\r
+\r
+\r
+\r
+\r
+\r
--- /dev/null
+! : init-4D-demo ( -- space )\r
+! OK\r
+! espace de dimension 4 et de couleur 0,3 0.3 0.3\r
+<space> \r
+ 4 >>dimension\r
+ { 0.3 0.3 0.3 } >>ambient-color\r
+ { 100 150 100 150 100 150 100 150 } "4cube1" 4cube suffix-solids\r
+ { 160 180 160 180 160 180 160 180 } "4cube2" 4cube suffix-solids\r
+ <light>\r
+ { -100 -100 -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+! ;\r
+! : init-3D-demo ( -- space )\r
+! OK\r
+! espace de dimension 4 et de couleur 0,3 0.3 0.3\r
+<space> \r
+ 3 >>dimension\r
+ { 0.3 0.3 0.3 } >>ambient-color\r
+ { 100 150 100 150 100 150 } "3cube1" 3cube suffix-solids\r
+ ! { -150 -10 -150 -10 -150 -10 -150 -10 } "4cube2" 4cube suffix-solids\r
+ <light>\r
+ { -100 -100 -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+! ;\r
+\r
+\r
+: s1 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "s1" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+;\r
+: solid1 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid1" >>name\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+: solid2 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid2" >>name\r
+ { -1 1 -10 } cut-solid \r
+ { -1 -1 -28 } cut-solid \r
+ { 1 0 13 } cut-solid \r
+ ! { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid3 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid3" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 16 } cut-solid \r
+ { -1 0 -36 } cut-solid \r
+ { 0 1 1 } cut-solid \r
+ { 0 -1 -17 } cut-solid \r
+ ! { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+\r
+;\r
+\r
+: solid4 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid4" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 21 } cut-solid \r
+ { -1 0 -36 } cut-solid \r
+ { 0 1 1 } cut-solid \r
+ { 0 -1 -17 } cut-solid \r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid5 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid5" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 6 } cut-solid \r
+ { -1 0 -17 } cut-solid \r
+ { 0 1 17 } cut-solid \r
+ { 0 -1 -19 } cut-solid \r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid7 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid7" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 38 } cut-solid \r
+ { 1 -5 -66 } cut-solid \r
+ { -2 1 -75 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid6s ( -- seq )\r
+ solid3 clone solid2 clone subtract\r
+;\r
+\r
+: space1 ( -- space )\r
+ <space>\r
+ 2 >>dimension\r
+ ! solid3 suffix-solids\r
+ solid1 suffix-solids\r
+ solid2 suffix-solids\r
+ ! solid6s [ suffix-solids ] each \r
+ solid4 suffix-solids\r
+ ! solid5 suffix-solids\r
+ solid7 suffix-solids\r
+ { 1 1 1 } >>ambient-color\r
+ <light>\r
+ { -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+;\r
+\r
+: space2 ( -- space )\r
+ <space>\r
+ 4 >>dimension\r
+ ! 4cube suffix-solids\r
+ { 1 1 1 } >>ambient-color\r
+ <light>\r
+ { -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+\r
+ ;\r
+\r
--- /dev/null
+Jeff Bigot\r
+Greg Ferrar
\ No newline at end of file
--- /dev/null
+JF Bigot, after Greg Ferrar
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays help.markup help.syntax kernel sequences ;
+IN: adsoda.combinators
+
+HELP: among
+{ $values
+ { "array" array } { "n" null }
+ { "array" array }
+}
+{ $description "returns an array containings every possibilities of n choices among a given sequence" } ;
+
+HELP: columnize
+{ $values
+ { "array" array }
+ { "array" array }
+}
+{ $description "flip a sequence into a sequence of 1 element sequences" } ;
+
+HELP: concat-nth
+{ $values
+ { "seq1" sequence } { "seq2" sequence }
+ { "seq" sequence }
+}
+{ $description "merges 2 sequences of sequences appending corresponding elements" } ;
+
+HELP: do-cycle
+{ $values
+ { "array" array }
+ { "array" array }
+}
+{ $description "Copy the first element at the end of the sequence in order to close the cycle." } ;
+
+
+ARTICLE: "adsoda.combinators" "adsoda.combinators"
+{ $vocab-link "adsoda.combinators" }
+;
+
+ABOUT: "adsoda.combinators"
--- /dev/null
+USING: adsoda.combinators\r
+sequences\r
+ tools.test \r
+ ;\r
+\r
+IN: adsoda.combinators.tests\r
+\r
+\r
+[ { "atoto" "b" "ctoto" } ] [ { "a" "b" "c" } 1 [ "toto" append ] map-but ] \r
+ unit-test\r
+\r
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel arrays sequences fry math combinators ;\r
+\r
+IN: adsoda.combinators\r
+\r
+! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ; \r
+\r
+! : prefix-each [ prefix ] curry map ; inline\r
+\r
+! : combinations ( seq n -- seqs )\r
+! {\r
+! { [ dup 0 = ] [ 2drop { { } } ] }\r
+! { [ over empty? ] [ 2drop { } ] }\r
+! { [ t ] [ \r
+! [ [ 1- (combinations) ] [ drop first ] 2bi prefix-each ]\r
+! [ (combinations) ] 2bi append\r
+! ] }\r
+! } cond ;\r
+\r
+: columnize ( array -- array ) [ 1array ] map ; inline\r
+\r
+: among ( array n -- array )\r
+ 2dup swap length \r
+ {\r
+ { [ over 1 = ] [ 3drop columnize ] }\r
+ { [ over 0 = ] [ 2drop 2drop { } ] }\r
+ { [ 2dup < ] [ 2drop [ 1 cut ] dip \r
+ [ 1- among [ append ] with map ] \r
+ [ among append ] 2bi\r
+ ] }\r
+ { [ 2dup = ] [ 3drop 1array ] }\r
+ { [ 2dup > ] [ 2drop 2drop { } ] } \r
+ } cond\r
+;\r
+\r
+: concat-nth ( seq1 seq2 -- seq ) [ nth append ] curry map-index ;\r
+\r
+: do-cycle ( array -- array ) dup first suffix ;\r
+\r
+: map-but ( seq i quot -- seq )\r
+ ! quot : ( seq x -- seq )\r
+ '[ _ = [ @ ] unless ] map-index ; inline\r
+\r
--- /dev/null
+USING: kernel\r
+sequences\r
+namespaces\r
+\r
+math\r
+math.vectors\r
+math.matrices\r
+;\r
+IN: adsoda.solution2\r
+\r
+! -------------------\r
+! correctif solution\r
+! ---------------\r
+SYMBOL: matrix\r
+: MIN-VAL-adsoda ( -- x ) 0.00000001\r
+! 0.000000000001 \r
+;\r
+\r
+: zero? ( x -- ? ) \r
+ abs MIN-VAL-adsoda <\r
+;\r
+\r
+! [ number>string string>number ] map \r
+\r
+: with-matrix ( matrix quot -- )\r
+ [ swap matrix set call matrix get ] with-scope ; inline\r
+\r
+: nth-row ( row# -- seq ) matrix get nth ;\r
+\r
+: change-row ( row# quot -- seq ) ! row# quot -- | quot: seq -- seq )\r
+ matrix get swap change-nth ; inline\r
+\r
+: exchange-rows ( row# row# -- ) matrix get exchange ;\r
+\r
+: rows ( -- n ) matrix get length ;\r
+\r
+: cols ( -- n ) 0 nth-row length ;\r
+\r
+: skip ( i seq quot -- n )\r
+ over [ find-from drop ] dip length or ; inline\r
+\r
+: first-col ( row# -- n )\r
+ #! First non-zero column\r
+ 0 swap nth-row [ zero? not ] skip ;\r
+\r
+: clear-scale ( col# pivot-row i-row -- n )\r
+ [ over ] dip nth dup zero? [\r
+ 3drop 0\r
+ ] [\r
+ [ nth dup zero? ] dip swap [\r
+ 2drop 0\r
+ ] [\r
+ swap / neg\r
+ ] if\r
+ ] if ;\r
+\r
+: (clear-col) ( col# pivot-row i -- )\r
+ [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;\r
+\r
+: rows-from ( row# -- slice )\r
+ rows dup <slice> ;\r
+\r
+: clear-col ( col# row# rows -- )\r
+ [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;\r
+\r
+: do-row ( exchange-with row# -- )\r
+ [ exchange-rows ] keep\r
+ [ first-col ] keep\r
+ dup 1+ rows-from clear-col ;\r
+\r
+: find-row ( row# quot -- i elt )\r
+ [ rows-from ] dip find ; inline\r
+\r
+: pivot-row ( col# row# -- n )\r
+ [ dupd nth-row nth zero? not ] find-row 2nip ;\r
+\r
+: (echelon) ( col# row# -- )\r
+ over cols < over rows < and [\r
+ 2dup pivot-row [ over do-row 1+ ] when*\r
+ [ 1+ ] dip (echelon)\r
+ ] [\r
+ 2drop\r
+ ] if ;\r
+\r
+: echelon ( matrix -- matrix' )\r
+ [ 0 0 (echelon) ] with-matrix ;\r
+\r
+: nonzero-rows ( matrix -- matrix' )\r
+ [ [ zero? ] all? not ] filter ;\r
+\r
+: null/rank ( matrix -- null rank )\r
+ echelon dup length swap nonzero-rows length [ - ] keep ;\r
+\r
+: leading ( seq -- n elt ) [ zero? not ] find ;\r
+\r
+: reduced ( matrix' -- matrix'' )\r
+ [\r
+ rows <reversed> [\r
+ dup nth-row leading drop\r
+ dup [ swap dup clear-col ] [ 2drop ] if\r
+ ] each\r
+ ] with-matrix ;\r
+\r
+: basis-vector ( row col# -- )\r
+ [ clone ] dip\r
+ [ swap nth neg recip ] 2keep\r
+ [ 0 spin set-nth ] 2keep\r
+ [ n*v ] dip\r
+ matrix get set-nth ;\r
+\r
+: nullspace ( matrix -- seq )\r
+ echelon reduced dup empty? [\r
+ dup first length identity-matrix [\r
+ [\r
+ dup leading drop\r
+ dup [ basis-vector ] [ 2drop ] if\r
+ ] each\r
+ ] with-matrix flip nonzero-rows\r
+ ] unless ;\r
+\r
+: 1-pivots ( matrix -- matrix )\r
+ [ dup leading nip [ recip v*n ] when* ] map ;\r
+\r
+: solution ( matrix -- matrix )\r
+ echelon nonzero-rows reduced 1-pivots ;\r
+\r
--- /dev/null
+A modification of solution to approximate solutions
\ No newline at end of file
--- /dev/null
+ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm
\ No newline at end of file
--- /dev/null
+adsoda 4D viewer
\ No newline at end of file
--- /dev/null
+Jeff Bigot
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays help.markup help.syntax kernel sequences ;
+IN: adsoda.tools
+
+HELP: 3cube
+{ $values
+ { "array" "array" } { "name" "name" }
+ { "solid" "solid" }
+}
+{ $description "array : xmin xmax ymin ymax zmin zmax"
+"\n returns a 3D solid with given limits"
+} ;
+
+HELP: 4cube
+{ $values
+ { "array" "array" } { "name" "name" }
+ { "solid" "solid" }
+}
+{ $description "array : xmin xmax ymin ymax zmin zmax wmin wmax"
+"\n returns a 4D solid with given limits"
+} ;
+
+
+HELP: coord-max
+{ $values
+ { "x" null } { "array" array }
+ { "array" array }
+}
+{ $description "" } ;
+
+HELP: coord-min
+{ $values
+ { "x" null } { "array" array }
+ { "array" array }
+}
+{ $description "" } ;
+
+HELP: equation-system-for-normal
+{ $values
+ { "points" "a list of n points" }
+ { "matrix" "matrix" }
+}
+{ $description "From a list of points, return the matrix"
+"to solve in order to find the vector normal to the plan defined by the points" }
+;
+
+HELP: normal-vector
+{ $values
+ { "points" "a list of n points" }
+ { "v" "a vector" }
+}
+{ $description "From a list of points, returns the vector normal to the plan defined by the points"
+"\nWith n points, creates n-1 vectors and then find a vector orthogonal to every others"
+"\n returns { f } if a normal vector can not be found" }
+;
+
+HELP: points-to-hyperplane
+{ $values
+ { "points" "a list of n points" }
+ { "hyperplane" "an hyperplane equation" }
+}
+{ $description "From a list of points, returns the equation of the hyperplan"
+"\n Finds a normal vector and then translate it so that it includes one of the points"
+
+}
+;
+
+ARTICLE: "adsoda.tools" "adsoda.tools"
+{ $vocab-link "adsoda.tools" }
+"\nTools to help in building an " { $vocab-link "adsoda" } "-space"
+;
+
+ABOUT: "adsoda.tools"
+
+
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: \r
+adsoda.tools\r
+tools.test\r
+;\r
+\r
+IN: adsoda.tools.tests\r
+\r
+\r
+ [ { 1 0 } ] [ { { 0 0 } { 0 1 } } normal-vector ] unit-test\r
+ [ f ] [ { { 0 0 } { 0 0 } } normal-vector ] unit-test\r
+\r
+ [ { 1/2 1/2 1+1/2 } ] [ { { 1 2 } { 2 1 } } points-to-hyperplane ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: \r
+kernel\r
+sequences\r
+math\r
+accessors\r
+adsoda\r
+math.vectors \r
+math.matrices\r
+bunny.model\r
+io.encodings.ascii\r
+io.files\r
+sequences.deep\r
+combinators\r
+adsoda.combinators\r
+fry\r
+io.files.temp\r
+grouping\r
+;\r
+\r
+IN: adsoda.tools\r
+\r
+\r
+\r
+\r
+\r
+! ---------------------------------\r
+: coord-min ( x array -- array ) swap suffix ;\r
+: coord-max ( x array -- array ) swap neg suffix ;\r
+\r
+: 4cube ( array name -- solid )\r
+! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
+ <solid> \r
+ 4 >>dimension\r
+ swap >>name\r
+ swap\r
+ { \r
+ [ { 1 0 0 0 } coord-min ] [ { -1 0 0 0 } coord-max ] \r
+ [ { 0 1 0 0 } coord-min ] [ { 0 -1 0 0 } coord-max ]\r
+ [ { 0 0 1 0 } coord-min ] [ { 0 0 -1 0 } coord-max ] \r
+ [ { 0 0 0 1 } coord-min ] [ { 0 0 0 -1 } coord-max ]\r
+ }\r
+ [ curry call ] 2map \r
+ [ cut-solid ] each \r
+ ensure-adjacencies\r
+ \r
+; inline\r
+\r
+: 3cube ( array name -- solid )\r
+! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
+ <solid> \r
+ 3 >>dimension\r
+ swap >>name\r
+ swap\r
+ { \r
+ [ { 1 0 0 } coord-min ] [ { -1 0 0 } coord-max ] \r
+ [ { 0 1 0 } coord-min ] [ { 0 -1 0 } coord-max ]\r
+ [ { 0 0 1 } coord-min ] [ { 0 0 -1 } coord-max ] \r
+ }\r
+ [ curry call ] 2map \r
+ [ cut-solid ] each \r
+ ensure-adjacencies\r
+ \r
+; inline\r
+\r
+\r
+: equation-system-for-normal ( points -- matrix )\r
+ unclip [ v- 0 suffix ] curry map\r
+ dup first [ drop 1 ] map suffix\r
+;\r
+\r
+: normal-vector ( points -- v ) \r
+ equation-system-for-normal\r
+ intersect-hyperplanes ;\r
+\r
+: points-to-hyperplane ( points -- hyperplane )\r
+ [ normal-vector 0 suffix ] [ first ] bi\r
+ translate ;\r
+\r
+: refs-to-points ( points faces -- faces )\r
+ [ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] with map\r
+;\r
+! V{ { 0.1 0.2 } { 1.1 1.3 } } V{ { 1 0 } { 0 1 } }\r
+! V{ { { 1.1 1.3 } { 0.1 0.2 } } { { 0.1 0.2 } { 1.1 1.3 } } }\r
+\r
+: ply-model-path ( -- path )\r
+\r
+! "bun_zipper.ply" \r
+"screw2.ply"\r
+temp-file \r
+;\r
+\r
+: read-bunny-model ( -- v )\r
+ply-model-path ascii [ parse-model ] with-file-reader\r
+\r
+refs-to-points\r
+;\r
+\r
+: 3points-to-normal ( seq -- v )\r
+ unclip [ v- ] curry map first2 cross normalize\r
+;\r
+: 2-faces-to-prism ( seq seq -- seq )\r
+ 2dup\r
+ [ do-cycle 2 clump ] bi@ concat-nth ! 3 faces rectangulaires\r
+ swap prefix\r
+ swap prefix\r
+; \r
+\r
+: Xpoints-to-prisme ( seq height -- cube )\r
+ ! from 3 points gives a list of faces representing a cube of height "height"\r
+ ! and of based on the three points\r
+ ! a face is a group of 3 or mode points. \r
+ [ dup dup 3points-to-normal ] dip \r
+ v*n [ v+ ] curry map ! 2 eme face triangulaire \r
+ 2-faces-to-prism \r
+\r
+! [ dup number? [ 1 + ] when ] deep-map\r
+! dup keep \r
+;\r
+\r
+\r
+: Xpoints-to-plane4D ( seq x y -- 4Dplane )\r
+ ! from 3 points gives a list of faces representing a cube in 4th dim\r
+ ! from x to y (height = y-x)\r
+ ! and of based on the X points\r
+ ! a face is a group of 3 or mode points. \r
+ '[ [ [ _ suffix ] map ] [ [ _ suffix ] map ] bi ] call\r
+ 2-faces-to-prism\r
+;\r
+\r
+: 3pointsfaces-to-3Dsolidfaces ( seq -- seq )\r
+ [ 1 Xpoints-to-prisme [ 100 110 Xpoints-to-plane4D ] map concat ] map \r
+\r
+;\r
+\r
+: test-figure ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+;\r
+\r
--- /dev/null
+
+USING: kernel quotations arrays sequences math math.ranges fry
+ opengl opengl.gl ui.render ui.gadgets.cartesian processing.shapes
+ accessors
+ help.syntax
+ easy-help ;
+
+IN: ui.gadgets.plot
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "ui.gadgets.plot" "Plot Gadget"
+
+Summary:
+
+ A simple gadget for ploting two dimentional functions.
+
+ Use the arrow keys to move around.
+
+ Use 'a' and 'z' keys to zoom in and out. ..
+
+Example:
+
+ <plot> [ sin ] add-function gadget. ..
+
+Example:
+
+ <plot>
+ [ sin ] red function boa add-function
+ [ cos ] blue function boa add-function
+ gadget. ..
+
+;
+
+ABOUT: "ui.gadgets.plot"
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: plot < cartesian functions points ;
+
+: init-plot ( plot -- plot )
+ init-cartesian
+ { } >>functions
+ 100 >>points ;
+
+: <plot> ( -- plot ) plot new init-plot ;
+
+: step-size ( plot -- step-size )
+ [ [ x-max>> ] [ x-min>> ] bi - ] [ points>> ] bi / ;
+
+: plot-range ( plot -- range )
+ [ x-min>> ] [ x-max>> ] [ step-size ] tri <range> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: function function color ;
+
+GENERIC: plot-function ( plot object -- plot )
+
+M: callable plot-function ( plot quotation -- plot )
+ [ dup plot-range ] dip '[ dup @ 2array ] map line-strip ;
+
+M: function plot-function ( plot function -- plot )
+ dup color>> dup [ >stroke-color ] [ drop ] if
+ [ dup plot-range ] dip function>> '[ dup @ 2array ] map line-strip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: plot-functions ( plot -- plot ) dup functions>> [ plot-function ] each ;
+
+: draw-axis ( plot -- plot )
+ dup
+ [ [ x-min>> ] [ drop 0 ] bi 2array ]
+ [ [ x-max>> ] [ drop 0 ] bi 2array ] bi line*
+ dup
+ [ [ drop 0 ] [ y-min>> ] bi 2array ]
+ [ [ drop 0 ] [ y-max>> ] bi 2array ] bi line* ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: ui.gadgets.slate ;
+
+M: plot draw-slate ( plot -- plot )
+ 2 glLineWidth
+ draw-axis
+ plot-functions
+ fill-mode
+ 1 glLineWidth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: add-function ( plot function -- plot )
+ over functions>> swap suffix >>functions ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: x-span ( plot -- span ) [ x-max>> ] [ x-min>> ] bi - ;
+: y-span ( plot -- span ) [ y-max>> ] [ y-min>> ] bi - ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: ui.gestures ui.gadgets ;
+
+: left ( plot -- plot )
+ dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
+ dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max
+ dup relayout-1 ;
+
+: right ( plot -- plot )
+ dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
+ dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max
+ dup relayout-1 ;
+
+: down ( plot -- plot )
+ dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
+ dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max
+ dup relayout-1 ;
+
+: up ( plot -- plot )
+ dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
+ dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max
+ dup relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: zoom-in-horizontal ( plot -- plot )
+ dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
+ dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max ;
+
+: zoom-in-vertical ( plot -- plot )
+ dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
+ dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max ;
+
+: zoom-in ( plot -- plot )
+ zoom-in-horizontal
+ zoom-in-vertical
+ dup relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: zoom-out-horizontal ( plot -- plot )
+ dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
+ dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max ;
+
+: zoom-out-vertical ( plot -- plot )
+ dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
+ dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max ;
+
+: zoom-out ( plot -- plot )
+ zoom-out-horizontal
+ zoom-out-vertical
+ dup relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+plot
+ H{
+ { T{ mouse-enter } [ request-focus ] }
+ { T{ key-down f f "LEFT" } [ left drop ] }
+ { T{ key-down f f "RIGHT" } [ right drop ] }
+ { T{ key-down f f "DOWN" } [ down drop ] }
+ { T{ key-down f f "UP" } [ up drop ] }
+ { T{ key-down f f "a" } [ zoom-in drop ] }
+ { T{ key-down f f "z" } [ zoom-out drop ] }
+ }
+set-gestures
\ No newline at end of file
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces opengl ui.render ui.gadgets accessors
+ help.syntax
+ easy-help ;
+
+IN: ui.gadgets.slate
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "slate" "Slate Gadget"
+
+Summary:
+
+ A gadget with an 'action' slot which should be set to a callable. ..
+
+Example:
+
+ ! Load the right vocabs for the examples
+
+ USING: processing.shapes ui.gadgets.slate ; ..
+
+Example:
+
+ [ { { 10 10 } { 50 30 } { 10 50 } } polygon fill-mode ] <slate>
+ gadget. ..
+
+;
+
+ABOUT: "slate"
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: slate < gadget action pdim graft ungraft ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-slate ( slate -- slate )
+ init-gadget
+ [ ] >>action
+ { 200 200 } >>pdim
+ [ ] >>graft
+ [ ] >>ungraft ;
+
+: <slate> ( action -- slate )
+ slate new
+ init-slate
+ swap >>action ;
+
+M: slate pref-dim* ( slate -- dim ) pdim>> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: combinators arrays sequences math math.geometry
+ opengl.gl ui.gadgets.worlds ;
+
+: screen-y* ( gadget -- loc )
+ {
+ [ find-world height ]
+ [ screen-loc second ]
+ [ height ]
+ }
+ cleave
+ + - ;
+
+: screen-loc* ( gadget -- loc )
+ {
+ [ screen-loc first ]
+ [ screen-y* ]
+ }
+ cleave
+ 2array ;
+
+: setup-viewport ( gadget -- gadget )
+ dup
+ {
+ [ screen-loc* ]
+ [ dim>> ]
+ }
+ cleave
+ gl-viewport ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: default-coordinate-system ( gadget -- gadget )
+ dup
+ {
+ [ drop 0 ]
+ [ width 1 - ]
+ [ height 1 - ]
+ [ drop 0 ]
+ }
+ cleave
+ -1 1
+ glOrtho ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate graft* ( slate -- ) graft>> call ;
+M: slate ungraft* ( slate -- ) ungraft>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: establish-coordinate-system ( gadget -- gadget )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate establish-coordinate-system ( slate -- slate )
+ default-coordinate-system ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: draw-slate ( slate -- slate )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate draw-slate ( slate -- slate ) dup action>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate draw-gadget* ( slate -- )
+
+ GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity
+
+ establish-coordinate-system
+
+ GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity
+
+ setup-viewport
+
+ draw-slate
+
+ GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
+ GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity
+
+ dup
+ find-world
+ ! The world coordinate system is a little wacky:
+ dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
+ setup-viewport
+ drop
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- /dev/null
+
+USING: kernel sequences math math.order
+ ui.gadgets ui.gadgets.tracks ui.gestures accessors fry
+ help.syntax
+ easy-help ;
+
+IN: ui.gadgets.tiling
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "ui.gadgets.tiling" "Tiling Layout Gadgets"
+
+Summary:
+
+ A gadget which tiles it's children.
+
+ A tiling gadget may contain any number of children, but only a
+ fixed number is displayed at one time. How many are displayed can
+ be controlled via Control-[ and Control-].
+
+ The focus may be switched with Alt-Left and Alt-Right.
+
+ The focused child may be moved via Shift-Alt-Left and
+ Shift-Alt-Right. ..
+
+Example:
+
+ <tiling-shelf>
+ "resource:" directory-files
+ [ [ drop ] <bevel-button> tiling-add ]
+ each
+ "Files" open-window ..
+
+;
+
+ABOUT: "ui.gadgets.tiling"
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: tiling < track gadgets tiles first focused ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-tiling ( tiling -- tiling )
+ init-track
+ { 1 0 } >>orientation
+ V{ } clone >>gadgets
+ 2 >>tiles
+ 0 >>first
+ 0 >>focused ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <tiling> ( -- gadget ) tiling new init-tiling ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bounded-subseq ( seq a b -- seq )
+ [ 0 max ] dip
+ pick length [ min ] curry bi@
+ rot
+ subseq ;
+
+: tiling-gadgets-to-map ( tiling -- gadgets )
+ [ gadgets>> ]
+ [ first>> ]
+ [ [ first>> ] [ tiles>> ] bi + ]
+ tri
+ bounded-subseq ;
+
+: tiling-map-gadgets ( tiling -- tiling )
+ dup clear-track
+ dup tiling-gadgets-to-map [ 1 track-add ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: tiling-add ( tiling gadget -- tiling )
+ over gadgets>> push
+ tiling-map-gadgets ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: first-gadget ( tiling -- index ) drop 0 ;
+
+: last-gadget ( tiling -- index ) gadgets>> length 1 - ;
+
+: first-viewable ( tiling -- index ) first>> ;
+
+: last-viewable ( tiling -- index ) [ first>> ] [ tiles>> ] bi + 1 - ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-focused-mapped ( tiling -- tiling )
+
+ dup [ focused>> ] [ first>> ] bi <
+ [ dup first>> 1 - >>first ]
+ [ ]
+ if
+
+ dup [ last-viewable ] [ focused>> ] bi <
+ [ dup first>> 1 + >>first ]
+ [ ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: check-focused-bounds ( tiling -- tiling )
+ dup focused>> 0 max over gadgets>> length 1 - min >>focused ;
+
+: focus-prev ( tiling -- tiling )
+ dup focused>> 1 - >>focused
+ check-focused-bounds
+ make-focused-mapped
+ tiling-map-gadgets
+ dup request-focus ;
+
+: focus-next ( tiling -- tiling )
+ dup focused>> 1 + >>focused
+ check-focused-bounds
+ make-focused-mapped
+ tiling-map-gadgets
+ dup request-focus ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: exchanged! ( seq a b -- )
+ [ 0 max ] bi@
+ pick length 1 - '[ _ min ] bi@
+ rot exchange ;
+
+: move-prev ( tiling -- tiling )
+ dup [ gadgets>> ] [ focused>> 1 - ] [ focused>> ] tri exchanged!
+ focus-prev ;
+
+: move-next ( tiling -- tiling )
+ dup [ gadgets>> ] [ focused>> ] [ focused>> 1 + ] tri exchanged!
+ focus-next ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: add-tile ( tiling -- tiling )
+ dup tiles>> 1 + >>tiles
+ tiling-map-gadgets ;
+
+: del-tile ( tiling -- tiling )
+ dup tiles>> 1 - 1 max >>tiles
+ tiling-map-gadgets ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: tiling focusable-child* ( tiling -- child/t )
+ [ focused>> ] [ gadgets>> ] bi nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: tiling-shelf < tiling ;
+TUPLE: tiling-pile < tiling ;
+
+: <tiling-shelf> ( -- gadget )
+ tiling-shelf new init-tiling { 1 0 } >>orientation ;
+
+: <tiling-pile> ( -- gadget )
+ tiling-pile new init-tiling { 0 1 } >>orientation ;
+
+tiling-shelf
+ H{
+ { T{ key-down f { A+ } "LEFT" } [ focus-prev drop ] }
+ { T{ key-down f { A+ } "RIGHT" } [ focus-next drop ] }
+ { T{ key-down f { S+ A+ } "LEFT" } [ move-prev drop ] }
+ { T{ key-down f { S+ A+ } "RIGHT" } [ move-next drop ] }
+ { T{ key-down f { C+ } "[" } [ del-tile drop ] }
+ { T{ key-down f { C+ } "]" } [ add-tile drop ] }
+ }
+set-gestures
+
+tiling-pile
+ H{
+ { T{ key-down f { A+ } "UP" } [ focus-prev drop ] }
+ { T{ key-down f { A+ } "DOWN" } [ focus-next drop ] }
+ { T{ key-down f { S+ A+ } "UP" } [ move-prev drop ] }
+ { T{ key-down f { S+ A+ } "DOWN" } [ move-next drop ] }
+ { T{ key-down f { C+ } "[" } [ del-tile drop ] }
+ { T{ key-down f { C+ } "]" } [ add-tile drop ] }
+ }
+set-gestures
projects / factor.git / commitdiff