diff --git a/extra/4DNav/4DNav-docs.factor b/extra/4DNav/4DNav-docs.factor
new file mode 100755
index 0000000000..d4bf1db87d
--- /dev/null
+++ b/extra/4DNav/4DNav-docs.factor
@@ -0,0 +1,400 @@
+! 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"
diff --git a/extra/4DNav/4DNav.factor b/extra/4DNav/4DNav.factor
new file mode 100755
index 0000000000..745259bd29
--- /dev/null
+++ b/extra/4DNav/4DNav.factor
@@ -0,0 +1,524 @@
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel
+namespaces
+accessors
+make
+math
+math.functions
+math.trig
+math.parser
+hashtables
+sequences
+combinators
+continuations
+colors
+prettyprint
+vars
+quotations
+io
+io.directories
+io.pathnames
+help.markup
+io.files
+ui.gadgets.panes
+ ui
+ ui.gadgets
+ ui.traverse
+ ui.gadgets.borders
+ ui.gadgets.handler
+ ui.gadgets.slate
+ ui.gadgets.theme
+ ui.gadgets.frames
+ ui.gadgets.tracks
+ ui.gadgets.labels
+ ui.gadgets.labelled
+ ui.gadgets.lists
+ ui.gadgets.buttons
+ ui.gadgets.packs
+ ui.gadgets.grids
+ ui.gestures
+ ui.tools.workspace
+ ui.gadgets.scrollers
+splitting
+vectors
+math.vectors
+rewrite-closures
+self
+values
+4DNav.turtle
+4DNav.window3D
+4DNav.deep
+4DNav.space-file-decoder
+models
+fry
+adsoda
+adsoda.tools
+;
+
+IN: 4DNav
+VALUE: selected-file
+VALUE: translation-step
+VALUE: rotation-step
+
+3 to: translation-step
+5 to: rotation-step
+
+VAR: selected-file-model
+VAR: observer3d
+VAR: view1
+VAR: view2
+VAR: view3
+VAR: view4
+VAR: present-space
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! replacement of namespaces.lib
+
+: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! waiting for deep-cleave-quots
+
+: 4D-Rxy ( angle -- Rx ) deg>rad
+[ 1.0 , 0.0 , 0.0 , 0.0 ,
+ 0.0 , 1.0 , 0.0 , 0.0 ,
+ 0.0 , 0.0 , dup cos , dup sin neg ,
+ 0.0 , 0.0 , dup sin , dup cos , ] 4 make-matrix nip ;
+
+: 4D-Rxz ( angle -- Ry ) deg>rad
+[ 1.0 , 0.0 , 0.0 , 0.0 ,
+ 0.0 , dup cos , 0.0 , dup sin neg ,
+ 0.0 , 0.0 , 1.0 , 0.0 ,
+ 0.0 , dup sin , 0.0 , dup cos , ] 4 make-matrix nip ;
+
+: 4D-Rxw ( angle -- Rz ) deg>rad
+[ 1.0 , 0.0 , 0.0 , 0.0 ,
+ 0.0 , dup cos , dup sin neg , 0.0 ,
+ 0.0 , dup sin , dup cos , 0.0 ,
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
+
+: 4D-Ryz ( angle -- Rx ) deg>rad
+[ dup cos , 0.0 , 0.0 , dup sin neg ,
+ 0.0 , 1.0 , 0.0 , 0.0 ,
+ 0.0 , 0.0 , 1.0 , 0.0 ,
+ dup sin , 0.0 , 0.0 , dup cos , ] 4 make-matrix nip ;
+
+: 4D-Ryw ( angle -- Ry ) deg>rad
+[ dup cos , 0.0 , dup sin neg , 0.0 ,
+ 0.0 , 1.0 , 0.0 , 0.0 ,
+ dup sin , 0.0 , dup cos , 0.0 ,
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
+
+: 4D-Rzw ( angle -- Rz ) deg>rad
+[ dup cos , dup sin neg , 0.0 , 0.0 ,
+ dup sin , dup cos , 0.0 , 0.0 ,
+ 0.0 , 0.0 , 1.0 , 0.0 ,
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! UI
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: button* ( string quot -- button ) closed-quot <repeat-button> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: model-projection-chooser ( -- gadget )
+ observer3d> projection-mode>>
+ { { 1 "perspective" } { 0 "orthogonal" } } <toggle-buttons> ;
+
+: collision-detection-chooser ( -- gadget )
+ observer3d> collision-mode>>
+ { { t "on" } { f "off" } } <toggle-buttons>
+;
+
+: model-projection ( x -- space ) present-space> swap space-project ;
+
+: update-observer-projections ( -- )
+ view1> relayout-1
+ view2> relayout-1
+ view3> relayout-1
+ view4> relayout-1 ;
+
+: update-model-projections ( -- )
+ 0 model-projection <model> view1> (>>model)
+ 1 model-projection <model> view2> (>>model)
+ 2 model-projection <model> view3> (>>model)
+ 3 model-projection <model> view4> (>>model) ;
+
+: camera-action ( quot -- quot )
+ [ drop [ ] observer3d> with-self update-observer-projections ]
+ make* closed-quot ;
+
+: win3D ( text gadget -- ) "navigateur 4D : " rot append open-window ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 4D object manipulation
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (mvt-4D) ( quot -- )
+ present-space>
+ swap call space-ensure-solids
+ >present-space
+ update-model-projections
+ update-observer-projections ;
+
+: rotation-4D ( m -- )
+ '[ _ [ [ middle-of-space dup vneg ] keep swap space-translate ] dip
+ space-transform
+ swap space-translate
+ ] (mvt-4D) ;
+
+: translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! menu
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: menu-rotations-4D ( -- gadget )
+ <frame>
+ <pile> 1 >>fill
+ "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] button* add-gadget
+ "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] button* add-gadget
+ @top-left grid-add
+ <pile> 1 >>fill
+ "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] button* add-gadget
+ "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] button* add-gadget
+ @top grid-add
+ <pile> 1 >>fill
+ "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] button* add-gadget
+ "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] button* add-gadget
+ @center grid-add
+ <pile> 1 >>fill
+ "XW +" [ drop rotation-step 4D-Rxw rotation-4D ] button* add-gadget
+ "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] button* add-gadget
+ @top-right grid-add
+ <pile> 1 >>fill
+ "YW +" [ drop rotation-step 4D-Ryw rotation-4D ] button* add-gadget
+ "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] button* add-gadget
+ @right grid-add
+ <pile> 1 >>fill
+ "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] button* add-gadget
+ "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] button* add-gadget
+ @bottom-right grid-add
+;
+
+: menu-translations-4D ( -- gadget )
+ <frame>
+ <pile> 1 >>fill
+ <shelf> 1 >>fill
+ "X+" [ drop { 1 0 0 0 } translation-step v*n translation-4D ]
+ button* add-gadget
+ "X-" [ drop { -1 0 0 0 } translation-step v*n translation-4D ]
+ button* add-gadget
+ add-gadget
+ "YZW" <label> add-gadget
+ @bottom-right grid-add
+ <pile> 1 >>fill
+ "XZW" <label> add-gadget
+ <shelf> 1 >>fill
+ "Y+" [ drop { 0 1 0 0 } translation-step v*n translation-4D ]
+ button* add-gadget
+ "Y-" [ drop { 0 -1 0 0 } translation-step v*n translation-4D ]
+ button* add-gadget
+ add-gadget
+ @top-right grid-add
+ <pile> 1 >>fill
+ "XYW" <label> add-gadget
+ <shelf> 1 >>fill
+ "Z+" [ drop { 0 0 1 0 } translation-step v*n translation-4D ]
+ button* add-gadget
+ "Z-" [ drop { 0 0 -1 0 } translation-step v*n translation-4D ]
+ button* add-gadget
+ add-gadget
+ @top-left grid-add
+ <pile> 1 >>fill
+ <shelf> 1 >>fill
+ "W+" [ drop { 0 0 0 1 } translation-step v*n translation-4D ]
+ button* add-gadget
+ "W-" [ drop { 0 0 0 -1 } translation-step v*n translation-4D ]
+ button* add-gadget
+ add-gadget
+ "XYZ" <label> add-gadget
+ @bottom-left grid-add
+ "X" <label> @center grid-add
+;
+
+: menu-4D ( -- gadget )
+ <shelf>
+ "rotations" <label> add-gadget
+ menu-rotations-4D add-gadget
+ "translations" <label> add-gadget
+ menu-translations-4D add-gadget
+ 0.5 >>align
+ { 0 10 } >>gap
+;
+
+
+! ------------------------------------------------------
+
+: redraw-model ( space -- )
+ >present-space
+ update-model-projections
+ update-observer-projections ;
+
+: load-model-file ( -- )
+ selected-file dup selected-file-model> set-model read-model-file
+ redraw-model ;
+
+: mvt-3D-X ( turn pitch -- quot )
+ '[ turtle-pos> norm neg reset-turtle
+ _ turn-left
+ _ pitch-up
+ step-turtle ] ;
+
+: mvt-3D-1 ( -- quot ) 90 0 mvt-3D-X ; inline
+: mvt-3D-2 ( -- quot ) 0 90 mvt-3D-X ; inline
+: mvt-3D-3 ( -- quot ) 0 0 mvt-3D-X ; inline
+: mvt-3D-4 ( -- quot ) 45 45 mvt-3D-X ; inline
+
+: camera-button ( string quot -- button )
+ [ <label> ] dip camera-action <repeat-button> ;
+
+! ----------------------------------------------------------
+! file chooser
+! ----------------------------------------------------------
+: <run-file-button> ( file-name -- button )
+ dup '[ drop _ \ selected-file set-value load-model-file
+ ]
+ closed-quot <roll-button> { 0 0 } >>align ;
+
+: <list-runner> ( -- gadget )
+ "extra/4DNav"
+ <pile> 1 >>fill
+ over dup directory-files
+ [ ".xml" tail? ] filter
+ [ append-path ] with map
+ [ <run-file-button> add-gadget ] each
+ swap <labelled-gadget> ;
+
+! -----------------------------------------------------
+
+: menu-rotations-3D ( -- gadget )
+ <frame>
+ "Turn\n left" [ rotation-step turn-left ] camera-button
+ @left grid-add
+ "Turn\n right" [ rotation-step turn-right ] camera-button
+ @right grid-add
+ "Pitch down" [ rotation-step pitch-down ] camera-button
+ @bottom grid-add
+ "Pitch up" [ rotation-step pitch-up ] camera-button
+ @top grid-add
+ <shelf> 1 >>fill
+ "Roll left\n (ctl)" [ rotation-step roll-left ] camera-button
+ add-gadget
+ "Roll right\n(ctl)" [ rotation-step roll-right ] camera-button
+ add-gadget
+ @center grid-add
+;
+
+: menu-translations-3D ( -- gadget )
+ <frame>
+ "left\n(alt)" [ translation-step strafe-left ] camera-button
+ @left grid-add
+ "right\n(alt)" [ translation-step strafe-right ] camera-button
+ @right grid-add
+ "Strafe up \n (alt)" [ translation-step strafe-up ] camera-button
+ @top grid-add
+ "Strafe down \n (alt)" [ translation-step strafe-down ] camera-button
+ @bottom grid-add
+ <pile> 1 >>fill
+ "Forward (ctl)" [ translation-step step-turtle ] camera-button
+ add-gadget
+ "Backward (ctl)" [ translation-step neg step-turtle ] camera-button
+ add-gadget
+ @center grid-add
+;
+
+: menu-quick-views ( -- gadget )
+ <shelf>
+ "View 1 (1)" mvt-3D-1 camera-button add-gadget
+ "View 2 (2)" mvt-3D-2 camera-button add-gadget
+ "View 3 (3)" mvt-3D-3 camera-button add-gadget
+ "View 4 (4)" mvt-3D-4 camera-button add-gadget
+;
+
+: menu-3D ( -- gadget )
+ <pile>
+ <shelf>
+ menu-rotations-3D add-gadget
+ menu-translations-3D add-gadget
+ 0.5 >>align
+ { 0 10 } >>gap
+ add-gadget
+ menu-quick-views add-gadget ;
+
+: add-keyboard-delegate ( obj -- obj )
+ <handler>
+{
+ { T{ key-down f f "LEFT" }
+ [ [ rotation-step turn-left ] camera-action ] }
+ { T{ key-down f f "RIGHT" }
+ [ [ rotation-step turn-right ] camera-action ] }
+ { T{ key-down f f "UP" }
+ [ [ rotation-step pitch-down ] camera-action ] }
+ { T{ key-down f f "DOWN" }
+ [ [ rotation-step pitch-up ] camera-action ] }
+
+ { T{ key-down f { C+ } "UP" }
+ [ [ translation-step step-turtle ] camera-action ] }
+ { T{ key-down f { C+ } "DOWN" }
+ [ [ translation-step neg step-turtle ] camera-action ] }
+ { T{ key-down f { C+ } "LEFT" }
+ [ [ rotation-step roll-left ] camera-action ] }
+ { T{ key-down f { C+ } "RIGHT" }
+ [ [ rotation-step roll-right ] camera-action ] }
+
+ { T{ key-down f { A+ } "LEFT" }
+ [ [ translation-step strafe-left ] camera-action ] }
+ { T{ key-down f { A+ } "RIGHT" }
+ [ [ translation-step strafe-right ] camera-action ] }
+ { T{ key-down f { A+ } "UP" }
+ [ [ translation-step strafe-up ] camera-action ] }
+ { T{ key-down f { A+ } "DOWN" }
+ [ [ translation-step strafe-down ] camera-action ] }
+
+
+ { T{ key-down f f "1" } [ mvt-3D-1 camera-action ] }
+ { T{ key-down f f "2" } [ mvt-3D-2 camera-action ] }
+ { T{ key-down f f "3" } [ mvt-3D-3 camera-action ] }
+ { T{ key-down f f "4" } [ mvt-3D-4 camera-action ] }
+
+ } [ make* ] map >hashtable >>table
+ ;
+
+! --------------------------------------------
+! print elements
+! --------------------------------------------
+! print-content
+
+GENERIC: adsoda-display-model ( x -- )
+
+M: light adsoda-display-model
+"\n light : " .
+ {
+ [ direction>> "direction : " pprint . ]
+ [ color>> "color : " pprint . ]
+ } cleave
+ ;
+
+M: face adsoda-display-model
+ {
+ [ halfspace>> "halfspace : " pprint . ]
+ [ touching-corners>> "touching corners : " pprint . ]
+ } cleave
+ ;
+M: solid adsoda-display-model
+ {
+ [ name>> "solid called : " pprint . ]
+ [ color>> "color : " pprint . ]
+ [ dimension>> "dimension : " pprint . ]
+ [ faces>> "composed of faces : " pprint [ adsoda-display-model ] each ]
+ } cleave
+ ;
+M: space adsoda-display-model
+ {
+ [ dimension>> "dimension : " pprint . ]
+ [ ambient-color>> "ambient-color : " pprint . ]
+ [ solids>> "composed of solids : " pprint [ adsoda-display-model ] each ]
+ [ lights>> "composed of lights : " pprint [ adsoda-display-model ] each ]
+ } cleave
+ ;
+
+! ----------------------------------------------
+: menu-bar ( -- gadget )
+ <shelf>
+ "reinit" [ drop load-model-file ] button* add-gadget
+ selected-file-model> <label-control> add-gadget
+ ;
+
+
+: controller-window* ( -- gadget )
+ { 0 1 } <track>
+ menu-bar f track-add
+ <list-runner>
+ <limited-scroller>
+ { 200 400 } >>max-dim
+ f track-add
+ <shelf>
+ "Projection mode : " <label> add-gadget
+ model-projection-chooser add-gadget
+ f track-add
+ <shelf>
+ "Collision detection (slow and buggy ) : " <label> add-gadget
+ collision-detection-chooser add-gadget
+ f track-add
+ <pile>
+ 0.5 >>align
+ menu-4D add-gadget
+ light-purple solid-interior
+ "4D movements" <labelled-gadget>
+ f track-add
+ <pile>
+ 0.5 >>align
+ { 2 2 } >>gap
+ menu-3D add-gadget
+ light-purple solid-interior
+ "Camera 3D" <labelled-gadget>
+ f track-add
+ gray solid-interior
+ ;
+
+: viewer-windows* ( -- )
+ "YZW" view1> win3D
+ "XZW" view2> win3D
+ "XYW" view3> win3D
+ "XYZ" view4> win3D
+;
+
+: navigator-window* ( -- )
+ controller-window*
+ viewer-windows*
+ add-keyboard-delegate
+ "navigateur 4D" open-window
+;
+
+: windows ( -- ) [ [ navigator-window* ] with-scope ] with-ui ;
+
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-variables ( -- )
+ "choose a file" <model> >selected-file-model
+ <observer> >observer3d
+ [ observer3d> >self
+ reset-turtle
+ 45 turn-left
+ 45 pitch-up
+ -300 step-turtle
+ ] with-scope
+
+;
+
+
+: init-models ( -- )
+ 0 model-projection observer3d> <window3D> >view1
+ 1 model-projection observer3d> <window3D> >view2
+ 2 model-projection observer3d> <window3D> >view3
+ 3 model-projection observer3d> <window3D> >view4
+;
+
+: 4DNav ( -- )
+ init-variables
+ selected-file read-model-file >present-space
+ init-models
+ windows
+;
+
+MAIN: 4DNav
+
+
diff --git a/extra/4DNav/authors.txt b/extra/4DNav/authors.txt
new file mode 100755
index 0000000000..a6a96933f4
--- /dev/null
+++ b/extra/4DNav/authors.txt
@@ -0,0 +1 @@
+Jeff Bigot
\ No newline at end of file
diff --git a/extra/4DNav/camera/authors.txt b/extra/4DNav/camera/authors.txt
new file mode 100755
index 0000000000..bbc876e7b6
--- /dev/null
+++ b/extra/4DNav/camera/authors.txt
@@ -0,0 +1 @@
+Adam Wendt
diff --git a/extra/4DNav/camera/camera-docs.factor b/extra/4DNav/camera/camera-docs.factor
new file mode 100755
index 0000000000..422148aebe
--- /dev/null
+++ b/extra/4DNav/camera/camera-docs.factor
@@ -0,0 +1,88 @@
+! 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"
diff --git a/extra/4DNav/camera/camera.factor b/extra/4DNav/camera/camera.factor
new file mode 100755
index 0000000000..93e8271f1b
--- /dev/null
+++ b/extra/4DNav/camera/camera.factor
@@ -0,0 +1,15 @@
+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 ;
diff --git a/extra/4DNav/deep/deep-docs.factor b/extra/4DNav/deep/deep-docs.factor
new file mode 100755
index 0000000000..0332f77e66
--- /dev/null
+++ b/extra/4DNav/deep/deep-docs.factor
@@ -0,0 +1,31 @@
+! 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"
diff --git a/extra/4DNav/deep/deep.factor b/extra/4DNav/deep/deep.factor
new file mode 100755
index 0000000000..65e15180bc
--- /dev/null
+++ b/extra/4DNav/deep/deep.factor
@@ -0,0 +1,11 @@
+USING: macros quotations math math.functions math.trig sequences.deep kernel make fry combinators grouping ;
+IN: 4DNav.deep
+
+! USING: bake ;
+! MACRO: deep-cleave-quots ( seq -- quot )
+! [ [ quotation? ] deep-filter ]
+! [ [ dup quotation? [ drop , ] when ] deep-map ]
+! bi '[ _ cleave _ bake ] ;
+
+: make-matrix ( quot width -- matrix ) [ { } make ] dip group ; inline
+
diff --git a/extra/4DNav/deploy.factor b/extra/4DNav/deploy.factor
new file mode 100755
index 0000000000..e39f91acf6
--- /dev/null
+++ b/extra/4DNav/deploy.factor
@@ -0,0 +1,15 @@
+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 }
+}
diff --git a/extra/4DNav/file-chooser/authors.txt b/extra/4DNav/file-chooser/authors.txt
new file mode 100755
index 0000000000..a6a96933f4
--- /dev/null
+++ b/extra/4DNav/file-chooser/authors.txt
@@ -0,0 +1 @@
+Jeff Bigot
\ No newline at end of file
diff --git a/extra/4DNav/file-chooser/file-chooser.factor b/extra/4DNav/file-chooser/file-chooser.factor
new file mode 100755
index 0000000000..2915a093ed
--- /dev/null
+++ b/extra/4DNav/file-chooser/file-chooser.factor
@@ -0,0 +1,142 @@
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING:
+kernel
+io.files
+io.backend
+sequences
+models
+strings
+ui
+ui.operations
+ui.commands
+ui.gestures
+ui.gadgets
+ui.gadgets.buttons
+ui.gadgets.lists
+ui.gadgets.labels
+ui.gadgets.tracks
+ui.gadgets.packs
+ui.gadgets.panes
+ui.gadgets.scrollers
+prettyprint
+combinators
+rewrite-closures
+accessors
+namespaces.lib
+values
+tools.walker
+fry
+;
+IN: 4DNav.file-chooser
+
+TUPLE: file-chooser < track
+ path
+ extension
+ selected-file
+ presenter
+ hook
+ list
+ ;
+
+: find-file-list ( gadget -- list )
+ [ file-chooser? ] find-parent list>> ;
+
+file-chooser H{
+ { T{ key-down f f "UP" } [ find-file-list select-previous ] }
+ { T{ key-down f f "DOWN" } [ find-file-list select-next ] }
+ { T{ key-down f f "PAGE_UP" } [ find-file-list list-page-up ] }
+ { T{ key-down f f "PAGE_DOWN" } [ find-file-list list-page-down ] }
+ { T{ key-down f f "RET" } [ find-file-list invoke-value-action ] }
+ { T{ button-down } request-focus }
+ { T{ button-down f 1 } [ find-file-list invoke-value-action ] }
+} set-gestures
+
+: list-of-files ( file-chooser -- seq )
+ [ path>> value>> directory-entries ] [ extension>> ] bi
+ '[ [ name>> _ [ tail? ] with contains? ] [ directory? ] bi or ] filter
+;
+
+: update-filelist-model ( file-chooser -- file-chooser )
+ [ list-of-files ] [ model>> ] bi set-model ;
+
+: init-filelist-model ( file-chooser -- file-chooser )
+ dup list-of-files <model> >>model ;
+
+: (fc-go) ( file-chooser quot -- )
+ [ [ file-chooser? ] find-parent dup path>> ] dip
+ call
+ normalize-path swap set-model
+ update-filelist-model
+ drop ;
+
+: fc-go-parent ( file-chooser -- )
+ [ dup value>> parent-directory ] (fc-go) ;
+
+: fc-go-home ( file-chooser -- )
+ [ home ] (fc-go) ;
+
+: fc-change-directory ( file-chooser file -- file-chooser )
+ dupd [ path>> value>> normalize-path ] [ name>> ] bi*
+ append-path over path>> set-model
+ update-filelist-model
+;
+
+: fc-load-file ( file-chooser file -- )
+ dupd [ selected-file>> ] [ name>> ] bi* swap set-model
+ [ path>> value>> ]
+ [ selected-file>> value>> append ]
+ [ hook>> ] tri
+ call
+; inline
+
+! : fc-ok-action ( file-chooser -- quot )
+! dup selected-file>> value>> "" =
+! [ drop [ drop ] ] [
+! [ path>> value>> ]
+! [ selected-file>> value>> append ]
+! [ hook>> prefix ] tri
+! [ drop ] prepend
+! ] if ;
+
+: line-selected-action ( file-chooser -- )
+ dup list>> list-value
+ dup directory?
+ [ fc-change-directory ] [ fc-load-file ] if ;
+
+: present-dir-element ( element -- string )
+ [ name>> ] [ directory? ] bi [ "-> " prepend ] when ;
+
+: <file-list> ( file-chooser -- list )
+ dup [ nip line-selected-action ] curry
+ [ present-dir-element ] rot model>> <list> ;
+
+: <file-chooser> ( hook path extension -- gadget )
+ { 0 1 } file-chooser new-track
+ swap >>extension
+ swap <model> >>path
+ "" <model> >>selected-file
+ swap >>hook
+ init-filelist-model
+ dup <file-list> >>list
+ "choose a file in directory " <label> f track-add
+ dup path>> <label-control> f track-add
+ dup extension>> ", " join "limited to : " prepend <label> f track-add
+ <shelf>
+ "selected file : " <label> add-gadget
+ over selected-file>> <label-control> add-gadget
+ f track-add
+ <shelf>
+ over [ swap fc-go-parent ] curry "go up" swap <bevel-button> add-gadget
+ over [ swap fc-go-home ] curry "go home" swap <bevel-button> add-gadget
+ ! over [ swap fc-ok-action ] curry "OK" swap <bevel-button> add-gadget
+ ! [ drop ] "Cancel" swap <bevel-button> add-gadget
+ f track-add
+ dup list>> <scroller> 1 track-add
+;
+
+M: file-chooser pref-dim* drop { 400 200 } ;
+
+: file-chooser-window ( -- )
+[ . ] home { "xml" "txt" } <file-chooser> "Choose a file" open-window ;
+
diff --git a/extra/4DNav/hypercube.xml b/extra/4DNav/hypercube.xml
new file mode 100755
index 0000000000..0d46e3b315
--- /dev/null
+++ b/extra/4DNav/hypercube.xml
@@ -0,0 +1,37 @@
+<model>
+<space>
+ <name>hypercube</name>
+ <dimension>4</dimension>
+ <solid>
+ <name>4cube1</name>
+ <dimension>4</dimension>
+ <face>1,0,0,0,100</face>
+ <face>-1,0,0,0,-150</face>
+ <face>0,1,0,0,100</face>
+ <face>0,-1,0,0,-150</face>
+ <face>0,0,1,0,100</face>
+ <face>0,0,-1,0,-150</face>
+ <face>0,0,0,1,100</face>
+ <face>0,0,0,-1,-150</face>
+ <color>1,0,0</color>
+ </solid>
+ <solid>
+ <name>4cube1</name>
+ <dimension>4</dimension>
+ <face>1,0,0,0,100</face>
+ <face>-1,0,0,0,-150</face>
+ <face>0,1,0,0,100</face>
+ <face>0,-1,0,0,-150</face>
+ <face>0,0,1,0,100</face>
+ <face>0,0,-1,0,-150</face>
+ <face>0,0,0,1,100</face>
+ <face>0,0,0,-1,-150</face>
+ <color>1,0,0</color>
+ </solid>
+ <light>
+ <direction>1,1,1,1</direction>
+ <color>0.2,0.2,0.6</color>
+ </light>
+ <color>0.8,0.9,0.9</color>
+</space>
+</model>
diff --git a/extra/4DNav/light_test.xml b/extra/4DNav/light_test.xml
new file mode 100755
index 0000000000..b7d750ddaa
--- /dev/null
+++ b/extra/4DNav/light_test.xml
@@ -0,0 +1,62 @@
+<model>
+<space>
+ <name>multi solids</name>
+ <dimension>4</dimension>
+ <solid>
+ <name>4cube1</name>
+ <dimension>4</dimension>
+ <face>1,0,0,0,100</face>
+ <face>-1,0,0,0,-150</face>
+ <face>0,1,0,0,100</face>
+ <face>0,-1,0,0,-150</face>
+ <face>0,0,1,0,100</face>
+ <face>0,0,-1,0,-150</face>
+ <face>0,0,0,1,100</face>
+ <face>0,0,0,-1,-150</face>
+ <color>1,1,1</color>
+ </solid>
+ <solid>
+ <name>4triancube</name>
+ <dimension>4</dimension>
+ <face>1,0,0,0,160</face>
+ <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>
+ <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>
+ <face>0,0,1,0,140</face>
+ <face>0,0,-1,0,-180</face>
+ <face>0,0,0,1,110</face>
+ <face>0,0,0,-1,-180</face>
+ <color>1,1,1</color>
+ </solid>
+ <solid>
+ <name>triangone</name>
+ <dimension>4</dimension>
+ <face>1,0,0,0,60</face>
+ <face>0.5,0.8660254037844386,0,0,60</face>
+ <face>-0.5,0.8660254037844387,0,0,-20</face>
+ <face>-1.0,0,0,0,-100</face>
+ <face>-0.5,-0.8660254037844384,0,0,-100</face>
+ <face>0.5,-0.8660254037844387,0,0,-20</face>
+ <face>0,0,1,0,120</face>
+ <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>
+ <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>
+ <color>1,1,1</color>
+ </solid>
+ <light>
+ <direction>1,0,0,0</direction>
+ <color>0,0,0,0.6</color>
+ </light>
+ <light>
+ <direction>0,1,0,0</direction>
+ <color>0,0.6,0,0</color>
+ </light>
+ <light>
+ <direction>0,0,1,0</direction>
+ <color>0,0,0.6,0</color>
+ </light>
+ <light>
+ <direction>0,0,0,1</direction>
+ <color>0.6,0.6,0.6</color>
+ </light>
+ <color>0.99,0.99,0.99</color>
+</space>
+</model>
diff --git a/extra/4DNav/multi solids.xml b/extra/4DNav/multi solids.xml
new file mode 100755
index 0000000000..b401e988b9
--- /dev/null
+++ b/extra/4DNav/multi solids.xml
@@ -0,0 +1,50 @@
+<model>
+<space>
+ <name>multi solids</name>
+ <dimension>4</dimension>
+ <solid>
+ <name>4cube1</name>
+ <dimension>4</dimension>
+ <face>1,0,0,0,100</face>
+ <face>-1,0,0,0,-150</face>
+ <face>0,1,0,0,100</face>
+ <face>0,-1,0,0,-150</face>
+ <face>0,0,1,0,100</face>
+ <face>0,0,-1,0,-150</face>
+ <face>0,0,0,1,100</face>
+ <face>0,0,0,-1,-150</face>
+ <color>1,0,0</color>
+ </solid>
+ <solid>
+ <name>4triancube</name>
+ <dimension>4</dimension>
+ <face>1,0,0,0,160</face>
+ <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>
+ <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>
+ <face>0,0,1,0,140</face>
+ <face>0,0,-1,0,-180</face>
+ <face>0,0,0,1,110</face>
+ <face>0,0,0,-1,-180</face>
+ <color>0,1,0</color>
+ </solid>
+ <solid>
+ <name>triangone</name>
+ <dimension>4</dimension>
+ <face>1,0,0,0,60</face>
+ <face>0.5,0.8660254037844386,0,0,60</face>
+ <face>-0.5,0.8660254037844387,0,0,-20</face>
+ <face>-1.0,0,0,0,-100</face>
+ <face>-0.5,-0.8660254037844384,0,0,-100</face>
+ <face>0.5,-0.8660254037844387,0,0,-20</face>
+ <face>0,0,1,0,120</face>
+ <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>
+ <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>
+ <color>0,1,1</color>
+ </solid>
+ <light>
+ <direction>1,1,1,1</direction>
+ <color>0.2,0.2,0.6</color>
+ </light>
+ <color>0.8,0.9,0.9</color>
+</space>
+</model>
diff --git a/extra/4DNav/prismetriagone.xml b/extra/4DNav/prismetriagone.xml
new file mode 100755
index 0000000000..cbdc071f97
--- /dev/null
+++ b/extra/4DNav/prismetriagone.xml
@@ -0,0 +1,25 @@
+<model>
+<space>
+ <name>Prismetragone</name>
+ <dimension>4</dimension>
+ <solid>
+ <name>triangone</name>
+ <dimension>4</dimension>
+ <face>1,0,0,0,60</face>
+ <face>0.5,0.8660254037844386,0,0,60</face>
+ <face>-0.5,0.8660254037844387,0,0,-20</face>
+ <face>-1.0,0,0,0,-100</face>
+ <face>-0.5,-0.8660254037844384,0,0,-100</face>
+ <face>0.5,-0.8660254037844387,0,0,-20</face>
+ <face>0,0,1,0,120</face>
+ <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>
+ <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>
+ <color>0,1,1</color>
+ </solid>
+ <light>
+ <direction>1,1,1,1</direction>
+ <color>0.2,0.2,0.6</color>
+ </light>
+ <color>0.8,0.9,0.9</color>
+</space>
+</model>
diff --git a/extra/4DNav/space-file-decoder/authors.txt b/extra/4DNav/space-file-decoder/authors.txt
new file mode 100755
index 0000000000..a6a96933f4
--- /dev/null
+++ b/extra/4DNav/space-file-decoder/authors.txt
@@ -0,0 +1 @@
+Jeff Bigot
\ No newline at end of file
diff --git a/extra/4DNav/space-file-decoder/space-file-decoder-docs.factor b/extra/4DNav/space-file-decoder/space-file-decoder-docs.factor
new file mode 100755
index 0000000000..ce66375759
--- /dev/null
+++ b/extra/4DNav/space-file-decoder/space-file-decoder-docs.factor
@@ -0,0 +1,31 @@
+! 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"
diff --git a/extra/4DNav/space-file-decoder/space-file-decoder.factor b/extra/4DNav/space-file-decoder/space-file-decoder.factor
new file mode 100755
index 0000000000..158917ca3e
--- /dev/null
+++ b/extra/4DNav/space-file-decoder/space-file-decoder.factor
@@ -0,0 +1,65 @@
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING: adsoda
+xml
+xml.utilities
+accessors
+combinators
+sequences
+math.parser
+kernel
+splitting
+values
+continuations
+;
+IN: 4DNav.space-file-decoder
+
+: decode-number-array ( x -- y ) "," split [ string>number ] map ;
+
+PROCESS: adsoda-read-model ( tag -- )
+
+TAG: dimension adsoda-read-model children>> first string>number ;
+TAG: direction adsoda-read-model children>> first decode-number-array ;
+TAG: color adsoda-read-model children>> first decode-number-array ;
+TAG: name adsoda-read-model children>> first ;
+TAG: face adsoda-read-model children>> first decode-number-array ;
+
+TAG: solid adsoda-read-model
+ <solid> swap
+ {
+ [ "dimension" tag-named adsoda-read-model >>dimension ]
+ [ "name" tag-named adsoda-read-model >>name ]
+ [ "color" tag-named adsoda-read-model >>color ]
+ [ "face" tags-named [ adsoda-read-model cut-solid ] each ]
+ } cleave
+ ensure-adjacencies
+;
+
+TAG: light adsoda-read-model
+ <light> swap
+ {
+ [ "direction" tag-named adsoda-read-model >>direction ]
+ [ "color" tag-named adsoda-read-model >>color ]
+ } cleave
+;
+
+TAG: space adsoda-read-model
+ <space> swap
+ {
+ [ "dimension" tag-named adsoda-read-model >>dimension ]
+ [ "name" tag-named adsoda-read-model >>name ]
+ [ "color" tag-named adsoda-read-model >>ambient-color ]
+ [ "solid" tags-named [ adsoda-read-model suffix-solids ] each ]
+ [ "light" tags-named [ adsoda-read-model suffix-lights ] each ]
+ } cleave
+;
+
+: read-model-file ( path -- x )
+ dup
+ [
+ [ file>xml "space" tags-named first adsoda-read-model ]
+ [ drop <space> ] recover
+ ] [ drop <space> ] if
+
+;
+
diff --git a/extra/4DNav/summary.txt b/extra/4DNav/summary.txt
new file mode 100755
index 0000000000..5b5a452cde
--- /dev/null
+++ b/extra/4DNav/summary.txt
@@ -0,0 +1 @@
+4DNav : simmple tool to navigate thru a 4D space view as projections on 4 3D spaces.
\ No newline at end of file
diff --git a/extra/4DNav/tags.txt b/extra/4DNav/tags.txt
new file mode 100755
index 0000000000..0c63a72fc9
--- /dev/null
+++ b/extra/4DNav/tags.txt
@@ -0,0 +1 @@
+4D viewer
\ No newline at end of file
diff --git a/extra/4DNav/triancube.xml b/extra/4DNav/triancube.xml
new file mode 100755
index 0000000000..8551bed24c
--- /dev/null
+++ b/extra/4DNav/triancube.xml
@@ -0,0 +1,23 @@
+<model>
+<space>
+ <name>triancube</name>
+ <dimension>4</dimension>
+ <solid>
+ <name>triancube</name>
+ <dimension>4</dimension>
+ <face>1,0,0,0,160</face>
+ <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>
+ <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>
+ <face>0,0,1,0,140</face>
+ <face>0,0,-1,0,-180</face>
+ <face>0,0,0,1,110</face>
+ <face>0,0,0,-1,-180</face>
+ <color>0,1,0</color>
+ </solid>
+ <light>
+ <direction>1,1,1,1</direction>
+ <color>0.2,0.2,0.6</color>
+ </light>
+ <color>0.8,0.9,0.9</color>
+</space>
+</model>
diff --git a/extra/4DNav/turtle/authors.txt b/extra/4DNav/turtle/authors.txt
new file mode 100755
index 0000000000..6cfd5da273
--- /dev/null
+++ b/extra/4DNav/turtle/authors.txt
@@ -0,0 +1 @@
+Eduardo Cavazos
diff --git a/extra/4DNav/turtle/turtle-docs.factor b/extra/4DNav/turtle/turtle-docs.factor
new file mode 100755
index 0000000000..e6f57972b9
--- /dev/null
+++ b/extra/4DNav/turtle/turtle-docs.factor
@@ -0,0 +1,229 @@
+! 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"
diff --git a/extra/4DNav/turtle/turtle.factor b/extra/4DNav/turtle/turtle.factor
new file mode 100755
index 0000000000..72a2e58e9b
--- /dev/null
+++ b/extra/4DNav/turtle/turtle.factor
@@ -0,0 +1,152 @@
+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 ;
diff --git a/extra/4DNav/window3D/authors.txt b/extra/4DNav/window3D/authors.txt
new file mode 100755
index 0000000000..a6a96933f4
--- /dev/null
+++ b/extra/4DNav/window3D/authors.txt
@@ -0,0 +1 @@
+Jeff Bigot
\ No newline at end of file
diff --git a/extra/4DNav/window3D/window3D-docs.factor b/extra/4DNav/window3D/window3D-docs.factor
new file mode 100755
index 0000000000..d57df6a8d8
--- /dev/null
+++ b/extra/4DNav/window3D/window3D-docs.factor
@@ -0,0 +1,20 @@
+! 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"
diff --git a/extra/4DNav/window3D/window3D.factor b/extra/4DNav/window3D/window3D.factor
new file mode 100755
index 0000000000..6db5d7c2f5
--- /dev/null
+++ b/extra/4DNav/window3D/window3D.factor
@@ -0,0 +1,82 @@
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel
+ui.gadgets
+ui.render
+opengl
+opengl.gl
+opengl.glu
+4DNav.camera
+4DNav.turtle
+math
+values
+alien.c-types
+accessors
+namespaces
+adsoda
+models
+accessors
+prettyprint
+;
+
+IN: 4DNav.window3D
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! drawing functions
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: window3D < gadget observer ;
+
+: <window3D> ( model observer -- gadget )
+ window3D new-gadget
+ swap 2dup
+ projection-mode>> add-connection
+ 2dup
+ collision-mode>> add-connection
+ >>observer
+ swap <model> >>model
+ t >>root?
+;
+
+M: window3D pref-dim* ( gadget -- dim ) drop { 300 300 } ;
+
+M: window3D draw-gadget* ( gadget -- )
+
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ 0.6 0.6 0.6 .9 glClearColor
+ dup observer>> projection-mode>> value>> 1 =
+ [ 60.0 1.0 0.1 3000.0 gluPerspective ]
+ [ -400.0 400.0 -400.0 400.0 0.0 4000.0 glOrtho ] if
+ dup observer>> collision-mode>> value>>
+ \ remove-hidden-solids?
+ set-value
+ dup observer>> do-look-at
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+ 0.9 0.9 0.9 1.0 glClearColor
+ 1.0 glClearDepth
+ GL_LINE_SMOOTH glEnable
+ GL_BLEND glEnable
+ GL_DEPTH_TEST glEnable
+ GL_LEQUAL glDepthFunc
+ GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
+ GL_LINE_SMOOTH_HINT GL_NICEST glHint
+ 1.25 glLineWidth
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+ glLoadIdentity
+ GL_LIGHTING glEnable
+ GL_LIGHT0 glEnable
+ GL_COLOR_MATERIAL glEnable
+ GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
+ ! *************************
+
+ model>> value>>
+ [ space->GL ] when*
+
+ ! *************************
+;
+
+M: window3D graft* drop ;
+
+M: window3D model-changed nip relayout ;
diff --git a/extra/adsoda/adsoda-docs.factor b/extra/adsoda/adsoda-docs.factor
new file mode 100755
index 0000000000..d90beb7c7b
--- /dev/null
+++ b/extra/adsoda/adsoda-docs.factor
@@ -0,0 +1,300 @@
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+
+IN: adsoda
+
+
+
+! --------------------------------------------------------------
+! faces
+! --------------------------------------------------------------
+ARTICLE: "face-page" "face in ADSODA"
+"explanation of faces"
+$nl
+"link to functions"
+"what is an halfspace"
+"halfspace touching-corners adjacent-faces"
+"touching-corners list of pointers to the corners which touch this face\n"
+
+"adjacent-faces list of pointers to the faces which touch this face\n"
+{ $subsection face }
+{ $subsection <face> }
+"test relative position"
+{ $subsection point-inside-or-on-face? }
+{ $subsection point-inside-face? }
+"handling face"
+{ $subsection flip-face }
+{ $subsection face-translate }
+{ $subsection face-transform }
+
+;
+
+HELP: face
+{ $class-description "a face is defined by"
+{ $list "halfspace equation" }
+{ $list "list of touching corners" }
+{ $list "list of adjacent faces" }
+$nl
+"Touching corners and adjacent faces are defined by algorithm thanks to other faces of the solid"
+}
+
+
+;
+HELP: <face>
+{ $values { "v" "an halfspace equation" } { "tuple" "a face" } } ;
+HELP: flip-face
+{ $values { "face" "a face" } { "face" "flipped face" } }
+{ $description "change the orientation of a face" }
+;
+
+HELP: face-translate
+{ $values { "face" "a face" } { "v" "a vector" } }
+{ $description
+"translate a face following a vector"
+$nl
+"a translation of an halfspace doesn't change the normal vector. this word just compute the new constant term" }
+
+
+ ;
+HELP: face-transform
+{ $values { "face" "a face" } { "m" "a transformation matrix" } }
+{ $description "compute the transformation of a face using a transformation matrix" }
+
+ ;
+! --------------------------------
+! solid
+! --------------------------------------------------------------
+ARTICLE: "solid-page" "solid in ADSODA"
+"explanation of solids"
+$nl
+"link to functions"
+{ $subsection solid }
+{ $subsection <solid> }
+"test relative position"
+{ $subsection point-inside-solid? }
+{ $subsection point-inside-or-on-solid? }
+"playing with faces and solids"
+{ $subsection add-face }
+{ $subsection cut-solid }
+{ $subsection slice-solid }
+"solid handling"
+{ $subsection solid-project }
+{ $subsection solid-translate }
+{ $subsection solid-transform }
+{ $subsection subtract }
+
+{ $subsection get-silhouette }
+
+{ $subsection solid= }
+
+
+;
+
+HELP: solid
+{ $class-description "dimension" $nl "silhouettes" $nl "faces" $nl "corners" $nl "adjacencies-valid" $nl "color" $nl "name"
+}
+;
+
+HELP: add-face
+{ $values { "solid" "a solid" } { "face" "a face" } }
+{ $description "reshape a solid with a face. The face truncate the solid." } ;
+
+HELP: cut-solid
+{ $values { "solid" "a solid" } { "halfspace" "an halfspace" } }
+{ $description "like add-face but just with halfspace equation" } ;
+
+HELP: slice-solid
+{ $values { "solid" "a solid" } { "face" "a face" } { "solid1" "the outer part of the former solid" } { "solid2" "the inner part of the former solid" } }
+{ $description "cut a solid into two parts. The face acts like a knife"
+} ;
+
+
+HELP: solid-project
+{ $values { "lights" "lights" } { "ambient" "ambient" } { "solid" "solid" } { "solids" "projection of solid" } }
+{ $description "Project the solid using pv vector"
+$nl
+"TODO: explain how to use lights"
+} ;
+
+HELP: solid-translate
+{ $values { "solid" "a solid" } { "v" "translating vector" } }
+{ $description "Translate a solid using a vector"
+$nl
+"v and solid must have the same dimension "
+} ;
+
+HELP: solid-transform
+{ $values { "solid" "a solid" } { "m" "transformation matrix" } }
+{ $description "Transform a solid using a matrix"
+$nl
+"v and solid must have the same dimension "
+} ;
+
+HELP: subtract
+{ $values { "solid1" "initial shape" } { "solid2" "shape to remove" } { "solids" "resulting shape" } }
+{ $description " " } ;
+
+
+! --------------------------------------------------------------
+! space
+! --------------------------------------------------------------
+ARTICLE: "space-page" "space in ADSODA"
+"A space is a collection of solids and lights."
+$nl
+"link to functions"
+$nl
+"Defining words"
+{ $subsection space }
+{ $subsection <space> }
+{ $subsection suffix-solids }
+{ $subsection suffix-lights }
+{ $subsection clear-space-solids }
+{ $subsection describe-space }
+
+
+"Handling space"
+{ $subsection space-ensure-solids }
+{ $subsection eliminate-empty-solids }
+{ $subsection space-transform }
+{ $subsection space-translate }
+{ $subsection remove-hidden-solids }
+{ $subsection space-project }
+
+
+;
+
+HELP: space
+{ $class-description
+"dimension" $nl " solids" $nl " ambient-color" $nl "lights"
+}
+;
+
+HELP: suffix-solids
+"( space solid -- space )"
+{ $values { "space" "a space" } { "solid" "a solid to add" } }
+{ $description "Add solid to space definition" } ;
+
+HELP: suffix-lights
+"( space light -- space ) "
+{ $values { "space" "a space" } { "light" "a light to add" } }
+{ $description "Add a light to space definition" } ;
+
+HELP: clear-space-solids
+"( space -- space )"
+{ $values { "space" "a space" } }
+{ $description "remove all solids in space" } ;
+
+HELP: space-ensure-solids
+{ $values { "space" "a space" } }
+{ $description "rebuild corners of all solids in space" } ;
+
+
+
+HELP: space-transform
+" ( space m -- space )"
+{ $values { "space" "a space" } { "m" "a matrix" } }
+{ $description "Transform a space using a matrix" } ;
+
+HELP: space-translate
+{ $values { "space" "a space" } { "v" "a vector" } }
+{ $description "Translate a space following a vector" } ;
+
+HELP: describe-space " ( space -- )"
+{ $values { "space" "a space" } }
+{ $description "return a description of space" } ;
+
+HELP: space-project
+{ $values { "space" "a space" } { "i" "an integer" } }
+{ $description "Project a space along ith coordinate" } ;
+
+! --------------------------------------------------------------
+! 3D rendering
+! --------------------------------------------------------------
+ARTICLE: "3D-rendering-page" "3D rendering in ADSODA"
+"explanation of 3D rendering"
+$nl
+"link to functions"
+{ $subsection face->GL }
+{ $subsection solid->GL }
+{ $subsection space->GL }
+
+;
+
+HELP: face->GL
+{ $values { "face" "a face" } { "color" "3 3 values array" } }
+{ $description "" } ;
+
+HELP: solid->GL
+{ $values { "solid" "a solid" } }
+{ $description "" } ;
+
+HELP: space->GL
+{ $values { "space" "a space" } }
+{ $description "" } ;
+
+! --------------------------------------------------------------
+! light
+! --------------------------------------------------------------
+
+ARTICLE: "light-page" "light in ADSODA"
+"explanation of light"
+$nl
+"link to functions"
+;
+
+ARTICLE: { "adsoda" "light" } "ADSODA : lights"
+"! HELP: light position color"
+"! <light> ( -- tuple ) light new ;"
+
+"! light est un vecteur avec 3 variables pour les couleurs\n"
+
+" void Light::Apply(Vector& normal, double &cRed, double &cGreen, double &cBlue)\n"
+" { \n"
+" // Dot the light direction with the normalized normal of Face."
+" register double intensity = -(normal * (*this));"
+
+" // Face is a backface, from light's perspective"
+" if (intensity < 0)"
+" return;"
+" "
+" // Add the intensity componentwise"
+" cRed += red * intensity;"
+" cGreen += green * intensity;"
+" cBlue += blue * intensity;"
+
+" // Clip to unit range"
+" if (cRed > 1.0) cRed = 1.0;"
+" if (cGreen > 1.0) cGreen = 1.0;"
+" if (cBlue > 1.0) cBlue = 1.0;"
+
+
+;
+
+
+
+ARTICLE: { "adsoda" "halfspace" } "ADSODA : halfspace"
+"! demi espace d�fini par un vecteur normal et une constante"
+" defined by the concatenation of the normal vector and a constant"
+ ;
+
+
+
+ARTICLE: "adsoda-main-page" "ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm"
+"multidimensional handler :"
+$nl
+"design a solid using face delimitations. Only works on convex shapes"
+$nl
+{ $emphasis "written in C++ by Greg Ferrar" }
+$nl
+"full explanation on adsoda page at " { $url "http://www.flowerfire.com/ADSODA/" }
+$nl
+"Useful words are describe on the following pages: "
+{ $subsection "face-page" }
+{ $subsection "solid-page" }
+{ $subsection "space-page" }
+{ $subsection "light-page" }
+{ $subsection "3D-rendering-page" }
+ ;
+
+ABOUT: "adsoda-main-page"
diff --git a/extra/adsoda/adsoda-tests.factor b/extra/adsoda/adsoda-tests.factor
new file mode 100755
index 0000000000..f8881dfebb
--- /dev/null
+++ b/extra/adsoda/adsoda-tests.factor
@@ -0,0 +1,310 @@
+USING: adsoda
+kernel
+math
+accessors
+sequences
+ adsoda.solution2
+ fry
+ tools.test
+ arrays ;
+
+IN: adsoda.tests
+
+
+
+: s1 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "s1" >>name
+ { 1 1 1 } >>color
+ { 1 -1 -5 } cut-solid
+ { -1 -1 -21 } cut-solid
+ { -1 0 -12 } cut-solid
+ { 1 2 16 } cut-solid
+;
+: solid1 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid1" >>name
+ { 1 -1 -5 } cut-solid
+ { -1 -1 -21 } cut-solid
+ { -1 0 -12 } cut-solid
+ { 1 2 16 } cut-solid
+ ensure-adjacencies
+
+;
+: solid2 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid2" >>name
+ { -1 1 -10 } cut-solid
+ { -1 -1 -28 } cut-solid
+ { 1 0 13 } cut-solid
+ ! { 1 2 16 } cut-solid
+ ensure-adjacencies
+
+;
+
+: solid3 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid3" >>name
+ { 1 1 1 } >>color
+ { 1 0 16 } cut-solid
+ { -1 0 -36 } cut-solid
+ { 0 1 1 } cut-solid
+ { 0 -1 -17 } cut-solid
+ ! { 1 2 16 } cut-solid
+ ensure-adjacencies
+
+
+;
+
+: solid4 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid4" >>name
+ { 1 1 1 } >>color
+ { 1 0 21 } cut-solid
+ { -1 0 -36 } cut-solid
+ { 0 1 1 } cut-solid
+ { 0 -1 -17 } cut-solid
+ ensure-adjacencies
+
+;
+
+: solid5 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid5" >>name
+ { 1 1 1 } >>color
+ { 1 0 6 } cut-solid
+ { -1 0 -17 } cut-solid
+ { 0 1 17 } cut-solid
+ { 0 -1 -19 } cut-solid
+ ensure-adjacencies
+
+;
+
+: solid7 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid7" >>name
+ { 1 1 1 } >>color
+ { 1 0 38 } cut-solid
+ { 1 -5 -66 } cut-solid
+ { -2 1 -75 } cut-solid
+ ensure-adjacencies
+
+;
+
+: solid6s ( -- seq )
+ solid3 clone solid2 clone subtract
+;
+
+: space1 ( -- space )
+ <space>
+ 2 >>dimension
+ ! solid3 suffix-solids
+ solid1 suffix-solids
+ solid2 suffix-solids
+ ! solid6s [ suffix-solids ] each
+ solid4 suffix-solids
+ ! solid5 suffix-solids
+ solid7 suffix-solids
+ { 1 1 1 } >>ambient-color
+ <light>
+ { -100 -100 } >>position
+ { 0.2 0.7 0.1 } >>color
+ suffix-lights
+;
+
+: space2 ( -- space )
+ <space>
+ 4 >>dimension
+ ! 4cube suffix-solids
+ { 1 1 1 } >>ambient-color
+ <light>
+ { -100 -100 } >>position
+ { 0.2 0.7 0.1 } >>color
+ suffix-lights
+
+ ;
+
+
+
+! {
+! { 1 0 0 0 }
+! { 0 1 0 0 }
+! { 0 0 0.984807753012208 -0.1736481776669303 }
+! { 0 0 0.1736481776669303 0.984807753012208 }
+! }
+
+! ------------------------------------------------------------
+! constant+
+[ { 1 2 5 } ] [ { 1 2 3 } 2 constant+ ] unit-test
+
+! ------------------------------------------------------------
+! translate
+[ { 1 -1 0 } ] [ { 1 -1 -5 } { 3 -2 } translate ] unit-test
+
+! ------------------------------------------------------------
+! transform
+[ { -1 -1 -5 21.0 } ] [ { -1 -1 -5 21 }
+ { { 1 0 0 }
+ { 0 1 0 }
+ { 0 0 1 }
+ } transform
+] unit-test
+
+! ------------------------------------------------------------
+! compare-nleft-to-identity-matrix
+[ t ] [
+ {
+ { 1 0 0 1232 }
+ { 0 1 0 0 321 }
+ { 0 0 1 0 } }
+ 3 compare-nleft-to-identity-matrix
+] unit-test
+
+[ f ] [
+ { { 1 0 0 } { 0 1 0 } { 0 0 0 } }
+ 3 compare-nleft-to-identity-matrix
+] unit-test
+
+[ f ] [
+ { { 2 0 0 } { 0 1 0 } { 0 0 1 } }
+ 3 compare-nleft-to-identity-matrix
+] unit-test
+! ------------------------------------------------------------
+[ t ] [
+ { { 1 0 0 }
+ { 0 1 0 }
+ { 0 0 1 } } 3 valid-solution?
+] unit-test
+
+[ f ] [
+ { { 1 0 0 1 }
+ { 0 0 0 1 }
+ { 0 0 1 0 } } 3 valid-solution?
+] unit-test
+
+[ f ] [
+ { { 1 0 0 1 }
+ { 0 0 0 1 } } 3 valid-solution?
+] unit-test
+
+[ f ] [
+ { { 1 0 0 1 }
+ { 0 0 0 1 }
+ { 0 0 1 0 } } 2 valid-solution?
+] unit-test
+
+! ------------------------------------------------------------
+[ 3 ] [ { 1 2 3 } last ] unit-test
+
+[ { 1 2 5 } ] [ { 1 2 3 } dup [ 2 + ] change-last ] unit-test
+
+! ------------------------------------------------------------
+! position-point
+[ 0 ] [
+ { 1 -1 -5 } { 2 7 } position-point
+] unit-test
+
+! ------------------------------------------------------------
+
+! transform
+! TODO construire un exemple
+
+
+! ------------------------------------------------------------
+! slice-solid
+
+! ------------------------------------------------------------
+! solve-equation
+! deux cas de tests, avec solution et sans solution
+
+[ { 2 7 } ]
+[ { { 1 -1 -5 } { 1 2 16 } } intersect-hyperplanes ]
+unit-test
+
+[ f ]
+[ { { 1 -1 -5 } { 1 2 16 } { -1 -1 -21 } } intersect-hyperplanes ]
+unit-test
+
+[ f ]
+[ { { 1 0 -5 } { 1 0 16 } } intersect-hyperplanes ]
+unit-test
+
+! ------------------------------------------------------------
+! point-inside-halfspace
+[ t ] [ { 1 -1 -5 } { 0 0 } point-inside-halfspace? ]
+unit-test
+[ f ] [ { 1 -1 -5 } { 8 13 } point-inside-halfspace? ]
+unit-test
+[ t ] [ { 1 -1 -5 } { 8 13 } point-inside-or-on-halfspace? ]
+unit-test
+
+
+! ------------------------------
+! order solid
+
+[ 1 ] [ 0 >pv solid1 solid2 order-solid ] unit-test
+[ -1 ] [ 0 >pv solid2 solid1 order-solid ] unit-test
+[ f ] [ 1 >pv solid1 solid2 order-solid ] unit-test
+[ f ] [ 1 >pv solid2 solid1 order-solid ] unit-test
+
+
+! clip-solid
+[ { { 13 15 } { 15 13 } { 13 13 } } ]
+ [ 0 >pv solid2 solid1 clip-solid first corners>> ] unit-test
+
+solid1 corners>> '[ _ ]
+ [ 0 >pv solid1 solid1 clip-solid first corners>> ] unit-test
+
+solid1 corners>> '[ _ ]
+ [ 0 >pv solid1 solid2 clip-solid first corners>> ] unit-test
+
+solid1 corners>> '[ _ ]
+ [ 1 >pv solid1 solid2 clip-solid first corners>> ] unit-test
+solid2 corners>> '[ _ ]
+ [ 1 >pv solid2 solid1 clip-solid first corners>> ] unit-test
+
+!
+[
+ {
+ { { 13 15 } { 15 13 } { 13 13 } }
+ { { 16 17 } { 16 13 } { 36 17 } { 36 13 } }
+ { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }
+ }
+] [ 0 >pv solid2 solid3 2array
+ solid1 (solids-silhouette-subtract)
+ [ corners>> ] map
+ ] unit-test
+
+
+[
+{
+ { { 8 13 } { 2 7 } { 12 9 } { 12 2 } }
+ { { 13 15 } { 15 13 } { 13 13 } }
+ { { 16 17 } { 16 15 } { 36 17 } { 36 15 } }
+ { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }
+}
+] [
+ 0 >pv <space> solid1 suffix-solids
+ solid2 suffix-solids
+ solid3 suffix-solids
+ remove-hidden-solids
+ solids>> [ corners>> ] map
+] unit-test
+
+! { }
+! { }
+! <light> { 0.2 0.3 0.4 } >>color { 1 -1 1 } >>direction suffix
+! <light> { 0.4 0.3 0.1 } >>color { -1 -1 -1 } >>direction suffix
+! suffix
+! { 0.1 0.1 0.1 } suffix ! ambient color
+! { 0.23 0.32 0.17 } suffix ! solid color
+! solid3 faces>> first
+
+! enlight-projection
diff --git a/extra/adsoda/adsoda.factor b/extra/adsoda/adsoda.factor
new file mode 100755
index 0000000000..e586087e48
--- /dev/null
+++ b/extra/adsoda/adsoda.factor
@@ -0,0 +1,543 @@
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors
+arrays
+assocs
+combinators
+kernel
+fry
+math
+math.constants
+math.functions
+math.libm
+math.order
+math.vectors
+math.matrices
+math.parser
+namespaces
+prettyprint
+sequences
+sequences.deep
+sets
+slots
+sorting
+tools.time
+vars
+continuations
+words
+opengl
+opengl.gl
+colors
+adsoda.solution2
+adsoda.combinators
+opengl.demo-support
+values
+tools.walker
+;
+
+IN: adsoda
+
+DEFER: combinations
+VAR: pv
+
+
+! ---------------------------------------------------------------------
+! global values
+VALUE: remove-hidden-solids?
+VALUE: VERY-SMALL-NUM
+VALUE: ZERO-VALUE
+VALUE: MAX-FACE-PER-CORNER
+
+t to: remove-hidden-solids?
+0.0000001 to: VERY-SMALL-NUM
+0.0000001 to: ZERO-VALUE
+4 to: MAX-FACE-PER-CORNER
+! ---------------------------------------------------------------------
+! sequence complement
+
+: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline
+
+: dimension ( array -- x ) length 1- ; inline
+: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline
+: change-last ( seq quot -- ) [ [ dimension ] keep ] dip change-nth ;
+
+! --------------------------------------------------------------
+! light
+! --------------------------------------------------------------
+
+TUPLE: light name { direction array } color ;
+: <light> ( -- tuple ) light new ;
+
+! -----------------------------------------------------------------------
+! halfspace manipulation
+! -----------------------------------------------------------------------
+
+: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;
+: translate ( u v -- w ) dupd v* sum constant+ ;
+
+: transform ( u matrix -- w )
+ [ swap m.v ] 2keep ! compute new normal vector
+ [
+ [ [ abs ZERO-VALUE > ] find ] keep ! find a point on the frontier
+ ! be sure it's not null vector
+ last ! get constant
+ swap /f neg swap ! intercept value
+ ] dip
+ flip
+ nth
+ [ * ] with map ! apply intercep value
+ over v*
+ sum neg
+ suffix ! add value as constant at the end of equation
+;
+
+: position-point ( halfspace v -- x )
+ -1 suffix v* sum ; inline
+: point-inside-halfspace? ( halfspace v -- ? )
+ position-point VERY-SMALL-NUM > ;
+: point-inside-or-on-halfspace? ( halfspace v -- ? )
+ position-point VERY-SMALL-NUM neg > ;
+: project-vector ( seq -- seq ) pv> [ head ] [ 1+ tail ] 2bi append ;
+: get-intersection ( matrice -- seq ) [ 1 tail* ] map flip first ;
+
+: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;
+
+: compare-nleft-to-identity-matrix ( seq n -- ? )
+ [ [ head ] curry map ] keep identity-matrix m-
+ flatten
+ [ abs ZERO-VALUE < ] all?
+;
+
+: valid-solution? ( matrice n -- ? )
+ islenght=?
+ [ compare-nleft-to-identity-matrix ]
+ [ 2drop f ] if ; inline
+
+: intersect-hyperplanes ( matrice -- seq )
+ [ solution dup ] [ first dimension ] bi
+ valid-solution? [ get-intersection ] [ drop f ] if ;
+
+! --------------------------------------------------------------
+! faces
+! --------------------------------------------------------------
+
+TUPLE: face { halfspace array } touching-corners adjacent-faces ;
+: <face> ( v -- tuple ) face new swap >>halfspace ;
+: flip-face ( face -- face ) [ vneg ] change-halfspace ;
+: erase-face-touching-corners ( face -- face ) f >>touching-corners ;
+: erase-face-adjacent-faces ( face -- face ) f >>adjacent-faces ;
+: faces-intersection ( faces -- v )
+ [ halfspace>> ] map intersect-hyperplanes ;
+: face-translate ( face v -- face )
+ [ translate ] curry change-halfspace ; inline
+: face-transform ( face m -- face )
+ [ transform ] curry change-halfspace ; inline
+: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;
+: backface? ( face -- face ? ) dup face-orientation 0 <= ;
+: pv-factor ( face -- f face )
+ halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline
+: suffix-touching-corner ( face corner -- face )
+ [ suffix ] curry change-touching-corners ; inline
+: real-face? ( face -- ? )
+ [ touching-corners>> length ] [ halfspace>> dimension ] bi >= ;
+
+: (add-to-adjacent-faces) ( face face -- face )
+ over adjacent-faces>> 2dup member?
+ [ 2drop ] [ swap suffix >>adjacent-faces ] if ;
+
+: add-to-adjacent-faces ( face face -- face )
+ 2dup = [ drop ] [ (add-to-adjacent-faces) ] if ;
+
+: update-adjacent-faces ( faces corner -- )
+ '[ [ _ suffix-touching-corner drop ] each ] keep
+ 2 among [
+ [ first ] keep second
+ [ add-to-adjacent-faces drop ] 2keep
+ swap add-to-adjacent-faces drop
+ ] each ; inline
+
+: face-project-dim ( face -- x ) halfspace>> length 2 - ;
+
+: apply-light ( color light normal -- u )
+ over direction>> v.
+ neg dup 0 >
+ [
+ [ color>> swap ] dip
+ [ * ] curry map v+
+ [ 1 min ] map
+ ]
+ [ 2drop ]
+ if
+;
+
+: enlight-projection ( array face -- color )
+ ! array = lights + ambient color
+ [ [ third ] [ second ] [ first ] tri ]
+ [ halfspace>> project-vector normalize ] bi*
+ [ apply-light ] curry each
+ v*
+;
+
+: (intersection-into-face) ( face-init face-adja quot -- face )
+ [
+ [ [ pv-factor ] bi@
+ roll
+ [ map ] 2bi@
+ v-
+ ] 2keep
+ [ touching-corners>> ] bi@
+ [ swap [ = ] curry find nip f = ] curry find nip
+ ] dip over
+ [
+ call
+ dupd
+ point-inside-halfspace? [ vneg ] unless
+ <face>
+ ] [ 3drop f ] if
+ ; inline
+
+: intersection-into-face ( face-init face-adja -- face )
+ [ [ project-vector ] bi@ ] (intersection-into-face) ;
+
+: intersection-into-silhouette-face ( face-init face-adja -- face )
+ [ ] (intersection-into-face) ;
+
+: intersections-into-faces ( face -- faces )
+ clone dup adjacent-faces>> [ intersection-into-face ] with map
+ [ ] filter ;
+
+: (face-silhouette) ( face -- faces )
+ clone dup adjacent-faces>>
+ [ backface?
+ [ intersection-into-silhouette-face ] [ 2drop f ] if
+ ] with map
+ [ ] filter
+; inline
+
+: face-silhouette ( face -- faces )
+ backface? [ drop f ] [ (face-silhouette) ] if ;
+
+! --------------------------------
+! solid
+! --------------------------------------------------------------
+TUPLE: solid dimension silhouettes faces corners adjacencies-valid color name ;
+
+: <solid> ( -- tuple ) solid new ;
+
+: suffix-silhouettes ( solid silhouette -- solid )
+ [ suffix ] curry change-silhouettes ;
+
+: suffix-face ( solid face -- solid ) [ suffix ] curry change-faces ;
+
+: suffix-corner ( solid corner -- solid ) [ suffix ] curry change-corners ;
+
+: erase-solid-corners ( solid -- solid ) f >>corners ;
+
+: erase-silhouettes ( solid -- solid ) dup dimension>> f <array> >>silhouettes ;
+
+: filter-real-faces ( solid -- solid ) [ [ real-face? ] filter ] change-faces ;
+
+: initiate-solid-from-face ( face -- solid )
+ face-project-dim <solid> swap >>dimension ;
+
+: erase-old-adjacencies ( solid -- solid )
+ erase-solid-corners
+ [ dup [ erase-face-touching-corners erase-face-adjacent-faces drop ] each ]
+ change-faces ;
+
+: point-inside-or-on-face? ( face v -- ? )
+ [ halfspace>> ] dip point-inside-or-on-halfspace? ;
+
+: point-inside-face? ( face v -- ? )
+ [ halfspace>> ] dip point-inside-halfspace? ;
+
+: point-inside-solid? ( solid point -- ? )
+ [ faces>> ] dip [ point-inside-face? ] curry all? ; inline
+
+: point-inside-or-on-solid? ( solid point -- ? )
+ [ faces>> ] dip [ point-inside-or-on-face? ] curry all? ; inline
+
+: unvalid-adjacencies ( solid -- solid )
+ erase-old-adjacencies f >>adjacencies-valid erase-silhouettes ;
+
+: add-face ( solid face -- solid )
+ suffix-face unvalid-adjacencies ;
+
+: cut-solid ( solid halfspace -- solid ) <face> add-face ;
+
+: slice-solid ( solid face -- solid1 solid2 )
+ [ [ clone ] bi@ flip-face add-face
+ [ "/outer/" append ] change-name ] 2keep
+ add-face [ "/inner/" append ] change-name ;
+
+! -------------
+
+
+: add-silhouette ( solid -- solid )
+ dup
+ ! find-adjacencies
+ faces>> { }
+ [ face-silhouette append ] reduce
+ [ ] filter
+ <solid>
+ swap >>faces
+ over dimension>> >>dimension
+ over name>> " silhouette " append
+ pv> number>string append
+ >>name
+ ! ensure-adjacencies
+ suffix-silhouettes ; inline
+
+: find-silhouettes ( solid -- solid )
+ { } >>silhouettes
+ dup dimension>> [ [ add-silhouette ] with-pv ] each ;
+
+: ensure-silhouettes ( solid -- solid )
+ dup silhouettes>> [ f = ] all?
+ [ find-silhouettes ] when ;
+
+! ------------
+
+: corner-added? ( solid corner -- ? )
+ ! add corner to solid if it is inside solid
+ [ ]
+ [ point-inside-or-on-solid? ]
+ [ swap corners>> member? not ]
+ 2tri and
+ [ suffix-corner drop t ] [ 2drop f ] if ;
+
+: process-corner ( solid faces corner -- )
+ swapd
+ [ corner-added? ] keep swap ! test if corner is inside solid
+ [ update-adjacent-faces ]
+ [ 2drop ]
+ if ;
+
+: compute-intersection ( solid faces -- )
+ dup faces-intersection
+ dup f = [ 3drop ] [ process-corner ] if ;
+
+: test-faces-combinaisons ( solid n -- )
+ [ dup faces>> ] dip among
+ [ compute-intersection ] with each ;
+
+: compute-adjacencies ( solid -- solid )
+ dup dimension>> [ >= ] curry
+ [ keep swap ] curry MAX-FACE-PER-CORNER swap
+ [ [ test-faces-combinaisons ] 2keep 1- ] [ ] while drop ;
+
+: find-adjacencies ( solid -- solid )
+ erase-old-adjacencies
+ compute-adjacencies
+ filter-real-faces
+ t >>adjacencies-valid ;
+
+: ensure-adjacencies ( solid -- solid )
+ dup adjacencies-valid>>
+ [ find-adjacencies ] unless
+ ensure-silhouettes
+ ;
+
+: (non-empty-solid?) ( solid -- ? ) [ dimension>> ] [ corners>> length ] bi < ;
+: non-empty-solid? ( solid -- ? ) ensure-adjacencies (non-empty-solid?) ;
+
+: compare-corners-roughly ( corner corner -- ? )
+ 2drop t ;
+! : remove-inner-faces ( -- ) ;
+: face-project ( array face -- seq )
+ backface?
+ [ 2drop f ]
+ [ [ enlight-projection ]
+ [ initiate-solid-from-face ]
+ [ intersections-into-faces ] tri
+ >>faces
+ swap >>color
+ ] if ;
+
+: solid-project ( lights ambient solid -- solids )
+ ensure-adjacencies
+ [ color>> ] [ faces>> ] bi [ 3array ] dip
+ [ face-project ] with map
+ [ ] filter
+ [ ensure-adjacencies ] map
+;
+
+: (solid-move) ( solid v move -- solid )
+ curry [ map ] curry
+ [ dup faces>> ] dip call drop
+ unvalid-adjacencies ; inline
+
+: solid-translate ( solid v -- solid ) [ face-translate ] (solid-move) ;
+: solid-transform ( solid m -- solid ) [ face-transform ] (solid-move) ;
+
+: find-corner-in-silhouette ( s1 s2 -- elt bool )
+ pv> swap silhouettes>> nth
+ swap corners>>
+ [ point-inside-solid? ] with find swap ;
+
+: valid-face-for-order ( solid point -- face )
+ [ point-inside-face? not ]
+ [ drop face-orientation 0 = not ] 2bi and ;
+
+: check-orientation ( s1 s2 pt -- int )
+ [ nip faces>> ] dip
+ [ valid-face-for-order ] curry find swap
+ [ face-orientation ] [ drop f ] if ;
+
+: (order-solid) ( s1 s2 -- int )
+ 2dup find-corner-in-silhouette
+ [ check-orientation ] [ 3drop f ] if ;
+
+: order-solid ( solid solid -- i )
+ 2dup (order-solid)
+ [ 2nip ]
+ [ swap (order-solid)
+ [ neg ] [ f ] if*
+ ] if* ;
+
+: subtract ( solid1 solid2 -- solids )
+ faces>> swap clone ensure-adjacencies ensure-silhouettes
+ [ swap slice-solid drop ] curry map
+ [ non-empty-solid? ] filter
+ [ ensure-adjacencies ] map
+; inline
+
+! --------------------------------------------------------------
+! space
+! --------------------------------------------------------------
+TUPLE: space name dimension solids ambient-color lights ;
+: <space> ( -- space ) space new ;
+: suffix-solids ( space solid -- space ) [ suffix ] curry change-solids ; inline
+: suffix-lights ( space light -- space ) [ suffix ] curry change-lights ; inline
+: clear-space-solids ( space -- space ) f >>solids ;
+
+: space-ensure-solids ( space -- space )
+ [ [ ensure-adjacencies ] map ] change-solids ;
+: eliminate-empty-solids ( space -- space )
+ [ [ non-empty-solid? ] filter ] change-solids ;
+
+: projected-space ( space solids -- space )
+ swap dimension>> 1- <space> swap >>dimension swap >>solids ;
+
+: get-silhouette ( solid -- silhouette ) silhouettes>> pv> swap nth ;
+: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;
+
+: space-apply ( space m quot -- space )
+ curry [ map ] curry [ dup solids>> ] dip
+ [ call ] [ drop ] recover drop ;
+: space-transform ( space m -- space ) [ solid-transform ] space-apply ;
+: space-translate ( space v -- space ) [ solid-translate ] space-apply ;
+
+: describe-space ( space -- )
+ solids>> [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;
+
+: clip-solid ( solid solid -- solids )
+ [ ]
+ [ solid= not ]
+ [ order-solid -1 = ] 2tri
+ and
+ [ get-silhouette subtract ]
+ [ drop 1array ]
+ if
+
+ ;
+
+: (solids-silhouette-subtract) ( solids solid -- solids )
+ [ clip-solid append ] curry { } -rot each ; inline
+
+: solids-silhouette-subtract ( solids i solid -- solids )
+! solids is an array of 1 solid arrays
+ [ (solids-silhouette-subtract) ] curry map-but
+; inline
+
+: remove-hidden-solids ( space -- space )
+! We must include each solid in a sequence because during substration
+! a solid can be divided in more than on solid
+ [
+ [ [ 1array ] map ]
+ [ length ]
+ [ ]
+ tri
+ [ solids-silhouette-subtract ] 2each
+ { } [ append ] reduce
+ ] change-solids
+ eliminate-empty-solids ! TODO include into change-solids
+;
+
+: space-project ( space i -- space )
+ [
+ [ clone
+ remove-hidden-solids? [ remove-hidden-solids ] when
+ dup
+ [ solids>> ]
+ [ lights>> ]
+ [ ambient-color>> ] tri
+ [ rot solid-project ] 2curry
+ map
+ [ append ] { } -rot each
+ ! TODO project lights
+ projected-space
+ ! remove-inner-faces
+ !
+ eliminate-empty-solids
+ ] with-pv
+ ] [ 3drop <space> ] recover
+ ; inline
+
+: middle-of-space ( space -- point )
+ solids>> [ corners>> ] map concat
+ [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n
+;
+
+! --------------------------------------------------------------
+! 3D rendering
+! --------------------------------------------------------------
+
+: face-reference ( face -- halfspace point vect )
+ [ halfspace>> ]
+ [ touching-corners>> first ]
+ [ touching-corners>> second ] tri
+ over v-
+;
+
+: theta ( v halfspace point vect -- v x )
+ [ [ over ] dip v- ] dip
+ [ cross dup norm >float ]
+ [ v. >float ]
+ 2bi
+ fatan2
+ -rot v.
+ 0 < [ neg ] when
+;
+
+: ordered-face-points ( face -- corners )
+ [ touching-corners>> 1 head ]
+ [ touching-corners>> 1 tail ]
+ [ face-reference [ theta ] 3curry ] tri
+ { } map>assoc sort-values keys
+ append
+ ; inline
+
+: point->GL ( point -- ) gl-vertex ;
+: points->GL ( array -- ) do-cycle [ point->GL ] each ;
+
+: face->GL ( face color -- )
+ [ ordered-face-points ] dip
+ [ first3 1.0 glColor4d GL_POLYGON [ [ point->GL ] each ] do-state ] curry
+ [ 0 0 0 1 glColor4d GL_LINE_LOOP [ [ point->GL ] each ] do-state ]
+ bi
+ ; inline
+
+: solid->GL ( solid -- )
+ [ faces>> ]
+ [ color>> ] bi
+ [ face->GL ] curry each ; inline
+
+: space->GL ( space -- )
+ solids>>
+ [ solid->GL ] each ;
+
+
+
+
+
diff --git a/extra/adsoda/adsoda.tests b/extra/adsoda/adsoda.tests
new file mode 100755
index 0000000000..f0b0c54953
--- /dev/null
+++ b/extra/adsoda/adsoda.tests
@@ -0,0 +1,147 @@
+! : init-4D-demo ( -- space )
+! OK
+! espace de dimension 4 et de couleur 0,3 0.3 0.3
+<space>
+ 4 >>dimension
+ { 0.3 0.3 0.3 } >>ambient-color
+ { 100 150 100 150 100 150 100 150 } "4cube1" 4cube suffix-solids
+ { 160 180 160 180 160 180 160 180 } "4cube2" 4cube suffix-solids
+ <light>
+ { -100 -100 -100 -100 } >>position
+ { 0.2 0.7 0.1 } >>color
+ suffix-lights
+! ;
+! : init-3D-demo ( -- space )
+! OK
+! espace de dimension 4 et de couleur 0,3 0.3 0.3
+<space>
+ 3 >>dimension
+ { 0.3 0.3 0.3 } >>ambient-color
+ { 100 150 100 150 100 150 } "3cube1" 3cube suffix-solids
+ ! { -150 -10 -150 -10 -150 -10 -150 -10 } "4cube2" 4cube suffix-solids
+ <light>
+ { -100 -100 -100 -100 } >>position
+ { 0.2 0.7 0.1 } >>color
+ suffix-lights
+! ;
+
+
+: s1 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "s1" >>name
+ { 1 1 1 } >>color
+ { 1 -1 -5 } cut-solid
+ { -1 -1 -21 } cut-solid
+ { -1 0 -12 } cut-solid
+ { 1 2 16 } cut-solid
+;
+: solid1 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid1" >>name
+ { 1 -1 -5 } cut-solid
+ { -1 -1 -21 } cut-solid
+ { -1 0 -12 } cut-solid
+ { 1 2 16 } cut-solid
+ ensure-adjacencies
+
+;
+: solid2 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid2" >>name
+ { -1 1 -10 } cut-solid
+ { -1 -1 -28 } cut-solid
+ { 1 0 13 } cut-solid
+ ! { 1 2 16 } cut-solid
+ ensure-adjacencies
+
+;
+
+: solid3 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid3" >>name
+ { 1 1 1 } >>color
+ { 1 0 16 } cut-solid
+ { -1 0 -36 } cut-solid
+ { 0 1 1 } cut-solid
+ { 0 -1 -17 } cut-solid
+ ! { 1 2 16 } cut-solid
+ ensure-adjacencies
+
+
+;
+
+: solid4 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid4" >>name
+ { 1 1 1 } >>color
+ { 1 0 21 } cut-solid
+ { -1 0 -36 } cut-solid
+ { 0 1 1 } cut-solid
+ { 0 -1 -17 } cut-solid
+ ensure-adjacencies
+
+;
+
+: solid5 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid5" >>name
+ { 1 1 1 } >>color
+ { 1 0 6 } cut-solid
+ { -1 0 -17 } cut-solid
+ { 0 1 17 } cut-solid
+ { 0 -1 -19 } cut-solid
+ ensure-adjacencies
+
+;
+
+: solid7 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid7" >>name
+ { 1 1 1 } >>color
+ { 1 0 38 } cut-solid
+ { 1 -5 -66 } cut-solid
+ { -2 1 -75 } cut-solid
+ ensure-adjacencies
+
+;
+
+: solid6s ( -- seq )
+ solid3 clone solid2 clone subtract
+;
+
+: space1 ( -- space )
+ <space>
+ 2 >>dimension
+ ! solid3 suffix-solids
+ solid1 suffix-solids
+ solid2 suffix-solids
+ ! solid6s [ suffix-solids ] each
+ solid4 suffix-solids
+ ! solid5 suffix-solids
+ solid7 suffix-solids
+ { 1 1 1 } >>ambient-color
+ <light>
+ { -100 -100 } >>position
+ { 0.2 0.7 0.1 } >>color
+ suffix-lights
+;
+
+: space2 ( -- space )
+ <space>
+ 4 >>dimension
+ ! 4cube suffix-solids
+ { 1 1 1 } >>ambient-color
+ <light>
+ { -100 -100 } >>position
+ { 0.2 0.7 0.1 } >>color
+ suffix-lights
+
+ ;
+
diff --git a/extra/adsoda/authors.txt b/extra/adsoda/authors.txt
new file mode 100755
index 0000000000..856f3b05fc
--- /dev/null
+++ b/extra/adsoda/authors.txt
@@ -0,0 +1,2 @@
+Jeff Bigot
+Greg Ferrar
\ No newline at end of file
diff --git a/extra/adsoda/combinators/authors.txt b/extra/adsoda/combinators/authors.txt
new file mode 100755
index 0000000000..e7f4cdeb7c
--- /dev/null
+++ b/extra/adsoda/combinators/authors.txt
@@ -0,0 +1 @@
+JF Bigot, after Greg Ferrar
\ No newline at end of file
diff --git a/extra/adsoda/combinators/combinators-docs.factor b/extra/adsoda/combinators/combinators-docs.factor
new file mode 100755
index 0000000000..e6bb52ac24
--- /dev/null
+++ b/extra/adsoda/combinators/combinators-docs.factor
@@ -0,0 +1,39 @@
+! 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"
diff --git a/extra/adsoda/combinators/combinators-tests.factor b/extra/adsoda/combinators/combinators-tests.factor
new file mode 100755
index 0000000000..6796929a74
--- /dev/null
+++ b/extra/adsoda/combinators/combinators-tests.factor
@@ -0,0 +1,11 @@
+USING: adsoda.combinators
+sequences
+ tools.test
+ ;
+
+IN: adsoda.combinators.tests
+
+
+[ { "atoto" "b" "ctoto" } ] [ { "a" "b" "c" } 1 [ "toto" append ] map-but ]
+ unit-test
+
diff --git a/extra/adsoda/combinators/combinators.factor b/extra/adsoda/combinators/combinators.factor
new file mode 100755
index 0000000000..5838c30698
--- /dev/null
+++ b/extra/adsoda/combinators/combinators.factor
@@ -0,0 +1,44 @@
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays sequences fry math combinators ;
+
+IN: adsoda.combinators
+
+! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ;
+
+! : prefix-each [ prefix ] curry map ; inline
+
+! : combinations ( seq n -- seqs )
+! {
+! { [ dup 0 = ] [ 2drop { { } } ] }
+! { [ over empty? ] [ 2drop { } ] }
+! { [ t ] [
+! [ [ 1- (combinations) ] [ drop first ] 2bi prefix-each ]
+! [ (combinations) ] 2bi append
+! ] }
+! } cond ;
+
+: columnize ( array -- array ) [ 1array ] map ; inline
+
+: among ( array n -- array )
+ 2dup swap length
+ {
+ { [ over 1 = ] [ 3drop columnize ] }
+ { [ over 0 = ] [ 2drop 2drop { } ] }
+ { [ 2dup < ] [ 2drop [ 1 cut ] dip
+ [ 1- among [ append ] with map ]
+ [ among append ] 2bi
+ ] }
+ { [ 2dup = ] [ 3drop 1array ] }
+ { [ 2dup > ] [ 2drop 2drop { } ] }
+ } cond
+;
+
+: concat-nth ( seq1 seq2 -- seq ) [ nth append ] curry map-index ;
+
+: do-cycle ( array -- array ) dup first suffix ;
+
+: map-but ( seq i quot -- seq )
+ ! quot : ( seq x -- seq )
+ '[ _ = [ @ ] unless ] map-index ; inline
+
diff --git a/extra/adsoda/solution2/solution2.factor b/extra/adsoda/solution2/solution2.factor
new file mode 100755
index 0000000000..3e0648128d
--- /dev/null
+++ b/extra/adsoda/solution2/solution2.factor
@@ -0,0 +1,126 @@
+USING: kernel
+sequences
+namespaces
+
+math
+math.vectors
+math.matrices
+;
+IN: adsoda.solution2
+
+! -------------------
+! correctif solution
+! ---------------
+SYMBOL: matrix
+: MIN-VAL-adsoda ( -- x ) 0.00000001
+! 0.000000000001
+;
+
+: zero? ( x -- ? )
+ abs MIN-VAL-adsoda <
+;
+
+! [ number>string string>number ] map
+
+: with-matrix ( matrix quot -- )
+ [ swap matrix set call matrix get ] with-scope ; inline
+
+: nth-row ( row# -- seq ) matrix get nth ;
+
+: change-row ( row# quot -- seq ) ! row# quot -- | quot: seq -- seq )
+ matrix get swap change-nth ; inline
+
+: exchange-rows ( row# row# -- ) matrix get exchange ;
+
+: rows ( -- n ) matrix get length ;
+
+: cols ( -- n ) 0 nth-row length ;
+
+: skip ( i seq quot -- n )
+ over [ find-from drop ] dip length or ; inline
+
+: first-col ( row# -- n )
+ #! First non-zero column
+ 0 swap nth-row [ zero? not ] skip ;
+
+: clear-scale ( col# pivot-row i-row -- n )
+ [ over ] dip nth dup zero? [
+ 3drop 0
+ ] [
+ [ nth dup zero? ] dip swap [
+ 2drop 0
+ ] [
+ swap / neg
+ ] if
+ ] if ;
+
+: (clear-col) ( col# pivot-row i -- )
+ [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;
+
+: rows-from ( row# -- slice )
+ rows dup <slice> ;
+
+: clear-col ( col# row# rows -- )
+ [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;
+
+: do-row ( exchange-with row# -- )
+ [ exchange-rows ] keep
+ [ first-col ] keep
+ dup 1+ rows-from clear-col ;
+
+: find-row ( row# quot -- i elt )
+ [ rows-from ] dip find ; inline
+
+: pivot-row ( col# row# -- n )
+ [ dupd nth-row nth zero? not ] find-row 2nip ;
+
+: (echelon) ( col# row# -- )
+ over cols < over rows < and [
+ 2dup pivot-row [ over do-row 1+ ] when*
+ [ 1+ ] dip (echelon)
+ ] [
+ 2drop
+ ] if ;
+
+: echelon ( matrix -- matrix' )
+ [ 0 0 (echelon) ] with-matrix ;
+
+: nonzero-rows ( matrix -- matrix' )
+ [ [ zero? ] all? not ] filter ;
+
+: null/rank ( matrix -- null rank )
+ echelon dup length swap nonzero-rows length [ - ] keep ;
+
+: leading ( seq -- n elt ) [ zero? not ] find ;
+
+: reduced ( matrix' -- matrix'' )
+ [
+ rows <reversed> [
+ dup nth-row leading drop
+ dup [ swap dup clear-col ] [ 2drop ] if
+ ] each
+ ] with-matrix ;
+
+: basis-vector ( row col# -- )
+ [ clone ] dip
+ [ swap nth neg recip ] 2keep
+ [ 0 spin set-nth ] 2keep
+ [ n*v ] dip
+ matrix get set-nth ;
+
+: nullspace ( matrix -- seq )
+ echelon reduced dup empty? [
+ dup first length identity-matrix [
+ [
+ dup leading drop
+ dup [ basis-vector ] [ 2drop ] if
+ ] each
+ ] with-matrix flip nonzero-rows
+ ] unless ;
+
+: 1-pivots ( matrix -- matrix )
+ [ dup leading nip [ recip v*n ] when* ] map ;
+
+: solution ( matrix -- matrix )
+ echelon nonzero-rows reduced 1-pivots ;
+
diff --git a/extra/adsoda/solution2/summary.txt b/extra/adsoda/solution2/summary.txt
new file mode 100755
index 0000000000..a25a451f3c
--- /dev/null
+++ b/extra/adsoda/solution2/summary.txt
@@ -0,0 +1 @@
+A modification of solution to approximate solutions
\ No newline at end of file
diff --git a/extra/adsoda/summary.txt b/extra/adsoda/summary.txt
new file mode 100755
index 0000000000..ee666bc787
--- /dev/null
+++ b/extra/adsoda/summary.txt
@@ -0,0 +1 @@
+ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm
\ No newline at end of file
diff --git a/extra/adsoda/tags.txt b/extra/adsoda/tags.txt
new file mode 100755
index 0000000000..6e25b2f44b
--- /dev/null
+++ b/extra/adsoda/tags.txt
@@ -0,0 +1 @@
+adsoda 4D viewer
\ No newline at end of file
diff --git a/extra/adsoda/tools/authors.txt b/extra/adsoda/tools/authors.txt
new file mode 100755
index 0000000000..a6a96933f4
--- /dev/null
+++ b/extra/adsoda/tools/authors.txt
@@ -0,0 +1 @@
+Jeff Bigot
\ No newline at end of file
diff --git a/extra/adsoda/tools/tools-docs.factor b/extra/adsoda/tools/tools-docs.factor
new file mode 100755
index 0000000000..6fb617a0c4
--- /dev/null
+++ b/extra/adsoda/tools/tools-docs.factor
@@ -0,0 +1,76 @@
+! 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"
+
+
diff --git a/extra/adsoda/tools/tools-tests.factor b/extra/adsoda/tools/tools-tests.factor
new file mode 100755
index 0000000000..bb5419417c
--- /dev/null
+++ b/extra/adsoda/tools/tools-tests.factor
@@ -0,0 +1,14 @@
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING:
+adsoda.tools
+tools.test
+;
+
+IN: adsoda.tools.tests
+
+
+ [ { 1 0 } ] [ { { 0 0 } { 0 1 } } normal-vector ] unit-test
+ [ f ] [ { { 0 0 } { 0 0 } } normal-vector ] unit-test
+
+ [ { 1/2 1/2 1+1/2 } ] [ { { 1 2 } { 2 1 } } points-to-hyperplane ] unit-test
diff --git a/extra/adsoda/tools/tools.factor b/extra/adsoda/tools/tools.factor
new file mode 100755
index 0000000000..efa3a55013
--- /dev/null
+++ b/extra/adsoda/tools/tools.factor
@@ -0,0 +1,145 @@
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING:
+kernel
+sequences
+math
+accessors
+adsoda
+math.vectors
+math.matrices
+bunny.model
+io.encodings.ascii
+io.files
+sequences.deep
+combinators
+adsoda.combinators
+fry
+io.files.temp
+grouping
+;
+
+IN: adsoda.tools
+
+
+
+
+
+! ---------------------------------
+: coord-min ( x array -- array ) swap suffix ;
+: coord-max ( x array -- array ) swap neg suffix ;
+
+: 4cube ( array name -- solid )
+! array : xmin xmax ymin ymax zmin zmax wmin wmax
+ <solid>
+ 4 >>dimension
+ swap >>name
+ swap
+ {
+ [ { 1 0 0 0 } coord-min ] [ { -1 0 0 0 } coord-max ]
+ [ { 0 1 0 0 } coord-min ] [ { 0 -1 0 0 } coord-max ]
+ [ { 0 0 1 0 } coord-min ] [ { 0 0 -1 0 } coord-max ]
+ [ { 0 0 0 1 } coord-min ] [ { 0 0 0 -1 } coord-max ]
+ }
+ [ curry call ] 2map
+ [ cut-solid ] each
+ ensure-adjacencies
+
+; inline
+
+: 3cube ( array name -- solid )
+! array : xmin xmax ymin ymax zmin zmax wmin wmax
+ <solid>
+ 3 >>dimension
+ swap >>name
+ swap
+ {
+ [ { 1 0 0 } coord-min ] [ { -1 0 0 } coord-max ]
+ [ { 0 1 0 } coord-min ] [ { 0 -1 0 } coord-max ]
+ [ { 0 0 1 } coord-min ] [ { 0 0 -1 } coord-max ]
+ }
+ [ curry call ] 2map
+ [ cut-solid ] each
+ ensure-adjacencies
+
+; inline
+
+
+: equation-system-for-normal ( points -- matrix )
+ unclip [ v- 0 suffix ] curry map
+ dup first [ drop 1 ] map suffix
+;
+
+: normal-vector ( points -- v )
+ equation-system-for-normal
+ intersect-hyperplanes ;
+
+: points-to-hyperplane ( points -- hyperplane )
+ [ normal-vector 0 suffix ] [ first ] bi
+ translate ;
+
+: refs-to-points ( points faces -- faces )
+ [ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] with map
+;
+! V{ { 0.1 0.2 } { 1.1 1.3 } } V{ { 1 0 } { 0 1 } }
+! V{ { { 1.1 1.3 } { 0.1 0.2 } } { { 0.1 0.2 } { 1.1 1.3 } } }
+
+: ply-model-path ( -- path )
+
+! "bun_zipper.ply"
+"screw2.ply"
+temp-file
+;
+
+: read-bunny-model ( -- v )
+ply-model-path ascii [ parse-model ] with-file-reader
+
+refs-to-points
+;
+
+: 3points-to-normal ( seq -- v )
+ unclip [ v- ] curry map first2 cross normalize
+;
+: 2-faces-to-prism ( seq seq -- seq )
+ 2dup
+ [ do-cycle 2 clump ] bi@ concat-nth ! 3 faces rectangulaires
+ swap prefix
+ swap prefix
+;
+
+: Xpoints-to-prisme ( seq height -- cube )
+ ! from 3 points gives a list of faces representing a cube of height "height"
+ ! and of based on the three points
+ ! a face is a group of 3 or mode points.
+ [ dup dup 3points-to-normal ] dip
+ v*n [ v+ ] curry map ! 2 eme face triangulaire
+ 2-faces-to-prism
+
+! [ dup number? [ 1 + ] when ] deep-map
+! dup keep
+;
+
+
+: Xpoints-to-plane4D ( seq x y -- 4Dplane )
+ ! from 3 points gives a list of faces representing a cube in 4th dim
+ ! from x to y (height = y-x)
+ ! and of based on the X points
+ ! a face is a group of 3 or mode points.
+ '[ [ [ _ suffix ] map ] [ [ _ suffix ] map ] bi ] call
+ 2-faces-to-prism
+;
+
+: 3pointsfaces-to-3Dsolidfaces ( seq -- seq )
+ [ 1 Xpoints-to-prisme [ 100 110 Xpoints-to-plane4D ] map concat ] map
+
+;
+
+: test-figure ( -- solid )
+ <solid>
+ 2 >>dimension
+ { 1 -1 -5 } cut-solid
+ { -1 -1 -21 } cut-solid
+ { -1 0 -12 } cut-solid
+ { 1 2 16 } cut-solid
+;
+