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