steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

update 4dnav doc

db4
Jeff Bigot 2009-01-30 17:55:36 +01:00
parent 09d1e6400b
commit 202e6df46f
44 changed files with 3411 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

201
unmaintained/4DNav/4DNav-docs.factor Executable file
View File

@ -0,0 +1,201 @@
! 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: menu-3D
{ $values
{ "gadget" "gadget" }
}
{ $description "The menu dedicated to 3D movements of the camera" } ;
HELP: menu-4D
{ $values
{ "gadget" "gadget" }
}
{ $description "The menu dedicated to 4D movements of space" } ;
HELP: menu-bar
{ $values
{ "gadget" "gadget" }
}
{ $description "return gadget containing menu buttons" } ;
HELP: model-projection
{ $values
{ "x" "interger" }
{ "space" "space" }
}
{ $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: 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" "vector" }
}
{ $description "Apply a 4D translation" } ;
ARTICLE: "implementation details" "How 4DNav is done"
"4DNav is build using :"
{ $subsection "4DNav.camera" }
{ $subsection "adsoda-main-page" }
;
ARTICLE: "Space file" "Create a new space file"
"To build a new space, create an XML file using " { $vocab-link "adsoda" } " model description. A solid is not caracterized by its corners but is defined as the intersection of hyperplanes."
$nl
"An example is:"
$nl
"\n<model>"
"\n<space>"
"\n <dimension>4</dimension>"
"\n <solid>"
"\n <name>4cube1</name>"
"\n <dimension>4</dimension>"
"\n <face>1,0,0,0,100</face>"
"\n <face>-1,0,0,0,-150</face>"
"\n <face>0,1,0,0,100</face>"
"\n <face>0,-1,0,0,-150</face>"
"\n <face>0,0,1,0,100</face>"
"\n <face>0,0,-1,0,-150</face>"
"\n <face>0,0,0,1,100</face>"
"\n <face>0,0,0,-1,-150</face>"
"\n <color>1,0,0</color>"
"\n </solid>"
"\n <solid>"
"\n <name>4triancube</name>"
"\n <dimension>4</dimension>"
"\n <face>1,0,0,0,160</face>"
"\n <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>"
"\n <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>"
"\n <face>0,0,1,0,140</face>"
"\n <face>0,0,-1,0,-180</face>"
"\n <face>0,0,0,1,110</face>"
"\n <face>0,0,0,-1,-180</face>"
"\n <color>0,1,0</color>"
"\n </solid>"
"\n <solid>"
"\n <name>triangone</name>"
"\n <dimension>4</dimension>"
"\n <face>1,0,0,0,60</face>"
"\n <face>0.5,0.8660254037844386,0,0,60</face>"
"\n <face>-0.5,0.8660254037844387,0,0,-20</face>"
"\n <face>-1.0,0,0,0,-100</face>"
"\n <face>-0.5,-0.8660254037844384,0,0,-100</face>"
"\n <face>0.5,-0.8660254037844387,0,0,-20</face>"
"\n <face>0,0,1,0,120</face>"
"\n <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>"
"\n <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>"
"\n <color>0,1,1</color>"
"\n </solid>"
"\n <light>"
"\n <direction>1,1,1,1</direction>"
"\n <color>0.2,0.2,0.6</color>"
"\n </light>"
"\n <color>0.8,0.9,0.9</color>"
"\n</space>"
"\n</model>"
;
ARTICLE: "TODO" "Todo"
{ $list
"A vocab to initialize parameters"
"an editor mode"
{ $list "add a face to a solid"
"add a solid to the space"
"move a face"
"move a solid"
"select a solid in a list"
"select a face"
"display selected face"
"edit a solid color"
"add a light"
"edit a light color"
"move a light"
}
"add a tool wich give an hyperplane normal vector with enought points. Will use adsoda.intersect-hyperplanes with { { 0 } { 0 } { 1 } } "
"decorrelate 3D camera and activate them with select buttons"
} ;
ARTICLE: "4DNav" "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 visualization window represents the projection of the 4D space on a particular 3D space."
{ $heading "Start" }
"type:" { $code "\"4DNav\" run" }
{ $heading "Navigation" }
"Menu window is divided in 4 areas"
{ $list
{ "a space-file chooser to select the file to display" }
{ "a parametrization area to select the projection mode" }
{ "4D submenu to translate and rotate the 4D space" }
{ "3D submenu to move the camera in 3D space. Cameras in every 3D spaces are manipulated as a single one" }
}
{ $heading "Links" }
{ $subsection "Space file" }
{ $subsection "TODO" }
{ $subsection "implementation details" }
;
ABOUT: "4DNav"

556
unmaintained/4DNav/4DNav.factor Executable file
View File

@ -0,0 +1,556 @@
! 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 )
"resource: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

1
unmaintained/4DNav/authors.txt Executable file
View File

@ -0,0 +1 @@
Jeff Bigot

1
unmaintained/4DNav/camera/authors.txt Executable file
View File

@ -0,0 +1 @@
Adam Wendt

88
unmaintained/4DNav/camera/camera-docs.factor Executable file
View File

@ -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" "position" }
}
{ $description "return the position of the camera" } ;
HELP: camera-focus
{ $values
{ "point" "position" }
}
{ $description "return the point the camera looks at" } ;
HELP: camera-up
{ $values
{ "dirvec" "upside direction" }
}
{ $description "In order to precise the roling position of camera give an upward vector" } ;
HELP: do-look-at
{ $values
{ "camera" "direction" }
}
{ $description "Word to use in replacement of gl-look-at when using a camera" } ;
ARTICLE: "4DNav.camera" "Camera"
{ $vocab-link "4DNav.camera" }
"\n"
"A camera is defined by:"
{ $list
{ "a position (" { $link camera-eye } ")" }
{ "a focus direction (" { $link camera-focus } ")\n" }
{ "an attitude information (" { $link camera-up } ")\n" }
}
"\nUse " { $link do-look-at } " in opengl statement in placement of gl-look-at"
"\n\n"
"A camera is a " { $vocab-link "4DNav.turtle" } " object. Its a special vocab to handle mouvements of a 3D object:"
{ $list
{ "To define a camera"
{
$unchecked-example
"VAR: my-camera"
": init-my-camera ( -- )"
" <turtle> >my-camera"
" [ my-camera> >self"
" reset-turtle "
" ] with-scope ;"
} }
{ "To move it"
{
$unchecked-example
" [ my-camera> >self"
" 45 pitch-up "
" 5 step-turtle"
" ] with-scope "
} }
{ "or"
{
$unchecked-example
" [ my-camera> >self"
" 5 strafe-left"
" ] with-scope "
}
}
{
"to use it in an opengl statement"
{
$unchecked-example
"my-camera> do-look-at"
}
}
}
;
ABOUT: "4DNav.camera"

19
unmaintained/4DNav/camera/camera.factor Executable file
View File

@ -0,0 +1,19 @@
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 ;

31
unmaintained/4DNav/deep/deep-docs.factor Executable file
View File

@ -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" "Deep"
{ $vocab-link "4DNav.deep" }
;
ABOUT: "4DNav.deep"

13
unmaintained/4DNav/deep/deep.factor Executable file
View File

@ -0,0 +1,13 @@
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

15
unmaintained/4DNav/deploy.factor Executable file
View File

@ -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 }
}

1
unmaintained/4DNav/file-chooser/authors.txt Executable file
View File

@ -0,0 +1 @@
Jeff Bigot

157
unmaintained/4DNav/file-chooser/file-chooser.factor Executable file
View File

@ -0,0 +1,157 @@
! Copyright (C) 2008 Jeff Bigot
! See http://factorcode.org/license.txt for BSD license.
USING:
kernel
io.files
io.backend
io.directories
io.files.info
io.pathnames
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
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 any? ]
[ 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 ;

37
unmaintained/4DNav/hypercube.xml Executable file
View File

@ -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>

62
unmaintained/4DNav/light_test.xml Executable file
View File

@ -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>

50
unmaintained/4DNav/multi solids.xml Executable file
View File

@ -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>

25
unmaintained/4DNav/prismetriagone.xml Executable file
View File

@ -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>

1
unmaintained/4DNav/space-file-decoder/authors.txt Executable file
View File

@ -0,0 +1 @@
Jeff Bigot

20
unmaintained/4DNav/space-file-decoder/space-file-decoder-docs.factor Executable file
View File

@ -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.space-file-decoder
HELP: read-model-file
{ $values
{ "path" "path to the file to read" }
{ "x" "value" }
}
{ $description "Read a file containing the xml description of the model" } ;
ARTICLE: "4DNav.space-file-decoder" "Space XMLfile decoder"
{ $vocab-link "4DNav.space-file-decoder" }
;
ABOUT: "4DNav.space-file-decoder"

66
unmaintained/4DNav/space-file-decoder/space-file-decoder.factor Executable file
View File

@ -0,0 +1,66 @@
! Copyright (C) 2008 Jeff Bigot
! See http://factorcode.org/license.txt for BSD license.
USING: adsoda xml xml.utilities xml.dispatch 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
;

1
unmaintained/4DNav/summary.txt Executable file
View File

@ -0,0 +1 @@
4DNav : simmple tool to navigate thru a 4D space view as projections on 4 3D spaces.

1
unmaintained/4DNav/tags.txt Executable file
View File

@ -0,0 +1 @@
4D viewer

23
unmaintained/4DNav/triancube.xml Executable file
View File

@ -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>

1
unmaintained/4DNav/turtle/authors.txt Executable file
View File

@ -0,0 +1 @@
Eduardo Cavazos

11
unmaintained/4DNav/turtle/turtle-docs.factor Executable file
View File

@ -0,0 +1,11 @@
! 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
ARTICLE: "4DNav.turtle" "Turtle"
{ $vocab-link "4DNav.turtle" }
;
ABOUT: "4DNav.turtle"

154
unmaintained/4DNav/turtle/turtle.factor Executable file
View File

@ -0,0 +1,154 @@
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 ;

1
unmaintained/4DNav/window3D/authors.txt Executable file
View File

@ -0,0 +1 @@
Jeff Bigot

12
unmaintained/4DNav/window3D/window3D-docs.factor Executable file
View File

@ -0,0 +1,12 @@
! 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
ARTICLE: "4DNav.window3D" "Window3D"
{ $vocab-link "4DNav.window3D" }
;
ABOUT: "4DNav.window3D"

83
unmaintained/4DNav/window3D/window3D.factor Executable file
View File

@ -0,0 +1,83 @@
! 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 ;

299
unmaintained/adsoda/adsoda-docs.factor Executable file
View File

@ -0,0 +1,299 @@
! 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 "Substract solid2 from solid1" } ;
! --------------------------------------------------------------
! 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" "The 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 "display a face" } ;
HELP: solid->GL
{ $values { "solid" "a solid" } }
{ $description "display a solid" } ;
HELP: space->GL
{ $values { "space" "a space" } }
{ $description "display a space" } ;
! --------------------------------------------------------------
! 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"
" 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"

310
unmaintained/adsoda/adsoda-tests.factor Executable file
View File

@ -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

570
unmaintained/adsoda/adsoda.factor Executable file
View File

@ -0,0 +1,570 @@
! 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 ;

147
unmaintained/adsoda/adsoda.tests Executable file
View File

@ -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
;

2
unmaintained/adsoda/authors.txt Executable file
View File

@ -0,0 +1,2 @@
Jeff Bigot
Greg Ferrar

1
unmaintained/adsoda/combinators/authors.txt Executable file
View File

@ -0,0 +1 @@
JF Bigot, after Greg Ferrar

39
unmaintained/adsoda/combinators/combinators-docs.factor Executable file
View File

@ -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" "number of value to select" }
{ "array" array }
}
{ $description "returns an array containings every possibilities of n choices among a given sequence" } ;
HELP: columnize
{ $values
{ "array" array }
{ "array" array }
}
{ $description "flip a sequence into a sequence of 1 element sequences" } ;
HELP: concat-nth
{ $values
{ "seq1" sequence } { "seq2" sequence }
{ "seq" sequence }
}
{ $description "merges 2 sequences of sequences appending corresponding elements" } ;
HELP: do-cycle
{ $values
{ "array" array }
{ "array" array }
}
{ $description "Copy the first element at the end of the sequence in order to close the cycle." } ;
ARTICLE: "adsoda.combinators" "Combinators"
{ $vocab-link "adsoda.combinators" }
;
ABOUT: "adsoda.combinators"

11
unmaintained/adsoda/combinators/combinators-tests.factor Executable file
View File

@ -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

45
unmaintained/adsoda/combinators/combinators.factor Executable file
View File

@ -0,0 +1,45 @@
! 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

126
unmaintained/adsoda/solution2/solution2.factor Executable file
View File

@ -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 ;

1
unmaintained/adsoda/solution2/summary.txt Executable file
View File

@ -0,0 +1 @@
A modification of solution to approximate solutions

1
unmaintained/adsoda/summary.txt Executable file
View File

@ -0,0 +1 @@
ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm

1
unmaintained/adsoda/tags.txt Executable file
View File

@ -0,0 +1 @@
adsoda 4D viewer

1
unmaintained/adsoda/tools/authors.txt Executable file
View File

@ -0,0 +1 @@
Jeff Bigot

62
unmaintained/adsoda/tools/tools-docs.factor Executable file
View File

@ -0,0 +1,62 @@
! 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"
"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"
"returns a 4D solid with given limits"
} ;
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"
"With n points, creates n-1 vectors and then find a vector orthogonal to every others"
"returns { f } if a normal vector can not be found" }
;
HELP: points-to-hyperplane
{ $values
{ "points" "a list of n points" }
{ "hyperplane" "an hyperplane equation" }
}
{ $description "From a list of points, returns the equation of the hyperplan"
"Finds a normal vector and then translate it so that it includes one of the points"
}
;
ARTICLE: "adsoda.tools" "Tools"
{ $vocab-link "adsoda.tools" }
"Tools to help in building an " { $vocab-link "adsoda" } "-space"
;
ABOUT: "adsoda.tools"

14
unmaintained/adsoda/tools/tools-tests.factor Executable file
View File

@ -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

150
unmaintained/adsoda/tools/tools.factor Executable file
View File

@ -0,0 +1,150 @@
! 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
;