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 }
+ { "gadget" "gadget" }
}
{ $description "The menu dedicated to 3D movements of the camera" } ;
HELP: menu-4D
{ $values
- { "gadget" null }
+ { "gadget" "gadget" }
}
{ $description "The menu dedicated to 4D movements of space" } ;
HELP: menu-bar
{ $values
- { "gadget" null }
+ { "gadget" "gadget" }
}
{ $description "return gadget containing menu buttons" } ;
HELP: model-projection
{ $values
- { "x" null }
- { "space" null }
+ { "x" "interger" }
+ { "space" "space" }
}
{ $description "Project space following coordinate x" } ;
HELP: mvt-3D-1
{ $values
- { "quot" quotation }
+ { "quot" "quotation" }
}
{ $description "return a quotation to orientate space to see it from first point of view" } ;
HELP: mvt-3D-2
{ $values
- { "quot" quotation }
+ { "quot" "quotation" }
}
{ $description "return a quotation to orientate space to see it from second point of view" } ;
HELP: mvt-3D-3
{ $values
- { "quot" quotation }
+ { "quot" "quotation" }
}
{ $description "return a quotation to orientate space to see it from third point of view" } ;
HELP: mvt-3D-4
{ $values
- { "quot" quotation }
+ { "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: 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 }
+ { "v" "vector" }
}
-{ $description "" } ;
+{ $description "Apply a 4D translation" } ;
-HELP: viewer-windows*
-{ $description "" } ;
-HELP: win3D
-{ $values
- { "text" null } { "gadget" null }
-}
-{ $description "" } ;
+ARTICLE: "implementation details" "How 4DNav is done"
+"4DNav is build using :"
-HELP: windows
-{ $description "" } ;
+{ $subsection "4DNav.camera" }
+{ $subsection "adsoda-main-page" }
+;
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:"
+"To build a new space, create an XML file using " { $vocab-link "adsoda" } " model description. A solid is not caracterized by its corners but is defined as the intersection of hyperplanes."
+
+$nl
+"An example is:"
$nl
"\n<model>"
;
-
ARTICLE: "TODO" "Todo"
{ $list
- "A file chooser"
"A vocab to initialize parameters"
"an editor mode"
{ $list "add a face to a solid"
"add a tool wich give an hyperplane normal vector with enought points. Will use adsoda.intersect-hyperplanes with { { 0 } { 0 } { 1 } } "
"decorrelate 3D camera and activate them with select buttons"
-
-
} ;
-ARTICLE: "4DNav" "4DNav"
+ARTICLE: "4DNav" "The 4DNav app"
{ $vocab-link "4DNav" }
$nl
{ $heading "4D Navigator" }
"4DNav is a simple tool to visualize 4 dimensionnal objects."
"\n"
"It uses " { $vocab-link "adsoda" } " library to display a 4D space and navigate thru it."
-
+$nl
"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
-
+"Each visualization window represents the projection of the 4D space on a particular 3D space."
+{ $heading "Start" }
+"type:" { $code "\"4DNav\" run" }
+{ $heading "Navigation" }
+"Menu window is divided in 4 areas"
+{ $list
+ { "a space-file chooser to select the file to display" }
+ { "a parametrization area to select the projection mode" }
+ { "4D submenu to translate and rotate the 4D space" }
+ { "3D submenu to move the camera in 3D space. Cameras in every 3D spaces are manipulated as a single one" }
+ }
{ $heading "Links" }
{ $subsection "Space file" }
{ $subsection "TODO" }
-
+{ $subsection "implementation details" }
;
[ dup cos , 0.0 , dup sin neg , 0.0 ,\r
0.0 , 1.0 , 0.0 , 0.0 ,\r
dup sin , 0.0 , dup cos , 0.0 ,\r
- 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
\r
: 4D-Rzw ( angle -- Rz ) deg>rad\r
[ dup cos , dup sin neg , 0.0 , 0.0 ,\r
dup sin , dup cos , 0.0 , 0.0 ,\r
0.0 , 0.0 , 1.0 , 0.0 ,\r
- 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
! UI\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
\r
-: button* ( string quot -- button ) closed-quot <repeat-button> ;\r
+: button* ( string quot -- button ) \r
+ closed-quot <repeat-button> ;\r
\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
! \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
\r
: model-projection-chooser ( -- gadget )\r
observer3d> projection-mode>>\r
- { { 1 "perspective" } { 0 "orthogonal" } } <toggle-buttons> ;\r
+ { { 1 "perspective" } { 0 "orthogonal" } } \r
+ <toggle-buttons> ;\r
\r
: collision-detection-chooser ( -- gadget )\r
observer3d> collision-mode>>\r
- { { t "on" } { f "off" } } <toggle-buttons>\r
-;\r
+ { { t "on" } { f "off" } } <toggle-buttons> ;\r
\r
-: model-projection ( x -- space ) present-space> swap space-project ;\r
+: model-projection ( x -- space ) \r
+ present-space> swap space-project ;\r
\r
: update-observer-projections ( -- )\r
view1> relayout-1 \r
3 model-projection <model> view4> (>>model) ;\r
\r
: camera-action ( quot -- quot ) \r
- [ drop [ ] observer3d> with-self update-observer-projections ] \r
+ [ drop [ ] observer3d> \r
+ with-self update-observer-projections ] \r
make* closed-quot ;\r
\r
-: win3D ( text gadget -- ) "navigateur 4D : " rot append open-window ;\r
+: win3D ( text gadget -- ) \r
+ "navigateur 4D : " rot append open-window ;\r
\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
! 4D object manipulation\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
\r
: (mvt-4D) ( quot -- ) \r
present-space> \r
update-observer-projections ;\r
\r
: rotation-4D ( m -- ) \r
- '[ _ [ [ middle-of-space dup vneg ] keep swap space-translate ] dip\r
+ '[ _ [ [ middle-of-space dup vneg ] keep \r
+ swap space-translate ] dip\r
space-transform \r
swap space-translate\r
] (mvt-4D) ;\r
\r
: translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ;\r
\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
! menu\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
\r
: menu-rotations-4D ( -- gadget )\r
<frame>\r
<pile> 1 >>fill\r
- "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] button* add-gadget\r
- "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] button* add-gadget \r
+ "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] \r
+ button* add-gadget\r
+ "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] \r
+ button* add-gadget \r
@top-left grid-add \r
<pile> 1 >>fill\r
- "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] button* add-gadget\r
- "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] button* add-gadget \r
+ "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] \r
+ button* add-gadget\r
+ "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] \r
+ button* add-gadget \r
@top grid-add \r
<pile> 1 >>fill\r
- "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] button* add-gadget\r
- "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] button* add-gadget \r
+ "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] \r
+ button* add-gadget\r
+ "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] \r
+ button* add-gadget \r
@center grid-add\r
<pile> 1 >>fill\r
- "XW +" [ drop rotation-step 4D-Rxw rotation-4D ] button* add-gadget\r
- "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] button* add-gadget \r
+ "XW +" [ drop rotation-step 4D-Rxw rotation-4D ] \r
+ button* add-gadget\r
+ "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] \r
+ button* add-gadget \r
@top-right grid-add \r
<pile> 1 >>fill\r
- "YW +" [ drop rotation-step 4D-Ryw rotation-4D ] button* add-gadget\r
- "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] button* add-gadget \r
+ "YW +" [ drop rotation-step 4D-Ryw rotation-4D ] \r
+ button* add-gadget\r
+ "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] \r
+ button* add-gadget \r
@right grid-add \r
<pile> 1 >>fill\r
- "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] button* add-gadget\r
- "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] button* add-gadget \r
+ "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] \r
+ button* add-gadget\r
+ "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] \r
+ button* add-gadget \r
@bottom-right grid-add \r
;\r
\r
<frame> \r
<pile> 1 >>fill\r
<shelf> 1 >>fill \r
- "X+" [ drop { 1 0 0 0 } translation-step v*n translation-4D ] \r
+ "X+" [ drop { 1 0 0 0 } translation-step v*n \r
+ translation-4D ] \r
button* add-gadget\r
- "X-" [ drop { -1 0 0 0 } translation-step v*n translation-4D ] \r
+ "X-" [ drop { -1 0 0 0 } translation-step v*n \r
+ translation-4D ] \r
button* add-gadget \r
add-gadget\r
"YZW" <label> add-gadget\r
<pile> 1 >>fill\r
"XZW" <label> add-gadget\r
<shelf> 1 >>fill\r
- "Y+" [ drop { 0 1 0 0 } translation-step v*n translation-4D ] \r
+ "Y+" [ drop { 0 1 0 0 } translation-step v*n \r
+ translation-4D ] \r
button* add-gadget\r
- "Y-" [ drop { 0 -1 0 0 } translation-step v*n translation-4D ] \r
+ "Y-" [ drop { 0 -1 0 0 } translation-step v*n \r
+ translation-4D ] \r
button* add-gadget \r
add-gadget\r
@top-right grid-add\r
<pile> 1 >>fill\r
"XYW" <label> add-gadget\r
<shelf> 1 >>fill\r
- "Z+" [ drop { 0 0 1 0 } translation-step v*n translation-4D ] \r
+ "Z+" [ drop { 0 0 1 0 } translation-step v*n \r
+ translation-4D ] \r
button* add-gadget\r
- "Z-" [ drop { 0 0 -1 0 } translation-step v*n translation-4D ] \r
+ "Z-" [ drop { 0 0 -1 0 } translation-step v*n \r
+ translation-4D ] \r
button* add-gadget \r
add-gadget \r
@top-left grid-add \r
<pile> 1 >>fill\r
<shelf> 1 >>fill\r
- "W+" [ drop { 0 0 0 1 } translation-step v*n translation-4D ] \r
+ "W+" [ drop { 0 0 0 1 } translation-step v*n \r
+ translation-4D ] \r
button* add-gadget\r
- "W-" [ drop { 0 0 0 -1 } translation-step v*n translation-4D ] \r
+ "W-" [ drop { 0 0 0 -1 } translation-step v*n \r
+ translation-4D ] \r
button* add-gadget \r
add-gadget\r
"XYZ" <label> add-gadget\r
update-observer-projections ;\r
\r
: load-model-file ( -- )\r
- selected-file dup selected-file-model> set-model read-model-file \r
+ selected-file dup selected-file-model> set-model \r
+ read-model-file \r
redraw-model ;\r
\r
: mvt-3D-X ( turn pitch -- quot )\r
\r
: menu-rotations-3D ( -- gadget )\r
<frame>\r
- "Turn\n left" [ rotation-step turn-left ] camera-button \r
- @left grid-add \r
- "Turn\n right" [ rotation-step turn-right ] camera-button \r
- @right grid-add \r
- "Pitch down" [ rotation-step pitch-down ] camera-button \r
- @bottom grid-add \r
- "Pitch up" [ rotation-step pitch-up ] camera-button \r
- @top grid-add \r
+ "Turn\n left" [ rotation-step turn-left ] \r
+ camera-button @left grid-add \r
+ "Turn\n right" [ rotation-step turn-right ] \r
+ camera-button @right grid-add \r
+ "Pitch down" [ rotation-step pitch-down ] \r
+ camera-button @bottom grid-add \r
+ "Pitch up" [ rotation-step pitch-up ] \r
+ camera-button @top grid-add \r
<shelf> 1 >>fill\r
- "Roll left\n (ctl)" [ rotation-step roll-left ] camera-button\r
- add-gadget \r
- "Roll right\n(ctl)" [ rotation-step roll-right ] camera-button \r
- add-gadget \r
+ "Roll left\n (ctl)" [ rotation-step roll-left ] \r
+ camera-button add-gadget \r
+ "Roll right\n(ctl)" [ rotation-step roll-right ] \r
+ camera-button add-gadget \r
@center grid-add \r
;\r
\r
: menu-translations-3D ( -- gadget )\r
<frame>\r
- "left\n(alt)" [ translation-step strafe-left ] camera-button\r
- @left grid-add \r
- "right\n(alt)" [ translation-step strafe-right ] camera-button\r
- @right grid-add \r
- "Strafe up \n (alt)" [ translation-step strafe-up ] camera-button\r
- @top grid-add\r
- "Strafe down \n (alt)" [ translation-step strafe-down ] camera-button\r
- @bottom grid-add \r
+ "left\n(alt)" [ translation-step strafe-left ]\r
+ camera-button @left grid-add \r
+ "right\n(alt)" [ translation-step strafe-right ]\r
+ camera-button @right grid-add \r
+ "Strafe up \n (alt)" [ translation-step strafe-up ] \r
+ camera-button @top grid-add\r
+ "Strafe down\n (alt)" [ translation-step strafe-down ]\r
+ camera-button @bottom grid-add \r
<pile> 1 >>fill\r
- "Forward (ctl)" [ translation-step step-turtle ] camera-button\r
- add-gadget\r
- "Backward (ctl)" [ translation-step neg step-turtle ] camera-button\r
- add-gadget\r
+ "Forward (ctl)" [ translation-step step-turtle ] \r
+ camera-button add-gadget\r
+ "Backward (ctl)" \r
+ [ translation-step neg step-turtle ] \r
+ camera-button add-gadget\r
@center grid-add\r
;\r
\r
[ [ rotation-step pitch-up ] camera-action ] }\r
\r
{ T{ key-down f { C+ } "UP" } \r
- [ [ translation-step step-turtle ] camera-action ] }\r
+ [ [ translation-step step-turtle ] camera-action ] }\r
{ T{ key-down f { C+ } "DOWN" } \r
- [ [ translation-step neg step-turtle ] camera-action ] }\r
+ [ [ translation-step neg step-turtle ] \r
+ camera-action ] }\r
{ T{ key-down f { C+ } "LEFT" } \r
[ [ rotation-step roll-left ] camera-action ] }\r
{ T{ key-down f { C+ } "RIGHT" } \r
[ [ rotation-step roll-right ] camera-action ] }\r
\r
{ T{ key-down f { A+ } "LEFT" } \r
- [ [ translation-step strafe-left ] camera-action ] }\r
+ [ [ translation-step strafe-left ] camera-action ] }\r
{ T{ key-down f { A+ } "RIGHT" } \r
- [ [ translation-step strafe-right ] camera-action ] }\r
+ [ [ translation-step strafe-right ] camera-action ] }\r
{ T{ key-down f { A+ } "UP" } \r
[ [ translation-step strafe-up ] camera-action ] }\r
{ T{ key-down f { A+ } "DOWN" } \r
- [ [ translation-step strafe-down ] camera-action ] }\r
+ [ [ translation-step strafe-down ] camera-action ] }\r
\r
\r
{ T{ key-down f f "1" } [ mvt-3D-1 camera-action ] }\r
[ name>> "solid called : " pprint . ] \r
[ color>> "color : " pprint . ]\r
[ dimension>> "dimension : " pprint . ]\r
- [ faces>> "composed of faces : " pprint [ adsoda-display-model ] each ]\r
+ [ faces>> "composed of faces : " pprint \r
+ [ adsoda-display-model ] each ]\r
} cleave\r
;\r
M: space adsoda-display-model \r
{\r
[ dimension>> "dimension : " pprint . ] \r
[ ambient-color>> "ambient-color : " pprint . ]\r
- [ solids>> "composed of solids : " pprint [ adsoda-display-model ] each ]\r
- [ lights>> "composed of lights : " pprint [ adsoda-display-model ] each ] \r
+ [ solids>> "composed of solids : " pprint \r
+ [ adsoda-display-model ] each ]\r
+ [ lights>> "composed of lights : " pprint \r
+ [ adsoda-display-model ] each ] \r
} cleave\r
;\r
\r
! ----------------------------------------------\r
: menu-bar ( -- gadget )\r
<shelf>\r
- "reinit" [ drop load-model-file ] button* add-gadget\r
- selected-file-model> <label-control> add-gadget\r
+ "reinit" [ drop load-model-file ] button* add-gadget\r
+ selected-file-model> <label-control> add-gadget\r
;\r
\r
\r
model-projection-chooser add-gadget\r
f track-add\r
<shelf>\r
- "Collision detection (slow and buggy ) : " <label> add-gadget\r
+ "Collision detection (slow and buggy ) : " \r
+ <label> add-gadget\r
collision-detection-chooser add-gadget\r
f track-add\r
<pile>\r
HELP: camera-eye
{ $values
- { "point" null }
+ { "point" "position" }
}
{ $description "return the position of the camera" } ;
HELP: camera-focus
{ $values
- { "point" null }
+ { "point" "position" }
}
{ $description "return the point the camera looks at" } ;
HELP: camera-up
{ $values
- { "dirvec" null }
+ { "dirvec" "upside direction" }
}
{ $description "In order to precise the roling position of camera give an upward vector" } ;
HELP: do-look-at
{ $values
- { "camera" null }
+ { "camera" "direction" }
}
{ $description "Word to use in replacement of gl-look-at when using a camera" } ;
-ARTICLE: "4DNav.camera" "4DNav.camera"
+ARTICLE: "4DNav.camera" "Camera"
{ $vocab-link "4DNav.camera" }
"\n"
"A camera is defined by:"
-USING: kernel namespaces math.vectors opengl 4DNav.turtle self ;
+USING: kernel namespaces math.vectors opengl 4DNav.turtle
+self ;
IN: 4DNav.camera
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: camera-eye ( -- point ) turtle-pos> ;
-: camera-focus ( -- point ) [ 1 step-turtle turtle-pos> ] save-self ;
+: camera-focus ( -- point )
+ [ 1 step-turtle turtle-pos> ] save-self ;
: camera-up ( -- dirvec )
-[ 90 pitch-up turtle-pos> 1 step-turtle turtle-pos> swap v- ] save-self ;
+[ 90 pitch-up turtle-pos> 1 step-turtle turtle-pos> swap v- ]
+ save-self ;
: do-look-at ( camera -- )
-[ >self camera-eye camera-focus camera-up gl-look-at ] with-scope ;
+[ >self camera-eye camera-focus camera-up gl-look-at ]
+ with-scope ;
! } }
! ;
-ARTICLE: "4DNav.deep" "4DNav.deep"
+ARTICLE: "4DNav.deep" "Deep"
{ $vocab-link "4DNav.deep" }
;
-USING: macros quotations math math.functions math.trig sequences.deep kernel make fry combinators grouping ;\r
+USING: macros quotations math math.functions math.trig \r
+sequences.deep kernel make fry combinators grouping ;\r
IN: 4DNav.deep\r
\r
! USING: bake ;\r
! [ [ dup quotation? [ drop , ] when ] deep-map ]\r
! bi '[ _ cleave _ bake ] ;\r
\r
-: make-matrix ( quot width -- matrix ) [ { } make ] dip group ; inline\r
+: make-matrix ( quot width -- matrix ) \r
+ [ { } make ] dip group ; inline\r
\r
[ file-chooser? ] find-parent list>> ;\r
\r
file-chooser H{\r
- { T{ key-down f f "UP" } [ find-file-list select-previous ] }\r
- { T{ key-down f f "DOWN" } [ find-file-list select-next ] }\r
- { T{ key-down f f "PAGE_UP" } [ find-file-list list-page-up ] }\r
- { T{ key-down f f "PAGE_DOWN" } [ find-file-list list-page-down ] }\r
- { T{ key-down f f "RET" } [ find-file-list invoke-value-action ] }\r
- { T{ button-down } request-focus }\r
- { T{ button-down f 1 } [ find-file-list invoke-value-action ] }\r
+ { T{ key-down f f "UP" } \r
+ [ find-file-list select-previous ] }\r
+ { T{ key-down f f "DOWN" } \r
+ [ find-file-list select-next ] }\r
+ { T{ key-down f f "PAGE_UP" } \r
+ [ find-file-list list-page-up ] }\r
+ { T{ key-down f f "PAGE_DOWN" } \r
+ [ find-file-list list-page-down ] }\r
+ { T{ key-down f f "RET" } \r
+ [ find-file-list invoke-value-action ] }\r
+ { T{ button-down } \r
+ request-focus }\r
+ { T{ button-down f 1 } \r
+ [ find-file-list invoke-value-action ] }\r
} set-gestures\r
\r
: list-of-files ( file-chooser -- seq )\r
[ path>> value>> directory-entries ] [ extension>> ] bi\r
- '[ [ name>> _ [ tail? ] with contains? ] [ directory? ] bi or ] filter\r
+ '[ [ name>> _ [ tail? ] with any? ] \r
+ [ directory? ] bi or ] filter\r
;\r
\r
: update-filelist-model ( file-chooser -- file-chooser )\r
dup <file-list> >>list\r
"choose a file in directory " <label> f track-add\r
dup path>> <label-control> f track-add\r
- dup extension>> ", " join "limited to : " prepend <label> f track-add\r
+ dup extension>> ", " join "limited to : " prepend \r
+ <label> f track-add\r
<shelf> \r
"selected file : " <label> add-gadget\r
over selected-file>> <label-control> add-gadget\r
f track-add\r
<shelf> \r
- over [ swap fc-go-parent ] curry "go up" swap <bevel-button> add-gadget\r
- over [ swap fc-go-home ] curry "go home" swap <bevel-button> add-gadget\r
- ! over [ swap fc-ok-action ] curry "OK" swap <bevel-button> add-gadget\r
+ over [ swap fc-go-parent ] curry "go up" \r
+ swap <bevel-button> add-gadget\r
+ over [ swap fc-go-home ] curry "go home" \r
+ swap <bevel-button> add-gadget\r
+ ! over [ swap fc-ok-action ] curry "OK" \r
+ ! swap <bevel-button> add-gadget\r
! [ drop ] "Cancel" swap <bevel-button> add-gadget\r
f track-add\r
dup list>> <scroller> 1 track-add\r
M: file-chooser pref-dim* drop { 400 200 } ;\r
\r
: file-chooser-window ( -- )\r
-[ . ] home { "xml" "txt" } <file-chooser> "Choose a file" open-window ;\r
+ [ . ] home { "xml" "txt" } <file-chooser> \r
+ "Choose a file" open-window ;\r
\r
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 }
+ { "x" "value" }
}
-{ $description "" } ;
+{ $description "Read a file containing the xml description of the model" } ;
-ARTICLE: "4DNav.space-file-decoder" "4DNav.space-file-decoder"
+ARTICLE: "4DNav.space-file-decoder" "Space XMLfile decoder"
{ $vocab-link "4DNav.space-file-decoder" }
;
! Copyright (C) 2008 Jeff Bigot\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: adsoda xml xml.utilities xml.dispatch accessors combinators\r
-sequences math.parser kernel splitting values continuations ;\r
+USING: adsoda xml xml.utilities xml.dispatch accessors \r
+combinators sequences math.parser kernel splitting values \r
+continuations ;\r
IN: 4DNav.space-file-decoder\r
\r
-: decode-number-array ( x -- y ) "," split [ string>number ] map ;\r
+: decode-number-array ( x -- y ) \r
+ "," split [ string>number ] map ;\r
\r
PROCESS: adsoda-read-model ( tag -- )\r
\r
-TAG: dimension adsoda-read-model children>> first string>number ;\r
-TAG: direction adsoda-read-model children>> first decode-number-array ;\r
-TAG: color adsoda-read-model children>> first decode-number-array ;\r
-TAG: name adsoda-read-model children>> first ;\r
-TAG: face adsoda-read-model children>> first decode-number-array ;\r
+TAG: dimension adsoda-read-model \r
+ children>> first string>number ;\r
+TAG: direction adsoda-read-model \r
+ children>> first decode-number-array ;\r
+TAG: color adsoda-read-model \r
+ children>> first decode-number-array ;\r
+TAG: name adsoda-read-model \r
+ children>> first ;\r
+TAG: face adsoda-read-model \r
+ children>> first decode-number-array ;\r
\r
TAG: solid adsoda-read-model \r
<solid> swap \r
{ \r
- [ "dimension" tag-named adsoda-read-model >>dimension ] \r
+ [ "dimension" tag-named adsoda-read-model >>dimension ]\r
[ "name" tag-named adsoda-read-model >>name ] \r
[ "color" tag-named adsoda-read-model >>color ] \r
- [ "face" tags-named [ adsoda-read-model cut-solid ] each ] \r
+ [ "face" \r
+ tags-named [ adsoda-read-model cut-solid ] each ] \r
} cleave\r
ensure-adjacencies\r
;\r
TAG: light adsoda-read-model \r
<light> swap \r
{ \r
- [ "direction" tag-named adsoda-read-model >>direction ] \r
+ [ "direction" tag-named adsoda-read-model >>direction ]\r
[ "color" tag-named adsoda-read-model >>color ] \r
} cleave\r
;\r
TAG: space adsoda-read-model \r
<space> swap \r
{ \r
- [ "dimension" tag-named adsoda-read-model >>dimension ] \r
+ [ "dimension" tag-named adsoda-read-model >>dimension ]\r
[ "name" tag-named adsoda-read-model >>name ] \r
- [ "color" tag-named adsoda-read-model >>ambient-color ] \r
- [ "solid" tags-named [ adsoda-read-model suffix-solids ] each ] \r
- [ "light" tags-named [ adsoda-read-model suffix-lights ] each ] \r
+ [ "color" tag-named \r
+ adsoda-read-model >>ambient-color ] \r
+ [ "solid" tags-named \r
+ [ adsoda-read-model suffix-solids ] each ] \r
+ [ "light" tags-named \r
+ [ adsoda-read-model suffix-lights ] each ]\r
} cleave\r
;\r
\r
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"
+ARTICLE: "4DNav.turtle" "Turtle"
{ $vocab-link "4DNav.turtle" }
;
sequences accessors 4DNav.deep models ;
IN: 4DNav.turtle
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: turtle pos ori ;
: turtle-ori> ( -- val ) self> ori>> ;
: >turtle-ori ( val -- ) self> (>>ori) ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! These rotation matrices are from
! `Computer Graphics: Principles and Practice'
0 , dup sin , dup cos , ] 3 make-matrix nip ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: apply-rotation ( rotation -- ) turtle-ori> swap m. >turtle-ori ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: 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 ;
: roll-left ( angle -- ) neg rotate-z ;
: roll-right ( angle -- ) rotate-z ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! roll-until-horizontal
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: V ( -- V ) { 0 1 0 } ;
V Z cross normalize set-X
Z X cross normalize set-Y ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: distance ( turtle turtle -- n ) pos>> swap pos>> v- [ sq ] map sum sqrt ;
+: distance ( turtle turtle -- n )
+ pos>> swap pos>> v- [ sq ] map sum sqrt ;
: move-by ( point -- ) turtle-pos> v+ >turtle-pos ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: reset-turtle ( -- )
{ 0 0 0 } clone >turtle-pos 3 identity-matrix >turtle-ori ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: step-vector ( length -- array ) { 0 0 1 } n*v ;
: step-turtle ( length -- )
- step-vector turtle-ori> swap m.v turtle-pos> v+ >turtle-pos ;
+ step-vector turtle-ori> swap m.v
+ turtle-pos> v+ >turtle-pos ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: strafe-up ( length -- )
90 pitch-up
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"
+ARTICLE: "4DNav.window3D" "Window3D"
{ $vocab-link "4DNav.window3D" }
;
\r
IN: 4DNav.window3D\r
\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
! drawing functions \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
\r
TUPLE: window3D < gadget observer ; \r
\r
GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc\r
GL_LINE_SMOOTH_HINT GL_NICEST glHint\r
1.25 glLineWidth\r
- GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear\r
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor \r
+ glClear\r
glLoadIdentity\r
GL_LIGHTING glEnable\r
GL_LIGHT0 glEnable\r
! --------------------------------------------------------------\r
! faces\r
! --------------------------------------------------------------\r
-ARTICLE: "face-page" "face in ADSODA"\r
+ARTICLE: "face-page" "Face in ADSODA"\r
"explanation of faces"\r
$nl\r
"link to functions"\r
! --------------------------------\r
! solid\r
! --------------------------------------------------------------\r
-ARTICLE: "solid-page" "solid in ADSODA"\r
+ARTICLE: "solid-page" "Solid in ADSODA"\r
"explanation of solids"\r
$nl\r
"link to functions"\r
\r
HELP: subtract \r
{ $values { "solid1" "initial shape" } { "solid2" "shape to remove" } { "solids" "resulting shape" } }\r
-{ $description " " } ;\r
+{ $description "Substract solid2 from solid1" } ;\r
\r
\r
! --------------------------------------------------------------\r
! space \r
! --------------------------------------------------------------\r
-ARTICLE: "space-page" "space in ADSODA"\r
+ARTICLE: "space-page" "Space in ADSODA"\r
"A space is a collection of solids and lights."\r
$nl\r
"link to functions"\r
! --------------------------------------------------------------\r
! 3D rendering\r
! --------------------------------------------------------------\r
-ARTICLE: "3D-rendering-page" "3D rendering in ADSODA"\r
+ARTICLE: "3D-rendering-page" "The 3D rendering in ADSODA"\r
"explanation of 3D rendering"\r
$nl\r
"link to functions"\r
\r
HELP: face->GL \r
{ $values { "face" "a face" } { "color" "3 3 values array" } }\r
-{ $description "" } ;\r
+{ $description "display a face" } ;\r
\r
HELP: solid->GL \r
{ $values { "solid" "a solid" } }\r
-{ $description "" } ;\r
+{ $description "display a solid" } ;\r
\r
HELP: space->GL \r
{ $values { "space" "a space" } }\r
-{ $description "" } ;\r
+{ $description "display a space" } ;\r
\r
! --------------------------------------------------------------\r
! light\r
! --------------------------------------------------------------\r
\r
-ARTICLE: "light-page" "light in ADSODA"\r
+ARTICLE: "light-page" "Light in ADSODA"\r
"explanation of light"\r
$nl\r
"link to functions"\r
\r
\r
ARTICLE: { "adsoda" "halfspace" } "ADSODA : halfspace"\r
-"! demi espace défini par un vecteur normal et une constante"\r
" defined by the concatenation of the normal vector and a constant" \r
;\r
\r
VAR: pv\r
\r
\r
-! ---------------------------------------------------------------------\r
+! -------------------------------------------------------------\r
! global values\r
VALUE: remove-hidden-solids?\r
VALUE: VERY-SMALL-NUM\r
0.0000001 to: VERY-SMALL-NUM\r
0.0000001 to: ZERO-VALUE\r
4 to: MAX-FACE-PER-CORNER\r
-! ---------------------------------------------------------------------\r
+! -------------------------------------------------------------\r
! sequence complement\r
\r
: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
\r
: dimension ( array -- x ) length 1- ; inline \r
-: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline\r
-: change-last ( seq quot -- ) [ [ dimension ] keep ] dip change-nth ; \r
+: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline\r
+: change-last ( seq quot -- ) \r
+ [ [ dimension ] keep ] dip change-nth ; \r
\r
-! --------------------------------------------------------------\r
+! -------------------------------------------------------------\r
! light\r
-! --------------------------------------------------------------\r
+! -------------------------------------------------------------\r
\r
TUPLE: light name { direction array } color ;\r
: <light> ( -- tuple ) light new ;\r
\r
-! -----------------------------------------------------------------------\r
+! -------------------------------------------------------------\r
! halfspace manipulation\r
-! -----------------------------------------------------------------------\r
+! -------------------------------------------------------------\r
\r
: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;\r
: translate ( u v -- w ) dupd v* sum constant+ ; \r
: transform ( u matrix -- w )\r
[ swap m.v ] 2keep ! compute new normal vector \r
[\r
- [ [ abs ZERO-VALUE > ] find ] keep ! find a point on the frontier\r
+ [ [ abs ZERO-VALUE > ] find ] keep \r
+ ! find a point on the frontier\r
! be sure it's not null vector\r
last ! get constant\r
swap /f neg swap ! intercept value\r
position-point VERY-SMALL-NUM > ; \r
: point-inside-or-on-halfspace? ( halfspace v -- ? ) \r
position-point VERY-SMALL-NUM neg > ;\r
-: project-vector ( seq -- seq ) pv> [ head ] [ 1+ tail ] 2bi append ; \r
-: get-intersection ( matrice -- seq ) [ 1 tail* ] map flip first ;\r
+: project-vector ( seq -- seq ) \r
+ pv> [ head ] [ 1+ tail ] 2bi append ; \r
+: get-intersection ( matrice -- seq ) \r
+ [ 1 tail* ] map flip first ;\r
\r
: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;\r
\r
[ solution dup ] [ first dimension ] bi\r
valid-solution? [ get-intersection ] [ drop f ] if ;\r
\r
-! --------------------------------------------------------------\r
+! -------------------------------------------------------------\r
! faces\r
-! --------------------------------------------------------------\r
+! -------------------------------------------------------------\r
\r
-TUPLE: face { halfspace array } touching-corners adjacent-faces ;\r
+TUPLE: face { halfspace array } \r
+ touching-corners adjacent-faces ;\r
: <face> ( v -- tuple ) face new swap >>halfspace ;\r
: flip-face ( face -- face ) [ vneg ] change-halfspace ;\r
-: erase-face-touching-corners ( face -- face ) f >>touching-corners ;\r
-: erase-face-adjacent-faces ( face -- face ) f >>adjacent-faces ;\r
+: erase-face-touching-corners ( face -- face ) \r
+ f >>touching-corners ;\r
+: erase-face-adjacent-faces ( face -- face ) \r
+ f >>adjacent-faces ;\r
: faces-intersection ( faces -- v ) \r
[ halfspace>> ] map intersect-hyperplanes ;\r
: face-translate ( face v -- face ) \r
[ translate ] curry change-halfspace ; inline\r
: face-transform ( face m -- face )\r
[ transform ] curry change-halfspace ; inline\r
-: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;\r
+: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;\r
: backface? ( face -- face ? ) dup face-orientation 0 <= ;\r
: pv-factor ( face -- f face ) \r
halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline\r
: suffix-touching-corner ( face corner -- face ) \r
[ suffix ] curry change-touching-corners ; inline\r
: real-face? ( face -- ? )\r
- [ touching-corners>> length ] [ halfspace>> dimension ] bi >= ;\r
+ [ touching-corners>> length ] \r
+ [ halfspace>> dimension ] bi >= ;\r
\r
: (add-to-adjacent-faces) ( face face -- face )\r
over adjacent-faces>> 2dup member?\r
[ ] (intersection-into-face) ;\r
\r
: intersections-into-faces ( face -- faces )\r
- clone dup adjacent-faces>> [ intersection-into-face ] with map \r
+ clone dup \r
+ adjacent-faces>> [ intersection-into-face ] with map \r
[ ] filter ;\r
\r
: (face-silhouette) ( face -- faces )\r
\r
! --------------------------------\r
! solid\r
-! --------------------------------------------------------------\r
-TUPLE: solid dimension silhouettes faces corners adjacencies-valid color name ;\r
+! -------------------------------------------------------------\r
+TUPLE: solid dimension silhouettes \r
+ faces corners adjacencies-valid color name ;\r
\r
: <solid> ( -- tuple ) solid new ;\r
\r
: suffix-silhouettes ( solid silhouette -- solid ) \r
[ suffix ] curry change-silhouettes ;\r
\r
-: suffix-face ( solid face -- solid ) [ suffix ] curry change-faces ;\r
-\r
-: suffix-corner ( solid corner -- solid ) [ suffix ] curry change-corners ; \r
-\r
+: suffix-face ( solid face -- solid ) \r
+ [ suffix ] curry change-faces ;\r
+: suffix-corner ( solid corner -- solid ) \r
+ [ suffix ] curry change-corners ; \r
: erase-solid-corners ( solid -- solid ) f >>corners ;\r
\r
-: erase-silhouettes ( solid -- solid ) dup dimension>> f <array> >>silhouettes ;\r
-\r
-: filter-real-faces ( solid -- solid ) [ [ real-face? ] filter ] change-faces ;\r
-\r
+: erase-silhouettes ( solid -- solid ) \r
+ dup dimension>> f <array> >>silhouettes ;\r
+: filter-real-faces ( solid -- solid ) \r
+ [ [ real-face? ] filter ] change-faces ;\r
: initiate-solid-from-face ( face -- solid ) \r
face-project-dim <solid> swap >>dimension ;\r
\r
: erase-old-adjacencies ( solid -- solid )\r
erase-solid-corners\r
- [ dup [ erase-face-touching-corners erase-face-adjacent-faces drop ] each ]\r
+ [ dup [ erase-face-touching-corners \r
+ erase-face-adjacent-faces drop ] each ]\r
change-faces ;\r
\r
: point-inside-or-on-face? ( face v -- ? ) \r
[ halfspace>> ] dip point-inside-halfspace? ;\r
\r
: point-inside-solid? ( solid point -- ? )\r
- [ faces>> ] dip [ point-inside-face? ] curry all? ; inline\r
+ [ faces>> ] dip [ point-inside-face? ] curry all? ; inline\r
\r
: point-inside-or-on-solid? ( solid point -- ? )\r
- [ faces>> ] dip [ point-inside-or-on-face? ] curry all? ; inline\r
+ [ faces>> ] dip \r
+ [ point-inside-or-on-face? ] curry all? ; inline\r
\r
: unvalid-adjacencies ( solid -- solid ) \r
- erase-old-adjacencies f >>adjacencies-valid erase-silhouettes ;\r
+ erase-old-adjacencies f >>adjacencies-valid \r
+ erase-silhouettes ;\r
\r
: add-face ( solid face -- solid ) \r
suffix-face unvalid-adjacencies ; \r
ensure-silhouettes\r
;\r
\r
-: (non-empty-solid?) ( solid -- ? ) [ dimension>> ] [ corners>> length ] bi < ;\r
-: non-empty-solid? ( solid -- ? ) ensure-adjacencies (non-empty-solid?) ;\r
+: (non-empty-solid?) ( solid -- ? ) \r
+ [ dimension>> ] [ corners>> length ] bi < ;\r
+: non-empty-solid? ( solid -- ? ) \r
+ ensure-adjacencies (non-empty-solid?) ;\r
\r
: compare-corners-roughly ( corner corner -- ? )\r
2drop t ;\r
[ dup faces>> ] dip call drop \r
unvalid-adjacencies ; inline\r
\r
-: solid-translate ( solid v -- solid ) [ face-translate ] (solid-move) ; \r
-: solid-transform ( solid m -- solid ) [ face-transform ] (solid-move) ; \r
+: solid-translate ( solid v -- solid ) \r
+ [ face-translate ] (solid-move) ; \r
+: solid-transform ( solid m -- solid ) \r
+ [ face-transform ] (solid-move) ; \r
\r
: find-corner-in-silhouette ( s1 s2 -- elt bool )\r
pv> swap silhouettes>> nth \r
[ ensure-adjacencies ] map\r
; inline\r
\r
-! --------------------------------------------------------------\r
+! -------------------------------------------------------------\r
! space \r
-! --------------------------------------------------------------\r
+! -------------------------------------------------------------\r
TUPLE: space name dimension solids ambient-color lights ;\r
: <space> ( -- space ) space new ;\r
-: suffix-solids ( space solid -- space ) [ suffix ] curry change-solids ; inline\r
-: suffix-lights ( space light -- space ) [ suffix ] curry change-lights ; inline\r
+: suffix-solids ( space solid -- space ) \r
+ [ suffix ] curry change-solids ; inline\r
+: suffix-lights ( space light -- space ) \r
+ [ suffix ] curry change-lights ; inline\r
: clear-space-solids ( space -- space ) f >>solids ;\r
\r
: space-ensure-solids ( space -- space ) \r
[ [ non-empty-solid? ] filter ] change-solids ;\r
\r
: projected-space ( space solids -- space ) \r
- swap dimension>> 1- <space> swap >>dimension swap >>solids ;\r
+ swap dimension>> 1- <space> \r
+ swap >>dimension swap >>solids ;\r
\r
-: get-silhouette ( solid -- silhouette ) silhouettes>> pv> swap nth ;\r
-: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;\r
+: get-silhouette ( solid -- silhouette ) \r
+ silhouettes>> pv> swap nth ;\r
+: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;\r
\r
: space-apply ( space m quot -- space ) \r
curry [ map ] curry [ dup solids>> ] dip\r
[ call ] [ drop ] recover drop ;\r
-: space-transform ( space m -- space ) [ solid-transform ] space-apply ;\r
-: space-translate ( space v -- space ) [ solid-translate ] space-apply ; \r
+: space-transform ( space m -- space ) \r
+ [ solid-transform ] space-apply ;\r
+: space-translate ( space v -- space ) \r
+ [ solid-translate ] space-apply ; \r
\r
: describe-space ( space -- ) \r
- solids>> [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;\r
+ solids>> \r
+ [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;\r
\r
: clip-solid ( solid solid -- solids )\r
[ ]\r
; inline \r
\r
: remove-hidden-solids ( space -- space ) \r
-! We must include each solid in a sequence because during substration \r
+! We must include each solid in a sequence because \r
+! during substration \r
! a solid can be divided in more than on solid\r
[ \r
[ [ 1array ] map ] \r
[ [ ] [ v+ ] map-reduce ] [ length ] bi v/n\r
;\r
\r
-! --------------------------------------------------------------\r
+! -------------------------------------------------------------\r
! 3D rendering\r
-! --------------------------------------------------------------\r
+! -------------------------------------------------------------\r
\r
: face-reference ( face -- halfspace point vect )\r
[ halfspace>> ] \r
\r
: face->GL ( face color -- )\r
[ ordered-face-points ] dip\r
- [ first3 1.0 glColor4d GL_POLYGON [ [ point->GL ] each ] do-state ] curry\r
- [ 0 0 0 1 glColor4d GL_LINE_LOOP [ [ point->GL ] each ] do-state ]\r
+ [ first3 1.0 glColor4d GL_POLYGON \r
+ [ [ point->GL ] each ] do-state ] curry\r
+ [ 0 0 0 1 glColor4d GL_LINE_LOOP \r
+ [ [ point->GL ] each ] do-state ]\r
bi\r
; inline\r
\r
HELP: among
{ $values
- { "array" array } { "n" null }
+ { "array" array } { "n" "number of value to select" }
{ "array" array }
}
{ $description "returns an array containings every possibilities of n choices among a given sequence" } ;
{ $description "Copy the first element at the end of the sequence in order to close the cycle." } ;
-ARTICLE: "adsoda.combinators" "adsoda.combinators"
+ARTICLE: "adsoda.combinators" "Combinators"
{ $vocab-link "adsoda.combinators" }
;
\r
IN: adsoda.combinators\r
\r
-! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ; \r
+! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ;\r
\r
! : prefix-each [ prefix ] curry map ; inline\r
\r
} cond\r
;\r
\r
-: concat-nth ( seq1 seq2 -- seq ) [ nth append ] curry map-index ;\r
+: concat-nth ( seq1 seq2 -- seq ) \r
+ [ nth append ] curry map-index ;\r
\r
: do-cycle ( array -- array ) dup first suffix ;\r
\r
{ "solid" "solid" }
}
{ $description "array : xmin xmax ymin ymax zmin zmax"
-"\n returns a 3D solid with given limits"
+"returns a 3D solid with given limits"
} ;
HELP: 4cube
{ "solid" "solid" }
}
{ $description "array : xmin xmax ymin ymax zmin zmax wmin wmax"
-"\n returns a 4D solid with given limits"
+"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" }
{ "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" }
+"With n points, creates n-1 vectors and then find a vector orthogonal to every others"
+"returns { f } if a normal vector can not be found" }
;
HELP: points-to-hyperplane
{ "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"
+"Finds a normal vector and then translate it so that it includes one of the points"
}
;
-ARTICLE: "adsoda.tools" "adsoda.tools"
+ARTICLE: "adsoda.tools" "Tools"
{ $vocab-link "adsoda.tools" }
-"\nTools to help in building an " { $vocab-link "adsoda" } "-space"
+"Tools to help in building an " { $vocab-link "adsoda" } "-space"
;
ABOUT: "adsoda.tools"
translate ;\r
\r
: refs-to-points ( points faces -- faces )\r
- [ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] with map\r
+ [ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] \r
+ with map\r
;\r
! V{ { 0.1 0.2 } { 1.1 1.3 } } V{ { 1 0 } { 0 1 } }\r
! V{ { { 1.1 1.3 } { 0.1 0.2 } } { { 0.1 0.2 } { 1.1 1.3 } } }\r
;\r
: 2-faces-to-prism ( seq seq -- seq )\r
2dup\r
- [ do-cycle 2 clump ] bi@ concat-nth ! 3 faces rectangulaires\r
+ [ do-cycle 2 clump ] bi@ concat-nth \r
+ ! 3 faces rectangulaires\r
swap prefix\r
swap prefix\r
; \r
\r
: Xpoints-to-prisme ( seq height -- cube )\r
- ! from 3 points gives a list of faces representing a cube of height "height"\r
+ ! from 3 points gives a list of faces representing \r
+ ! a cube of height "height"\r
! and of based on the three points\r
! a face is a group of 3 or mode points. \r
[ dup dup 3points-to-normal ] dip \r
\r
\r
: Xpoints-to-plane4D ( seq x y -- 4Dplane )\r
- ! from 3 points gives a list of faces representing a cube in 4th dim\r
+ ! from 3 points gives a list of faces representing \r
+ ! a cube in 4th dim\r
! from x to y (height = y-x)\r
! and of based on the X points\r
! a face is a group of 3 or mode points. \r
;\r
\r
: 3pointsfaces-to-3Dsolidfaces ( seq -- seq )\r
- [ 1 Xpoints-to-prisme [ 100 110 Xpoints-to-plane4D ] map concat ] map \r
+ [ 1 Xpoints-to-prisme [ 100 \r
+ 110 Xpoints-to-plane4D ] map concat ] map \r
\r
;\r
\r
projects / factor.git / commitdiff