--- /dev/null
-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 "" } ;
+ ! 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
+
- { "gadget" null }
+
+ HELP: menu-3D
+ { $values
- { "gadget" null }
++ { "gadget" "gadget" }
+ }
+ { $description "The menu dedicated to 3D movements of the camera" } ;
+
+ HELP: menu-4D
+ { $values
+
- { "gadget" null }
++ { "gadget" "gadget" }
+ }
+ { $description "The menu dedicated to 4D movements of space" } ;
+
+ HELP: menu-bar
+ { $values
+
- { "x" null }
- { "space" null }
++ { "gadget" "gadget" }
+ }
+ { $description "return gadget containing menu buttons" } ;
+
+ HELP: model-projection
+ { $values
- { "quot" quotation }
++ { "x" "interger" }
++ { "space" "space" }
+ }
+ { $description "Project space following coordinate x" } ;
+
+ HELP: mvt-3D-1
+ { $values
+
- { "quot" quotation }
++ { "quot" "quotation" }
+ }
+ { $description "return a quotation to orientate space to see it from first point of view" } ;
+
+ HELP: mvt-3D-2
+ { $values
+
- { "quot" quotation }
++ { "quot" "quotation" }
+ }
+ { $description "return a quotation to orientate space to see it from second point of view" } ;
+
+ HELP: mvt-3D-3
+ { $values
+
- { "quot" quotation }
++ { "quot" "quotation" }
+ }
+ { $description "return a quotation to orientate space to see it from third point of view" } ;
+
+ HELP: mvt-3D-4
+ { $values
+
-HELP: observer3d
-{ $description "" } ;
-
-HELP: observer3d>
-{ $values
-
- { "value" null }
-}
-{ $description "" } ;
-
-HELP: present-space
-{ $description "" } ;
-
-HELP: present-space>
-{ $values
-
- { "value" null }
-}
-{ $description "" } ;
-
++ { "quot" "quotation" }
+ }
+ { $description "return a quotation to orientate space to see it from first point of view" } ;
+
- { "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 }
+ 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
-{ $description "" } ;
++ { "v" "vector" }
+ }
-HELP: viewer-windows*
-{ $description "" } ;
++{ $description "Apply a 4D translation" } ;
+
-HELP: win3D
-{ $values
- { "text" null } { "gadget" null }
-}
-{ $description "" } ;
+
-HELP: windows
-{ $description "" } ;
++ARTICLE: "implementation details" "How 4DNav is done"
++"4DNav is build using :"
+
-"\nTo build a new space, create an XML file using " { $vocab-link "adsoda" } " model description. \nAn example is:"
++{ $subsection "4DNav.camera" }
++{ $subsection "adsoda-main-page" }
++;
+
+ ARTICLE: "Space file" "Create a new space file"
-
++"To build a new space, create an XML file using " { $vocab-link "adsoda" } " model description. A solid is not caracterized by its corners but is defined as the intersection of hyperplanes."
++
++$nl
++"An 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>"
+
+
+ ;
- "A file chooser"
+ ARTICLE: "TODO" "Todo"
+ { $list
-
-
+ "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"
+ } ;
+
+
-
++ARTICLE: "4DNav" "The 4DNav app"
+ { $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."
-"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
-
++$nl
+ "It will display:"
+ { $list
+ { "a menu window" }
+ { "4 visualization windows" }
+ }
-
++"Each visualization window represents the projection of the 4D space on a particular 3D space."
+
++{ $heading "Start" }
++"type:" { $code "\"4DNav\" run" }
+
++{ $heading "Navigation" }
++"Menu window is divided in 4 areas"
++{ $list
++ { "a space-file chooser to select the file to display" }
++ { "a parametrization area to select the projection mode" }
++ { "4D submenu to translate and rotate the 4D space" }
++ { "3D submenu to move the camera in 3D space. Cameras in every 3D spaces are manipulated as a single one" }
++ }
+
+ { $heading "Links" }
+ { $subsection "Space file" }
+
+ { $subsection "TODO" }
++{ $subsection "implementation details" }
+
+ ;
+
+ ABOUT: "4DNav"
--- /dev/null
- 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
+ ! 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
++ 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
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
++ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
+ \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
++! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+ ! UI\r
-: button* ( string quot -- button ) closed-quot <repeat-button> ;\r
++! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+ \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
++: button* ( string quot -- button ) \r
++ closed-quot <repeat-button> ;\r
+ \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
++! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+ ! \r
- { { 1 "perspective" } { 0 "orthogonal" } } <toggle-buttons> ;\r
++! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+ \r
+ : model-projection-chooser ( -- gadget )\r
+ observer3d> projection-mode>>\r
- { { t "on" } { f "off" } } <toggle-buttons>\r
-;\r
++ { { 1 "perspective" } { 0 "orthogonal" } } \r
++ <toggle-buttons> ;\r
+ \r
+ : collision-detection-chooser ( -- gadget )\r
+ observer3d> collision-mode>>\r
-: model-projection ( x -- space ) present-space> swap space-project ;\r
++ { { t "on" } { f "off" } } <toggle-buttons> ;\r
+ \r
- [ drop [ ] observer3d> with-self update-observer-projections ] \r
++: model-projection ( x -- space ) \r
++ present-space> swap space-project ;\r
+ \r
+ : update-observer-projections ( -- )\r
+ view1> relayout-1 \r
+ view2> relayout-1 \r
+ view3> relayout-1 \r
+ view4> relayout-1 ;\r
+ \r
+ : update-model-projections ( -- )\r
+ 0 model-projection <model> view1> (>>model)\r
+ 1 model-projection <model> view2> (>>model)\r
+ 2 model-projection <model> view3> (>>model)\r
+ 3 model-projection <model> view4> (>>model) ;\r
+ \r
+ : camera-action ( quot -- quot ) \r
-: win3D ( text gadget -- ) "navigateur 4D : " rot append open-window ;\r
++ [ drop [ ] observer3d> \r
++ with-self update-observer-projections ] \r
+ make* closed-quot ;\r
+ \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
++: win3D ( text gadget -- ) \r
++ "navigateur 4D : " rot append open-window ;\r
+ \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
++! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+ ! 4D object manipulation\r
- '[ _ [ [ middle-of-space dup vneg ] keep swap space-translate ] dip\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
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
++ '[ _ [ [ middle-of-space dup vneg ] keep \r
++ swap space-translate ] dip\r
+ space-transform \r
+ swap space-translate\r
+ ] (mvt-4D) ;\r
+ \r
+ : translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ;\r
+ \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
++! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+ ! menu\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
++! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+ \r
+ : menu-rotations-4D ( -- gadget )\r
+ <frame>\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
++ "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] \r
++ button* add-gadget\r
++ "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] \r
++ button* add-gadget \r
+ @top-left grid-add \r
+ <pile> 1 >>fill\r
- "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
++ "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] \r
++ button* add-gadget\r
++ "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] \r
++ button* add-gadget \r
+ @top grid-add \r
+ <pile> 1 >>fill\r
- "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
++ "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] \r
++ button* add-gadget\r
++ "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] \r
++ button* add-gadget \r
+ @center grid-add\r
+ <pile> 1 >>fill\r
- "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
++ "XW +" [ drop rotation-step 4D-Rxw rotation-4D ] \r
++ button* add-gadget\r
++ "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] \r
++ button* add-gadget \r
+ @top-right grid-add \r
+ <pile> 1 >>fill\r
- "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
++ "YW +" [ drop rotation-step 4D-Ryw rotation-4D ] \r
++ button* add-gadget\r
++ "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] \r
++ button* add-gadget \r
+ @right grid-add \r
+ <pile> 1 >>fill\r
- "X+" [ drop { 1 0 0 0 } translation-step v*n translation-4D ] \r
++ "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] \r
++ button* add-gadget\r
++ "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] \r
++ button* add-gadget \r
+ @bottom-right grid-add \r
+ ;\r
+ \r
+ : menu-translations-4D ( -- gadget )\r
+ <frame> \r
+ <pile> 1 >>fill\r
+ <shelf> 1 >>fill \r
- "X-" [ drop { -1 0 0 0 } translation-step v*n translation-4D ] \r
++ "X+" [ drop { 1 0 0 0 } translation-step v*n \r
++ translation-4D ] \r
+ button* add-gadget\r
- "Y+" [ drop { 0 1 0 0 } translation-step v*n translation-4D ] \r
++ "X-" [ drop { -1 0 0 0 } translation-step v*n \r
++ translation-4D ] \r
+ button* add-gadget \r
+ add-gadget\r
+ "YZW" <label> add-gadget\r
+ @bottom-right grid-add\r
+ <pile> 1 >>fill\r
+ "XZW" <label> add-gadget\r
+ <shelf> 1 >>fill\r
- "Y-" [ drop { 0 -1 0 0 } translation-step v*n translation-4D ] \r
++ "Y+" [ drop { 0 1 0 0 } translation-step v*n \r
++ translation-4D ] \r
+ button* add-gadget\r
- "Z+" [ drop { 0 0 1 0 } translation-step v*n translation-4D ] \r
++ "Y-" [ drop { 0 -1 0 0 } translation-step v*n \r
++ translation-4D ] \r
+ button* add-gadget \r
+ add-gadget\r
+ @top-right grid-add\r
+ <pile> 1 >>fill\r
+ "XYW" <label> add-gadget\r
+ <shelf> 1 >>fill\r
- "Z-" [ drop { 0 0 -1 0 } translation-step v*n translation-4D ] \r
++ "Z+" [ drop { 0 0 1 0 } translation-step v*n \r
++ translation-4D ] \r
+ button* add-gadget\r
- "W+" [ drop { 0 0 0 1 } translation-step v*n translation-4D ] \r
++ "Z-" [ drop { 0 0 -1 0 } translation-step v*n \r
++ translation-4D ] \r
+ button* add-gadget \r
+ add-gadget \r
+ @top-left grid-add \r
+ <pile> 1 >>fill\r
+ <shelf> 1 >>fill\r
- "W-" [ drop { 0 0 0 -1 } translation-step v*n translation-4D ] \r
++ "W+" [ drop { 0 0 0 1 } translation-step v*n \r
++ translation-4D ] \r
+ button* add-gadget\r
- selected-file dup selected-file-model> set-model read-model-file \r
++ "W-" [ drop { 0 0 0 -1 } translation-step v*n \r
++ translation-4D ] \r
+ button* add-gadget \r
+ add-gadget\r
+ "XYZ" <label> add-gadget\r
+ @bottom-left grid-add \r
+ "X" <label> @center grid-add\r
+ ;\r
+ \r
+ : menu-4D ( -- gadget ) \r
+ <shelf> \r
+ "rotations" <label> add-gadget\r
+ menu-rotations-4D add-gadget\r
+ "translations" <label> add-gadget\r
+ menu-translations-4D add-gadget\r
+ 0.5 >>align\r
+ { 0 10 } >>gap\r
+ ;\r
+ \r
+ \r
+ ! ------------------------------------------------------\r
+ \r
+ : redraw-model ( space -- )\r
+ >present-space \r
+ update-model-projections \r
+ update-observer-projections ;\r
+ \r
+ : load-model-file ( -- )\r
- "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
++ selected-file dup selected-file-model> set-model \r
++ read-model-file \r
+ redraw-model ;\r
+ \r
+ : mvt-3D-X ( turn pitch -- quot )\r
+ '[ turtle-pos> norm neg reset-turtle \r
+ _ turn-left \r
+ _ pitch-up \r
+ step-turtle ] ;\r
+ \r
+ : mvt-3D-1 ( -- quot ) 90 0 mvt-3D-X ; inline\r
+ : mvt-3D-2 ( -- quot ) 0 90 mvt-3D-X ; inline\r
+ : mvt-3D-3 ( -- quot ) 0 0 mvt-3D-X ; inline\r
+ : mvt-3D-4 ( -- quot ) 45 45 mvt-3D-X ; inline\r
+ \r
+ : camera-button ( string quot -- button ) \r
+ [ <label> ] dip camera-action <repeat-button> ;\r
+ \r
+ ! ----------------------------------------------------------\r
+ ! file chooser\r
+ ! ----------------------------------------------------------\r
+ : <run-file-button> ( file-name -- button )\r
+ dup '[ drop _ \ selected-file set-value load-model-file \r
+ ] \r
+ closed-quot <roll-button> { 0 0 } >>align ;\r
+ \r
+ : <list-runner> ( -- gadget )\r
+ "resource:extra/4DNav" \r
+ <pile> 1 >>fill \r
+ over dup directory-files \r
+ [ ".xml" tail? ] filter \r
+ [ append-path ] with map\r
+ [ <run-file-button> add-gadget ] each\r
+ swap <labelled-gadget> ;\r
+ \r
+ ! -----------------------------------------------------\r
+ \r
+ : menu-rotations-3D ( -- gadget )\r
+ <frame>\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
++ "Turn\n left" [ rotation-step turn-left ] \r
++ camera-button @left grid-add \r
++ "Turn\n right" [ rotation-step turn-right ] \r
++ camera-button @right grid-add \r
++ "Pitch down" [ rotation-step pitch-down ] \r
++ camera-button @bottom grid-add \r
++ "Pitch up" [ rotation-step pitch-up ] \r
++ camera-button @top grid-add \r
+ <shelf> 1 >>fill\r
- "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
++ "Roll left\n (ctl)" [ rotation-step roll-left ] \r
++ camera-button add-gadget \r
++ "Roll right\n(ctl)" [ rotation-step roll-right ] \r
++ camera-button add-gadget \r
+ @center grid-add \r
+ ;\r
+ \r
+ : menu-translations-3D ( -- gadget )\r
+ <frame>\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
++ "left\n(alt)" [ translation-step strafe-left ]\r
++ camera-button @left grid-add \r
++ "right\n(alt)" [ translation-step strafe-right ]\r
++ camera-button @right grid-add \r
++ "Strafe up \n (alt)" [ translation-step strafe-up ] \r
++ camera-button @top grid-add\r
++ "Strafe down\n (alt)" [ translation-step strafe-down ]\r
++ camera-button @bottom grid-add \r
+ <pile> 1 >>fill\r
- [ [ translation-step step-turtle ] camera-action ] }\r
++ "Forward (ctl)" [ translation-step step-turtle ] \r
++ camera-button add-gadget\r
++ "Backward (ctl)" \r
++ [ translation-step neg step-turtle ] \r
++ camera-button add-gadget\r
+ @center grid-add\r
+ ;\r
+ \r
+ : menu-quick-views ( -- gadget )\r
+ <shelf>\r
+ "View 1 (1)" mvt-3D-1 camera-button add-gadget\r
+ "View 2 (2)" mvt-3D-2 camera-button add-gadget\r
+ "View 3 (3)" mvt-3D-3 camera-button add-gadget \r
+ "View 4 (4)" mvt-3D-4 camera-button add-gadget \r
+ ;\r
+ \r
+ : menu-3D ( -- gadget ) \r
+ <pile>\r
+ <shelf> \r
+ menu-rotations-3D add-gadget\r
+ menu-translations-3D add-gadget\r
+ 0.5 >>align\r
+ { 0 10 } >>gap\r
+ add-gadget\r
+ menu-quick-views add-gadget ; \r
+ \r
+ : 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 neg step-turtle ] camera-action ] }\r
++ [ [ translation-step step-turtle ] camera-action ] }\r
+ { T{ key-down f { C+ } "DOWN" } \r
- [ [ translation-step strafe-left ] camera-action ] }\r
++ [ [ translation-step neg step-turtle ] \r
++ camera-action ] }\r
+ { T{ key-down f { C+ } "LEFT" } \r
+ [ [ rotation-step roll-left ] camera-action ] }\r
+ { T{ key-down f { C+ } "RIGHT" } \r
+ [ [ rotation-step roll-right ] camera-action ] }\r
+ \r
+ { T{ key-down f { A+ } "LEFT" } \r
- [ [ translation-step strafe-right ] camera-action ] }\r
++ [ [ translation-step strafe-left ] camera-action ] }\r
+ { T{ key-down f { A+ } "RIGHT" } \r
- [ [ translation-step strafe-down ] camera-action ] }\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
- [ faces>> "composed of faces : " pprint [ adsoda-display-model ] each ]\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
- [ solids>> "composed of solids : " pprint [ adsoda-display-model ] each ]\r
- [ lights>> "composed of lights : " pprint [ adsoda-display-model ] each ] \r
++ [ faces>> "composed of faces : " pprint \r
++ [ adsoda-display-model ] each ]\r
+ } cleave\r
+ ;\r
+ M: space adsoda-display-model \r
+ {\r
+ [ dimension>> "dimension : " pprint . ] \r
+ [ ambient-color>> "ambient-color : " pprint . ]\r
- "reinit" [ drop load-model-file ] button* add-gadget\r
- selected-file-model> <label-control> add-gadget\r
++ [ solids>> "composed of solids : " pprint \r
++ [ adsoda-display-model ] each ]\r
++ [ lights>> "composed of lights : " pprint \r
++ [ adsoda-display-model ] each ] \r
+ } cleave\r
+ ;\r
+ \r
+ ! ----------------------------------------------\r
+ : menu-bar ( -- gadget )\r
+ <shelf>\r
- "Collision detection (slow and buggy ) : " <label> add-gadget\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 ) : " \r
++ <label> add-gadget\r
+ collision-detection-chooser add-gadget\r
+ f track-add\r
+ <pile>\r
+ 0.5 >>align \r
+ menu-4D add-gadget \r
+ 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
- { "point" 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 }
++ { "point" "position" }
+ }
+ { $description "return the position of the camera" } ;
+
+ HELP: camera-focus
+ { $values
+
- { "dirvec" null }
++ { "point" "position" }
+ }
+ { $description "return the point the camera looks at" } ;
+
+ HELP: camera-up
+ { $values
+
- { "camera" null }
++ { "dirvec" "upside direction" }
+ }
+ { $description "In order to precise the roling position of camera give an upward vector" } ;
+
+ HELP: do-look-at
+ { $values
-ARTICLE: "4DNav.camera" "4DNav.camera"
++ { "camera" "direction" }
+ }
+ { $description "Word to use in replacement of gl-look-at when using a camera" } ;
+
++ARTICLE: "4DNav.camera" "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 ;
++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-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 ;
++[ 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 ;
++[ >self camera-eye camera-focus camera-up gl-look-at ]
++ with-scope ;
--- /dev/null
-ARTICLE: "4DNav.deep" "4DNav.deep"
+ ! 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" "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
++USING: macros quotations math math.functions math.trig \r
++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
++: make-matrix ( quot width -- matrix ) \r
++ [ { } make ] dip group ; inline\r
+ \r
--- /dev/null
- { 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
+ ! 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
- '[ [ name>> _ [ tail? ] with contains? ] [ directory? ] bi or ] filter\r
++ { T{ key-down f f "UP" } \r
++ [ find-file-list select-previous ] }\r
++ { T{ key-down f f "DOWN" } \r
++ [ find-file-list select-next ] }\r
++ { T{ key-down f f "PAGE_UP" } \r
++ [ find-file-list list-page-up ] }\r
++ { T{ key-down f f "PAGE_DOWN" } \r
++ [ find-file-list list-page-down ] }\r
++ { T{ key-down f f "RET" } \r
++ [ find-file-list invoke-value-action ] }\r
++ { T{ button-down } \r
++ request-focus }\r
++ { T{ button-down f 1 } \r
++ [ 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
- dup extension>> ", " join "limited to : " prepend <label> f track-add\r
++ '[ [ name>> _ [ tail? ] with any? ] \r
++ [ 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
- 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
++ dup extension>> ", " join "limited to : " prepend \r
++ <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
-[ . ] home { "xml" "txt" } <file-chooser> "Choose a file" open-window ;\r
++ over [ swap fc-go-parent ] curry "go up" \r
++ swap <bevel-button> add-gadget\r
++ over [ swap fc-go-home ] curry "go home" \r
++ swap <bevel-button> add-gadget\r
++ ! over [ swap fc-ok-action ] curry "OK" \r
++ ! 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> \r
++ "Choose a file" open-window ;\r
+ \r
--- /dev/null
-HELP: adsoda-read-model
-{ $values
- { "tag" null }
-}
-{ $description "" } ;
+ ! 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: decode-number-array
-{ $values
- { "x" null }
- { "y" null }
-}
-{ $description "" } ;
+
- { "x" null }
+
+ HELP: read-model-file
+ { $values
+
+ { "path" "path to the file to read" }
-{ $description "" } ;
++ { "x" "value" }
+ }
-ARTICLE: "4DNav.space-file-decoder" "4DNav.space-file-decoder"
++{ $description "Read a file containing the xml description of the model" } ;
+
++ARTICLE: "4DNav.space-file-decoder" "Space XMLfile decoder"
+ { $vocab-link "4DNav.space-file-decoder" }
+ ;
+
+ ABOUT: "4DNav.space-file-decoder"
--- /dev/null
-USING: adsoda xml xml.utilities xml.dispatch accessors combinators\r
-sequences math.parser kernel splitting values continuations ;\r
+ ! Copyright (C) 2008 Jeff Bigot\r
+ ! See http://factorcode.org/license.txt for BSD license.\r
-: decode-number-array ( x -- y ) "," split [ string>number ] map ;\r
++USING: adsoda xml xml.utilities xml.dispatch accessors \r
++combinators sequences math.parser kernel splitting values \r
++continuations ;\r
+ IN: 4DNav.space-file-decoder\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
++: decode-number-array ( x -- y ) \r
++ "," split [ string>number ] map ;\r
+ \r
+ PROCESS: adsoda-read-model ( tag -- )\r
+ \r
- [ "dimension" tag-named adsoda-read-model >>dimension ] \r
++TAG: dimension adsoda-read-model \r
++ children>> first string>number ;\r
++TAG: direction adsoda-read-model \r
++ children>> first decode-number-array ;\r
++TAG: color adsoda-read-model \r
++ children>> first decode-number-array ;\r
++TAG: name adsoda-read-model \r
++ children>> first ;\r
++TAG: face adsoda-read-model \r
++ children>> first decode-number-array ;\r
+ \r
+ TAG: solid adsoda-read-model \r
+ <solid> swap \r
+ { \r
- [ "face" tags-named [ adsoda-read-model cut-solid ] each ] \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
- [ "direction" tag-named adsoda-read-model >>direction ] \r
++ [ "face" \r
++ 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
- [ "dimension" tag-named adsoda-read-model >>dimension ] \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
- [ "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
++ [ "dimension" tag-named adsoda-read-model >>dimension ]\r
+ [ "name" tag-named adsoda-read-model >>name ] \r
++ [ "color" tag-named \r
++ adsoda-read-model >>ambient-color ] \r
++ [ "solid" tags-named \r
++ [ adsoda-read-model suffix-solids ] each ] \r
++ [ "light" tags-named \r
++ [ 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
-HELP: <turtle>
-{ $values
-
- { "turtle" null }
-}
-{ $description "" } ;
+ ! 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-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"
+
++ARTICLE: "4DNav.turtle" "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) ;
+
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: apply-rotation ( rotation -- ) turtle-ori> swap m. >turtle-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 ;
++! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
++: 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 turtle-ori> swap m.v turtle-pos> v+ >turtle-pos ;
++! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ : 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
-HELP: <window3D>
-{ $values
- { "model" null } { "observer" null }
- { "gadget" null }
-}
-{ $description "" } ;
+ ! 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
-{ $description "" } ;
+
-ARTICLE: "4DNav.window3D" "4DNav.window3D"
+
++ARTICLE: "4DNav.window3D" "Window3D"
+ { $vocab-link "4DNav.window3D" }
+ ;
+
+ ABOUT: "4DNav.window3D"
--- /dev/null
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+ ! 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
++! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+ ! drawing functions \r
- GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear\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 \r
++ 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
-ARTICLE: "face-page" "face in ADSODA"\r
+ ! 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: "solid-page" "solid in ADSODA"\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
-{ $description " " } ;\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
-ARTICLE: "space-page" "space in ADSODA"\r
++{ $description "Substract solid2 from solid1" } ;\r
+ \r
+ \r
+ ! --------------------------------------------------------------\r
+ ! space \r
+ ! --------------------------------------------------------------\r
-ARTICLE: "3D-rendering-page" "3D rendering in ADSODA"\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
-{ $description "" } ;\r
++ARTICLE: "3D-rendering-page" "The 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
++{ $description "display a face" } ;\r
+ \r
+ HELP: solid->GL \r
+ { $values { "solid" "a solid" } }\r
-{ $description "" } ;\r
++{ $description "display a solid" } ;\r
+ \r
+ HELP: space->GL \r
+ { $values { "space" "a space" } }\r
-ARTICLE: "light-page" "light in ADSODA"\r
++{ $description "display a space" } ;\r
+ \r
+ ! --------------------------------------------------------------\r
+ ! light\r
+ ! --------------------------------------------------------------\r
+ \r
-"! demi espace défini par un vecteur normal et une constante"\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
+ " 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
-! ---------------------------------------------------------------------\r
+ ! 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
++! -------------------------------------------------------------\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
-: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline\r
-: change-last ( seq quot -- ) [ [ dimension ] keep ] dip change-nth ; \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
-! --------------------------------------------------------------\r
++: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline\r
++: change-last ( seq quot -- ) \r
++ [ [ dimension ] keep ] dip change-nth ; \r
+ \r
-! --------------------------------------------------------------\r
++! -------------------------------------------------------------\r
+ ! light\r
-! -----------------------------------------------------------------------\r
++! -------------------------------------------------------------\r
+ \r
+ TUPLE: light name { direction array } color ;\r
+ : <light> ( -- tuple ) light new ;\r
+ \r
-! -----------------------------------------------------------------------\r
++! -------------------------------------------------------------\r
+ ! halfspace manipulation\r
- [ [ abs ZERO-VALUE > ] find ] keep ! find a point on the frontier\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
-: project-vector ( seq -- seq ) pv> [ head ] [ 1+ tail ] 2bi append ; \r
-: get-intersection ( matrice -- seq ) [ 1 tail* ] map flip first ;\r
++ [ [ abs ZERO-VALUE > ] find ] keep \r
++ ! 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
-! --------------------------------------------------------------\r
++: project-vector ( seq -- seq ) \r
++ pv> [ head ] [ 1+ tail ] 2bi append ; \r
++: get-intersection ( matrice -- seq ) \r
++ [ 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
++! -------------------------------------------------------------\r
+ ! faces\r
-TUPLE: face { halfspace array } touching-corners adjacent-faces ;\r
++! -------------------------------------------------------------\r
+ \r
-: erase-face-touching-corners ( face -- face ) f >>touching-corners ;\r
-: erase-face-adjacent-faces ( face -- face ) f >>adjacent-faces ;\r
++TUPLE: face { halfspace array } \r
++ touching-corners adjacent-faces ;\r
+ : <face> ( v -- tuple ) face new swap >>halfspace ;\r
+ : flip-face ( face -- face ) [ vneg ] change-halfspace ;\r
-: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;\r
++: erase-face-touching-corners ( face -- face ) \r
++ f >>touching-corners ;\r
++: erase-face-adjacent-faces ( face -- face ) \r
++ 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
- [ touching-corners>> length ] [ halfspace>> dimension ] bi >= ;\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
- clone dup adjacent-faces>> [ intersection-into-face ] with map \r
++ [ touching-corners>> length ] \r
++ [ 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
-! --------------------------------------------------------------\r
-TUPLE: solid dimension silhouettes faces corners adjacencies-valid color name ;\r
++ clone dup \r
++ 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
-: suffix-face ( solid face -- solid ) [ suffix ] curry change-faces ;\r
-\r
-: suffix-corner ( solid corner -- solid ) [ suffix ] curry change-corners ; \r
-\r
++! -------------------------------------------------------------\r
++TUPLE: solid dimension silhouettes \r
++ 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
-: erase-silhouettes ( solid -- solid ) dup dimension>> f <array> >>silhouettes ;\r
-\r
-: filter-real-faces ( solid -- solid ) [ [ real-face? ] filter ] change-faces ;\r
-\r
++: suffix-face ( solid face -- solid ) \r
++ [ suffix ] curry change-faces ;\r
++: suffix-corner ( solid corner -- solid ) \r
++ [ suffix ] curry change-corners ; \r
+ : erase-solid-corners ( solid -- solid ) f >>corners ;\r
+ \r
- [ dup [ erase-face-touching-corners erase-face-adjacent-faces drop ] each ]\r
++: erase-silhouettes ( solid -- solid ) \r
++ dup dimension>> f <array> >>silhouettes ;\r
++: filter-real-faces ( solid -- solid ) \r
++ [ [ real-face? ] filter ] change-faces ;\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
- [ faces>> ] dip [ point-inside-face? ] curry all? ; inline\r
++ [ dup [ erase-face-touching-corners \r
++ 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-or-on-face? ] curry all? ; inline\r
++ [ faces>> ] dip [ point-inside-face? ] curry all? ; inline\r
+ \r
+ : point-inside-or-on-solid? ( solid point -- ? )\r
- erase-old-adjacencies f >>adjacencies-valid erase-silhouettes ;\r
++ [ faces>> ] dip \r
++ [ point-inside-or-on-face? ] curry all? ; inline\r
+ \r
+ : unvalid-adjacencies ( solid -- solid ) \r
-: (non-empty-solid?) ( solid -- ? ) [ dimension>> ] [ corners>> length ] bi < ;\r
-: non-empty-solid? ( solid -- ? ) ensure-adjacencies (non-empty-solid?) ;\r
++ erase-old-adjacencies f >>adjacencies-valid \r
++ 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
-: solid-translate ( solid v -- solid ) [ face-translate ] (solid-move) ; \r
-: solid-transform ( solid m -- solid ) [ face-transform ] (solid-move) ; \r
++: (non-empty-solid?) ( solid -- ? ) \r
++ [ dimension>> ] [ corners>> length ] bi < ;\r
++: non-empty-solid? ( solid -- ? ) \r
++ 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
-! --------------------------------------------------------------\r
++: solid-translate ( solid v -- solid ) \r
++ [ face-translate ] (solid-move) ; \r
++: solid-transform ( solid m -- solid ) \r
++ [ 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
++! -------------------------------------------------------------\r
+ ! space \r
-: suffix-solids ( space solid -- space ) [ suffix ] curry change-solids ; inline\r
-: suffix-lights ( space light -- space ) [ suffix ] curry change-lights ; inline\r
++! -------------------------------------------------------------\r
+ TUPLE: space name dimension solids ambient-color lights ;\r
+ : <space> ( -- space ) space new ;\r
- swap dimension>> 1- <space> swap >>dimension swap >>solids ;\r
++: suffix-solids ( space solid -- space ) \r
++ [ suffix ] curry change-solids ; inline\r
++: suffix-lights ( space light -- space ) \r
++ [ 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
-: get-silhouette ( solid -- silhouette ) silhouettes>> pv> swap nth ;\r
-: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;\r
++ swap dimension>> 1- <space> \r
++ swap >>dimension swap >>solids ;\r
+ \r
-: space-transform ( space m -- space ) [ solid-transform ] space-apply ;\r
-: space-translate ( space v -- space ) [ solid-translate ] space-apply ; \r
++: get-silhouette ( solid -- silhouette ) \r
++ 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
- solids>> [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;\r
++: space-transform ( space m -- space ) \r
++ [ solid-transform ] space-apply ;\r
++: space-translate ( space v -- space ) \r
++ [ solid-translate ] space-apply ; \r
+ \r
+ : describe-space ( space -- ) \r
-! We must include each solid in a sequence because during substration \r
++ solids>> \r
++ [ [ 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
-! --------------------------------------------------------------\r
++! We must include each solid in a sequence because \r
++! 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
++! -------------------------------------------------------------\r
+ ! 3D rendering\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
++! -------------------------------------------------------------\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 \r
++ [ [ point->GL ] each ] do-state ] curry\r
++ [ 0 0 0 1 glColor4d GL_LINE_LOOP \r
++ [ [ 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
- { "array" array } { "n" 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
-ARTICLE: "adsoda.combinators" "adsoda.combinators"
++ { "array" array } { "n" "number of value to select" }
+ { "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" "Combinators"
+ { $vocab-link "adsoda.combinators" }
+ ;
+
+ ABOUT: "adsoda.combinators"
--- /dev/null
-! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ; \r
+ ! 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
-: concat-nth ( seq1 seq2 -- seq ) [ nth append ] curry map-index ;\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 ) \r
++ [ 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
-"\n returns a 3D solid with given limits"
+ ! 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 4D solid with given limits"
++"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"
-HELP: coord-max
-{ $values
- { "x" null } { "array" array }
- { "array" array }
-}
-{ $description "" } ;
-
-HELP: coord-min
-{ $values
- { "x" null } { "array" array }
- { "array" array }
-}
-{ $description "" } ;
-
++"returns a 4D solid with given limits"
+ } ;
+
+
-"\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: 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"
-"\n Finds a normal vector and then translate it so that it includes one of the points"
++"With n points, creates n-1 vectors and then find a vector orthogonal to every others"
++"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"
-ARTICLE: "adsoda.tools" "adsoda.tools"
++"Finds a normal vector and then translate it so that it includes one of the points"
+
+ }
+ ;
+
-"\nTools to help in building an " { $vocab-link "adsoda" } "-space"
++ARTICLE: "adsoda.tools" "Tools"
+ { $vocab-link "adsoda.tools" }
++"Tools to help in building an " { $vocab-link "adsoda" } "-space"
+ ;
+
+ ABOUT: "adsoda.tools"
+
+
--- /dev/null
- [ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] with map\r
+ ! 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
- [ do-cycle 2 clump ] bi@ concat-nth ! 3 faces rectangulaires\r
++ [ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] \r
++ 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
- ! from 3 points gives a list of faces representing a cube of height "height"\r
++ [ do-cycle 2 clump ] bi@ concat-nth \r
++ ! 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 in 4th dim\r
++ ! from 3 points gives a list of faces representing \r
++ ! 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
- [ 1 Xpoints-to-prisme [ 100 110 Xpoints-to-plane4D ] map concat ] map \r
++ ! from 3 points gives a list of faces representing \r
++ ! 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 \r
++ 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
projects / factor.git / commitdiff