It's confusing to ripgrep through unmaintained/ and this eliminates all
incompatible/outdated code in the Factor repository.

Please contribute the worthy code back to Factor and remove it from factor-unmaintained.
char-rename
Doug Coleman 2017-06-04 15:39:41 -05:00
parent 9e76899dbd
commit 9aacb29667
509 changed files with 1 additions and 50766 deletions

View File

@ -117,7 +117,7 @@ The Factor source tree is organized as follows:
* `basis/` - Factor basis library, compiler, tools
* `extra/` - more libraries and applications
* `misc/` - editor modes, icons, etc
* `unmaintained/` - unmaintained contributions, please help!
* `unmaintained/` - now at [factor-unmaintained](https://github.com/factor/factor-unmaintained)
## Community

View File

@ -1,201 +0,0 @@
! Copyright (C) 2008 Jean-François Bigot.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations strings ;
IN: 4DNav
HELP: menu-3D
{ $values
{ "gadget" "gadget" }
}
{ $description "The menu dedicated to 3D movements of the camera" } ;
HELP: menu-4D
{ $values
{ "gadget" "gadget" }
}
{ $description "The menu dedicated to 4D movements of space" } ;
HELP: menu-bar
{ $values
{ "gadget" "gadget" }
}
{ $description "return gadget containing menu buttons" } ;
HELP: model-projection
{ $values
{ "x" "interger" }
{ "space" "space" }
}
{ $description "Project space following coordinate x" } ;
HELP: mvt-3D-1
{ $values
{ "quot" "quotation" }
}
{ $description "return a quotation to orientate space to see it from first point of view" } ;
HELP: mvt-3D-2
{ $values
{ "quot" "quotation" }
}
{ $description "return a quotation to orientate space to see it from second point of view" } ;
HELP: mvt-3D-3
{ $values
{ "quot" "quotation" }
}
{ $description "return a quotation to orientate space to see it from third point of view" } ;
HELP: mvt-3D-4
{ $values
{ "quot" "quotation" }
}
{ $description "return a quotation to orientate space to see it from first point of view" } ;
HELP: load-model-file
{ $description "load space from file" } ;
HELP: rotation-4D
{ $values
{ "m" "a rotation matrix" }
}
{ $description "Apply a 4D rotation matrix" } ;
HELP: translation-4D
{ $values
{ "v" "vector" }
}
{ $description "Apply a 4D translation" } ;
ARTICLE: "implementation details" "How 4DNav is done"
"4DNav is build using :"
{ $subsections
"4DNav.camera"
"adsoda-main-page"
}
;
ARTICLE: "Space file" "Create a new space file"
"To build a new space, create an XML file using " { $vocab-link "adsoda" } " model description. A solid is not caracterized by its corners but is defined as the intersection of hyperplanes."
$nl
"An example is:"
{ $code """
<model>
<space>
<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>""" } ;
ARTICLE: "TODO" "Todo"
{ $list
"A vocab to initialize parameters"
"an editor mode"
{ $list "add a face to a solid"
"add a solid to the space"
"move a face"
"move a solid"
"select a solid in a list"
"select a face"
"display selected face"
"edit a solid color"
"add a light"
"edit a light color"
"move a light"
}
"add a tool wich give an hyperplane normal vector with enought points. Will use adsoda.intersect-hyperplanes with { { 0 } { 0 } { 1 } } "
"decorrelate 3D camera and activate them with select buttons"
} ;
ARTICLE: "4DNav" "The 4DNav app"
{ $vocab-link "4DNav" }
$nl
{ $heading "4D Navigator" }
"4DNav is a simple tool to visualize 4 dimensionnal objects."
$nl
"It uses " { $vocab-link "adsoda" } " library to display a 4D space and navigate thru it."
$nl
"It will display:"
{ $list
{ "a menu window" }
{ "4 visualization windows" }
}
"Each visualization window represents the projection of the 4D space on a particular 3D space."
{ $heading "Start" }
"type:" { $code "\"4DNav\" run" }
{ $heading "Navigation" }
"Menu window is divided in 4 areas"
{ $list
{ "a space-file chooser to select the file to display" }
{ "a parametrization area to select the projection mode" }
{ "4D submenu to translate and rotate the 4D space" }
{ "3D submenu to move the camera in 3D space. Cameras in every 3D spaces are manipulated as a single one" }
}
{ $heading "Links" }
{ $subsections
"Space file"
"TODO"
"implementation details"
}
;
ABOUT: "4DNav"

View File

@ -1,567 +0,0 @@
! Copyright (C) 2008 Jeff Bigot
! See http://factorcode.org/license.txt for BSD license.
USING: kernel
namespaces
accessors
assocs
make
math
math.functions
math.trig
math.parser
hashtables
sequences
combinators
continuations
colors
colors.constants
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.frames
ui.gadgets.tracks
ui.gadgets.labels
ui.gadgets.labeled
ui.gadgets.lists
ui.gadgets.buttons
ui.gadgets.packs
ui.gadgets.grids
ui.gadgets.corners
ui.gestures
ui.gadgets.scrollers
splitting
vectors
math.vectors
values
4DNav.turtle
4DNav.window3D
4DNav.deep
4DNav.space-file-decoder
models
fry
adsoda
adsoda.tools
;
QUALIFIED-WITH: ui.pens.solid s
QUALIFIED-WITH: ui.gadgets.wrappers w
IN: 4DNav
VALUE: selected-file
VALUE: translation-step
VALUE: rotation-step
3 \ translation-step set-value
5 \ rotation-step set-value
VAR: selected-file-model
VAR: observer3d
VAR: view1
VAR: view2
VAR: view3
VAR: view4
VAR: present-space
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! namespace utilities
: closed-quot ( quot -- quot )
namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 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" } }
<radio-buttons> ;
: collision-detection-chooser ( -- gadget )
observer3d> collision-mode>>
{ { t "on" } { f "off" } } <radio-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 ]
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 ; inline
: 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 )
3 3 <frame>
{ 1 1 } >>filled-cell
<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 )
3 3 <frame>
{ 1 1 } >>filled-cell
<pile> 1 >>fill
<shelf> 1 >>fill
"X+" [ drop { 1 0 0 0 } translation-step v*n
translation-4D ]
button* add-gadget
"X-" [ drop { -1 0 0 0 } translation-step v*n
translation-4D ]
button* add-gadget
add-gadget
"YZW" <label> add-gadget
@bottom-right grid-add
<pile> 1 >>fill
"XZW" <label> add-gadget
<shelf> 1 >>fill
"Y+" [ drop { 0 1 0 0 } translation-step v*n
translation-4D ]
button* add-gadget
"Y-" [ drop { 0 -1 0 0 } translation-step v*n
translation-4D ]
button* add-gadget
add-gadget
@top-right grid-add
<pile> 1 >>fill
"XYW" <label> add-gadget
<shelf> 1 >>fill
"Z+" [ drop { 0 0 1 0 } translation-step v*n
translation-4D ]
button* add-gadget
"Z-" [ drop { 0 0 -1 0 } translation-step v*n
translation-4D ]
button* add-gadget
add-gadget
@top-left grid-add
<pile> 1 >>fill
<shelf> 1 >>fill
"W+" [ drop { 0 0 0 1 } translation-step v*n
translation-4D ]
button* add-gadget
"W-" [ drop { 0 0 0 -1 } translation-step v*n
translation-4D ]
button* add-gadget
add-gadget
"XYZ" <label> add-gadget
@bottom-left grid-add
"X" <label> @center grid-add
;
: menu-4D ( -- gadget )
<shelf>
"rotations" <label> add-gadget
menu-rotations-4D add-gadget
"translations" <label> add-gadget
menu-translations-4D add-gadget
0.5 >>align
{ 0 10 } >>gap
;
! ------------------------------------------------------
: redraw-model ( space -- )
>present-space
update-model-projections
update-observer-projections ;
: load-model-file ( -- )
selected-file dup selected-file-model> set-model
read-model-file
redraw-model ;
: mvt-3D-X ( turn pitch -- quot )
'[ turtle-pos> norm neg reset-turtle
_ turn-left
_ pitch-up
step-turtle ] ;
: mvt-3D-1 ( -- quot ) 90 0 mvt-3D-X ; inline
: mvt-3D-2 ( -- quot ) 0 90 mvt-3D-X ; inline
: mvt-3D-3 ( -- quot ) 0 0 mvt-3D-X ; inline
: mvt-3D-4 ( -- quot ) 45 45 mvt-3D-X ; inline
: camera-button ( string quot -- button )
[ <label> ] dip camera-action <repeat-button> ;
! ----------------------------------------------------------
! file chooser
! ----------------------------------------------------------
: <run-file-button> ( file-name -- button )
dup '[ drop _ \ selected-file set-value load-model-file
]
closed-quot <roll-button> { 0 0 } >>align ;
: <list-runner> ( -- gadget )
"resource:extra/4DNav"
<pile> 1 >>fill
over dup directory-files
[ ".xml" tail? ] filter
[ append-path ] with map
[ <run-file-button> add-gadget ] each
swap <labeled-gadget> ;
! -----------------------------------------------------
: menu-rotations-3D ( -- gadget )
3 3 <frame>
{ 1 1 } >>filled-cell
"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 )
3 3 <frame>
{ 1 1 } >>filled-cell
"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 ;
TUPLE: handler < w:wrapper table ;
: <handler> ( child -- handler ) handler w:new-wrapper ;
M: handler handle-gesture ( gesture gadget -- ? )
tuck table>> at dup [ call( gadget -- ) f ] [ 2drop t ] if ;
: add-keyboard-delegate ( obj -- obj )
<handler>
H{
{ 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 ] }
} >>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>
<scroller>
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
COLOR: purple s:<solid> >>interior
"4D movements" <labeled-gadget>
f track-add
<pile>
0.5 >>align
{ 2 2 } >>gap
menu-3D add-gadget
COLOR: purple s:<solid> >>interior
"Camera 3D" <labeled-gadget>
f track-add
COLOR: gray s:<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

View File

@ -1 +0,0 @@
Jeff Bigot

View File

@ -1 +0,0 @@
Adam Wendt

View File

@ -1,88 +0,0 @@
! Copyright (C) 2008 Jean-François Bigot.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel ;
IN: 4DNav.camera
HELP: camera-eye
{ $values
{ "point" "position" }
}
{ $description "return the position of the camera" } ;
HELP: camera-focus
{ $values
{ "point" "position" }
}
{ $description "return the point the camera looks at" } ;
HELP: camera-up
{ $values
{ "dirvec" "upside direction" }
}
{ $description "In order to precise the roling position of camera give an upward vector" } ;
HELP: do-look-at
{ $values
{ "camera" "direction" }
}
{ $description "Word to use in replacement of gl-look-at when using a camera" } ;
ARTICLE: "4DNav.camera" "Camera"
{ $vocab-link "4DNav.camera" }
$nl
"A camera is defined by:"
{ $list
{ "a position (" { $link camera-eye } ")" }
{ "a focus direction (" { $link camera-focus } ")" }
{ "an attitude information (" { $link camera-up } ")" }
}
"Use " { $link do-look-at } " in opengl statement in placement of gl-look-at"
$nl
"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"

View File

@ -1,18 +0,0 @@
USING: kernel namespaces math.vectors opengl opengl.glu 4DNav.turtle ;
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 ;

View File

@ -1,31 +0,0 @@
! Copyright (C) 2008 Jean-François Bigot.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations sequences ;
IN: 4DNav.deep
! HELP: deep-cleave-quots
! { $values
! { "seq" sequence }
! { "quot" quotation }
! }
! { $description "A word to build a soquence from a sequence of quotation" }
!
! { $examples
! "It is useful to build matrix"
! { $example "USING: math math.trig ; "
! " 30 deg>rad "
! " { { [ cos ] [ sin neg ] 0 } "
! " { [ sin ] [ cos ] 0 } "
! " { 0 0 1 } "
! " } deep-cleave-quots "
! " "
!
!
! } }
! ;
ARTICLE: "4DNav.deep" "Deep"
{ $vocab-link "4DNav.deep" }
;
ABOUT: "4DNav.deep"

View File

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

View File

@ -1,14 +0,0 @@
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-unicode? t }
{ deploy-io 3 }
{ "stop-after-last-window?" t }
{ deploy-word-defs? t }
}

View File

@ -1 +0,0 @@
Jeff Bigot

View File

@ -1,154 +0,0 @@
! Copyright (C) 2008 Jeff Bigot
! See http://factorcode.org/license.txt for BSD license.
USING:
kernel
io.files
io.backend
io.directories
io.files.info
io.pathnames
sequences
models
strings
ui
ui.operations
ui.commands
ui.gestures
ui.gadgets
ui.gadgets.buttons
ui.gadgets.lists
ui.gadgets.labels
ui.gadgets.tracks
ui.gadgets.packs
ui.gadgets.panes
ui.gadgets.scrollers
prettyprint
combinators
accessors
values
tools.walker
fry
;
IN: 4DNav.file-chooser
TUPLE: file-chooser < track
path
extension
selected-file
presenter
hook
list
;
: find-file-list ( gadget -- list )
[ file-chooser? ] find-parent list>> ;
file-chooser H{
{ T{ key-down f f "UP" }
[ find-file-list select-previous ] }
{ T{ key-down f f "DOWN" }
[ find-file-list select-next ] }
{ T{ key-down f f "PAGE_UP" }
[ find-file-list list-page-up ] }
{ T{ key-down f f "PAGE_DOWN" }
[ find-file-list list-page-down ] }
{ T{ key-down f f "RET" }
[ find-file-list invoke-value-action ] }
{ T{ button-down }
request-focus }
{ T{ button-down f 1 }
[ find-file-list invoke-value-action ] }
} set-gestures
: list-of-files ( file-chooser -- seq )
[ path>> value>> directory-entries ] [ extension>> ] bi
'[ [ name>> _ [ tail? ] with any? ]
[ directory? ] bi or ] filter
;
: update-filelist-model ( file-chooser -- )
[ list-of-files ] [ model>> ] bi set-model ;
: init-filelist-model ( file-chooser -- file-chooser )
dup list-of-files <model> >>model ;
: (fc-go) ( file-chooser button quot -- )
[ [ file-chooser? ] find-parent dup path>> ] dip
call
normalize-path swap set-model
update-filelist-model
drop ; inline
: fc-go-parent ( file-chooser button -- )
[ dup value>> parent-directory ] (fc-go) ;
: fc-go-home ( file-chooser button -- )
[ home ] (fc-go) ;
: fc-change-directory ( file-chooser file -- )
dupd [ path>> value>> normalize-path ] [ name>> ] bi*
append-path over path>> set-model
update-filelist-model
;
: fc-load-file ( file-chooser file -- )
over [ name>> ] [ selected-file>> ] bi* set-model
[ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi
call( path -- )
; 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 <border-button> add-gadget
over [ swap fc-go-home ] curry "go home"
swap <border-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 ;

View File

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

View File

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

View File

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

View File

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

View File

@ -1 +0,0 @@
Jeff Bigot

View File

@ -1,20 +0,0 @@
! Copyright (C) 2008 Jean-François Bigot.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel ;
IN: 4DNav.space-file-decoder
HELP: read-model-file
{ $values
{ "path" "path to the file to read" }
{ "x" "value" }
}
{ $description "Read a file containing the xml description of the model" } ;
ARTICLE: "4DNav.space-file-decoder" "Space XMLfile decoder"
{ $vocab-link "4DNav.space-file-decoder" }
;
ABOUT: "4DNav.space-file-decoder"

View File

@ -1,64 +0,0 @@
! Copyright (C) 2008 Jeff Bigot
! See http://factorcode.org/license.txt for BSD license.
USING: adsoda xml xml.traversal xml.syntax accessors
combinators sequences math.parser kernel splitting values
continuations ;
IN: 4DNav.space-file-decoder
: decode-number-array ( x -- y )
"," split [ string>number ] map ;
TAGS: adsoda-read-model ( tag -- model )
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 )
[
[ file>xml "space" tag-named adsoda-read-model ]
[ 2drop <space> ] recover
] [ <space> ] if*
;

View File

@ -1 +0,0 @@
Simple tool to navigate through a 4D space with projections on 4 3D spaces

View File

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

View File

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

View File

@ -1 +0,0 @@
Eduardo Cavazos

View File

@ -1,11 +0,0 @@
! Copyright (C) 2008 Jean-François Bigot.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays help.markup help.syntax kernel sequences ;
IN: 4DNav.turtle
ARTICLE: "4DNav.turtle" "Turtle"
{ $vocab-link "4DNav.turtle" }
;
ABOUT: "4DNav.turtle"

View File

@ -1,159 +0,0 @@
USING: kernel math arrays math.vectors math.matrices namespaces make
math.constants math.functions splitting grouping math.trig sequences
accessors 4DNav.deep models vars ;
IN: 4DNav.turtle
! replacement of self
VAR: self
: with-self ( quot obj -- ) [ >self call ] with-scope ; inline
: save-self ( quot -- ) self> [ self> clone >self call ] dip >self ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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 ;

View File

@ -1 +0,0 @@
Jeff Bigot

View File

@ -1,12 +0,0 @@
! Copyright (C) 2008 Jean-François Bigot.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel ;
IN: 4DNav.window3D
ARTICLE: "4DNav.window3D" "Window3D"
{ $vocab-link "4DNav.window3D" }
;
ABOUT: "4DNav.window3D"

View File

@ -1,82 +0,0 @@
! 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
prettyprint
;
IN: 4DNav.window3D
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! drawing functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: window3D < gadget observer ;
: <window3D> ( model observer -- gadget )
window3D new
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
! *************************
control-value
[ space->GL ] when*
! *************************
;
M: window3D graft* drop ;
M: window3D model-changed nip relayout ;

View File

@ -1,511 +0,0 @@
USING: accessors arrays assocs calendar colors
combinators.short-circuit help.markup help.syntax kernel locals
math math.functions math.matrices math.order math.parser
math.trig math.vectors opengl opengl.demo-support opengl.gl
sbufs sequences strings threads ui.gadgets ui.gadgets.worlds
ui.gestures ui.render ui.tools.workspace ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
IN: L-system
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: <turtle> pos ori angle length thickness color vertices saved ;
DEFER: default-L-parser-values
: reset-turtle ( turtle -- turtle )
{ 0 0 0 } clone >>pos
3 identity-matrix >>ori
V{ } clone >>vertices
V{ } clone >>saved
default-L-parser-values ;
: turtle ( -- turtle ) <turtle> new reset-turtle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: step-turtle ( TURTLE LENGTH -- turtle )
TURTLE
TURTLE pos>> TURTLE ori>> { 0 0 LENGTH } m.v v+
>>pos ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: Rx ( ANGLE -- Rx )
[let | ANGLE [ ANGLE deg>rad ] |
[let | A [ ANGLE cos ]
B [ ANGLE sin neg ]
C [ ANGLE sin ]
D [ ANGLE cos ] |
{ { 1 0 0 }
{ 0 A B }
{ 0 C D } }
] ] ;
:: Ry ( ANGLE -- Ry )
[let | ANGLE [ ANGLE deg>rad ] |
[let | A [ ANGLE cos ]
B [ ANGLE sin ]
C [ ANGLE sin neg ]
D [ ANGLE cos ] |
{ { A 0 B }
{ 0 1 0 }
{ C 0 D } }
] ] ;
:: Rz ( ANGLE -- Rz )
[let | ANGLE [ ANGLE deg>rad ] |
[let | A [ ANGLE cos ]
B [ ANGLE sin neg ]
C [ ANGLE sin ]
D [ ANGLE cos ] |
{ { A B 0 }
{ C D 0 }
{ 0 0 1 } }
] ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: apply-rotation ( TURTLE ROTATION -- turtle )
TURTLE TURTLE ori>> ROTATION m. >>ori ;
: rotate-x ( turtle angle -- turtle ) Rx apply-rotation ;
: rotate-y ( turtle angle -- turtle ) Ry apply-rotation ;
: rotate-z ( turtle angle -- turtle ) Rz apply-rotation ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: pitch-up ( turtle angle -- turtle ) neg rotate-x ;
: pitch-down ( turtle angle -- turtle ) rotate-x ;
: turn-left ( turtle angle -- turtle ) rotate-y ;
: turn-right ( turtle angle -- turtle ) neg rotate-y ;
: roll-left ( turtle angle -- turtle ) neg rotate-z ;
: roll-right ( turtle angle -- turtle ) rotate-z ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: V ( -- V ) { 0 1 0 } ;
: X ( turtle -- 3array ) ori>> [ first ] map ;
: Y ( turtle -- 3array ) ori>> [ second ] map ;
: Z ( turtle -- 3array ) ori>> [ third ] map ;
: set-X ( turtle seq -- turtle ) over ori>> [ set-first ] 2each ;
: set-Y ( turtle seq -- turtle ) over ori>> [ set-second ] 2each ;
: set-Z ( turtle seq -- turtle ) over ori>> [ set-third ] 2each ;
:: roll-until-horizontal ( TURTLE -- turtle )
TURTLE
V TURTLE Z cross normalize set-X
TURTLE Z TURTLE X cross normalize set-Y ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: strafe-up ( TURTLE LENGTH -- turtle )
TURTLE 90 pitch-up LENGTH step-turtle 90 pitch-down ;
:: strafe-down ( TURTLE LENGTH -- turtle )
TURTLE 90 pitch-down LENGTH step-turtle 90 pitch-up ;
:: strafe-left ( TURTLE LENGTH -- turtle )
TURTLE 90 turn-left LENGTH step-turtle 90 turn-right ;
:: strafe-right ( TURTLE LENGTH -- turtle )
TURTLE 90 turn-right LENGTH step-turtle 90 turn-left ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: polygon ( vertices -- ) GL_POLYGON glBegin [ first3 glVertex3d ] each glEnd ;
: start-polygon ( turtle -- turtle ) dup vertices>> delete-all ;
: finish-polygon ( turtle -- turtle ) dup vertices>> polygon ;
: polygon-vertex ( turtle -- turtle ) dup [ pos>> ] [ vertices>> ] bi push ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: record-vertex ( turtle -- turtle ) dup pos>> first3 glVertex3d ;
: draw-forward ( turtle length -- turtle )
GL_LINES glBegin [ record-vertex ] dip step-turtle record-vertex glEnd ;
: move-forward ( turtle length -- turtle ) step-turtle polygon-vertex ;
: sneak-forward ( turtle length -- turtle ) step-turtle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: scale-length ( turtle m -- turtle ) over length>> * >>length ;
: scale-angle ( turtle m -- turtle ) over angle>> * >>angle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: set-thickness ( turtle i -- turtle ) dup glLineWidth >>thickness ;
: scale-thickness ( turtle m -- turtle )
over thickness>> * 0.5 max set-thickness ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: color-table ( -- colors )
{
T{ rgba f 0 0 0 1 } ! black
T{ rgba f 0.5 0.5 0.5 1 } ! grey
T{ rgba f 1 0 0 1 } ! red
T{ rgba f 1 1 0 1 } ! yellow
T{ rgba f 0 1 0 1 } ! green
T{ rgba f 0.25 0.88 0.82 1 } ! turquoise
T{ rgba f 0 0 1 1 } ! blue
T{ rgba f 0.63 0.13 0.94 1 } ! purple
T{ rgba f 0.00 0.50 0.00 1 } ! dark green
T{ rgba f 0.00 0.82 0.82 1 } ! dark turquoise
T{ rgba f 0.00 0.00 0.50 1 } ! dark blue
T{ rgba f 0.58 0.00 0.82 1 } ! dark purple
T{ rgba f 0.50 0.00 0.00 1 } ! dark red
T{ rgba f 0.25 0.25 0.25 1 } ! dark grey
T{ rgba f 0.75 0.75 0.75 1 } ! medium grey
T{ rgba f 1 1 1 1 } ! white
} ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : material-color ( color -- )
! GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
: material-color ( color -- )
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot color>raw 4array gl-material ;
: set-color ( turtle i -- turtle )
dup color-table nth dup gl-color material-color >>color ;
: inc-color ( turtle -- turtle ) dup color>> 1 + set-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: save-turtle ( turtle -- turtle ) dup clone over saved>> push ;
: restore-turtle ( turtle -- turtle ) saved>> pop dup color>> set-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: default-L-parser-values ( turtle -- turtle )
1 >>length 45 >>angle 1 >>thickness 2 >>color ;
: L-parser-dialect ( -- commands )
{
{ "+" [ dup angle>> turn-left ] }
{ "-" [ dup angle>> turn-right ] }
{ "&" [ dup angle>> pitch-down ] }
{ "^" [ dup angle>> pitch-up ] }
{ "<" [ dup angle>> roll-left ] }
{ ">" [ dup angle>> roll-right ] }
{ "|" [ 180.0 rotate-y ] }
{ "%" [ 180.0 rotate-z ] }
{ "$" [ roll-until-horizontal ] }
{ "F" [ dup length>> draw-forward ] }
{ "Z" [ dup length>> 2 / draw-forward ] }
{ "f" [ dup length>> move-forward ] }
{ "z" [ dup length>> 2 / move-forward ] }
{ "g" [ dup length>> sneak-forward ] }
{ "." [ polygon-vertex ] }
{ "[" [ save-turtle ] }
{ "]" [ restore-turtle ] }
{ "{" [ start-polygon ] }
{ "}" [ finish-polygon ] }
{ "/" [ 1.1 scale-length ] } ! double quote command in lparser
{ "'" [ 0.9 scale-length ] }
{ ";" [ 1.1 scale-angle ] }
{ ":" [ 0.9 scale-angle ] }
{ "?" [ 1.4 scale-thickness ] }
{ "!" [ 0.7 scale-thickness ] }
{ "c" [ dup color>> 1 + color-table length mod set-color ] }
}
;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: <L-system> < gadget
camera display-list pedestal paused
turtle-values
commands axiom rules string ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: iterate-system ( GADGET -- ) GADGET pedestal>> 0.5 + GADGET pedestal<< ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: start-rotation-thread ( GADGET -- )
GADGET f >>paused drop
[
[
GADGET paused>>
[ f ]
[ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
if
]
loop
]
in-thread ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: open-paren ( -- ch ) CHAR: ( ;
: close-paren ( -- ch ) CHAR: ) ;
: open-paren? ( obj -- ? ) open-paren = ;
: close-paren? ( obj -- ? ) close-paren = ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: read-instruction ( STRING -- next rest )
{ [ STRING length 1 > ] [ STRING second open-paren? ] } 0&&
[ STRING close-paren STRING index 1 + cut ]
[ STRING 1 cut ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: iterate-string-loop ( STRING RULES ACCUM -- )
STRING empty? not
[
STRING read-instruction
[let | REST [ ] NEXT [ ] |
NEXT 1 head RULES at NEXT or ACCUM push-all
REST RULES ACCUM iterate-string-loop ]
]
when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: iterate-string ( STRING RULES -- string )
[let | ACCUM [ STRING length 10 * <sbuf> ] |
STRING RULES ACCUM iterate-string-loop
ACCUM >string ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: interpret-string ( STRING COMMANDS -- )
STRING empty? not
[
STRING read-instruction
[let | REST [ ] NEXT [ ] |
[let | COMMAND [ NEXT 1 head COMMANDS at ] |
COMMAND
[
NEXT length 1 =
[ COMMAND call ]
[
NEXT 2 tail 1 head* string>number
COMMAND 1 tail*
call
]
if
]
when ]
REST COMMANDS interpret-string ]
]
when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: iterate-L-system-string ( L-SYSTEM -- )
L-SYSTEM string>> L-SYSTEM axiom>> or
L-SYSTEM rules>>
iterate-string
L-SYSTEM string<< ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: do-camera-look-at ( CAMERA -- )
[let | EYE [ CAMERA pos>> ]
FOCUS [ CAMERA clone 1 step-turtle pos>> ]
UP [ CAMERA clone 90 pitch-up 1 step-turtle pos>> CAMERA pos>> v- ]
|
EYE FOCUS UP gl-look-at ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: generate-display-list ( L-SYSTEM -- )
L-SYSTEM find-gl-context
L-SYSTEM display-list>> GL_COMPILE glNewList
turtle
L-SYSTEM turtle-values>> [ ] or call
L-SYSTEM string>> L-SYSTEM axiom>> or
L-SYSTEM commands>>
interpret-string
drop
glEndList ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M:: <L-system> draw-gadget* ( L-SYSTEM -- )
black gl-clear
GL_FLAT glShadeModel
GL_PROJECTION glMatrixMode
glLoadIdentity
-1 1 -1 1 1.5 200 glFrustum
GL_MODELVIEW glMatrixMode
glLoadIdentity
L-SYSTEM camera>> do-camera-look-at
GL_FRONT_AND_BACK GL_LINE glPolygonMode
! draw axis
white gl-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
! rotate pedestal
L-SYSTEM pedestal>> 0 0 1 glRotated
L-SYSTEM display-list>> glCallList ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M:: <L-system> graft* ( L-SYSTEM -- )
L-SYSTEM find-gl-context
1 glGenLists L-SYSTEM display-list<< ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M:: <L-system> pref-dim* ( L-SYSTEM -- dim ) { 400 400 } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: with-camera ( L-SYSTEM QUOT -- )
L-SYSTEM camera>> QUOT call drop
L-SYSTEM relayout-1 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<L-system>
H{
{ T{ key-down f f "LEFT" } [ [ 5 turn-left ] with-camera ] }
{ T{ key-down f f "RIGHT" } [ [ 5 turn-right ] with-camera ] }
{ T{ key-down f f "UP" } [ [ 5 pitch-down ] with-camera ] }
{ T{ key-down f f "DOWN" } [ [ 5 pitch-up ] with-camera ] }
{ T{ key-down f f "a" } [ [ 1 step-turtle ] with-camera ] }
{ T{ key-down f f "z" } [ [ -1 step-turtle ] with-camera ] }
{ T{ key-down f f "q" } [ [ 5 roll-left ] with-camera ] }
{ T{ key-down f f "w" } [ [ 5 roll-right ] with-camera ] }
{ T{ key-down f { A+ } "LEFT" } [ [ 1 strafe-left ] with-camera ] }
{ T{ key-down f { A+ } "RIGHT" } [ [ 1 strafe-right ] with-camera ] }
{ T{ key-down f { A+ } "UP" } [ [ 1 strafe-up ] with-camera ] }
{ T{ key-down f { A+ } "DOWN" } [ [ 1 strafe-down ] with-camera ] }
{ T{ key-down f f "r" } [ start-rotation-thread ] }
{
T{ key-down f f "x" }
[
dup iterate-L-system-string
dup generate-display-list
dup relayout-1
drop
]
}
{ T{ key-down f f "F1" } [ drop "L-system" help-window ] }
}
set-gestures
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: L-system ( -- L-system )
<L-system> new-gadget
0 >>pedestal
! turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ;
turtle 90 pitch-down -5 step-turtle 2 strafe-up >>camera
dup start-rotation-thread
;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "L-system" "L-system"
"Press 'x' to iterate the L-system." $nl
"Camera control:"
{ $table
{ "a" "Forward" }
{ "z" "Backward" }
{ "LEFT" "Turn left" }
{ "RIGHT" "Turn right" }
{ "UP" "Pitch down" }
{ "DOWN" "Pitch up" }
{ "q" "Roll left" }
{ "w" "Roll right" } } ;
ABOUT: "L-system"

View File

@ -1,27 +0,0 @@
USING: accessors ui L-system ;
IN: L-system.models.abop-1
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: abop-1 ( <L-system> -- <L-system> )
L-parser-dialect >>commands
"c(12)FFAL" >>axiom
{
{ "A" "F [ & '(.8) ! B L ] >(137) ' !(.9) A" }
{ "B" "F [ - '(.8) !(.9) $ C L ] ' !(.9) C" }
{ "C" "F [ + '(.8) !(.9) $ B L ] ' !(.9) B" }
{ "L" " ~ c(8) { +(30) f -(120) f -(120) f }" }
}
>>rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: main ( -- ) [ L-system abop-1 "L-system" open-window ] with-ui ;
MAIN: main

View File

@ -1,31 +0,0 @@
USING: accessors ui L-system ;
IN: L-system.models.abop-2
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: abop-2 ( <L-system> -- <L-system> )
L-parser-dialect >>commands
[ 30 >>angle ] >>turtle-values
"c(12)FAL" >>axiom
{
{ "A" "F [&'(.7)!BL] >(137) [&'(.6)!BL] >(137) '(.9) !(.9) A" }
{ "B" "F [- '(.7) !(.9) $ C L] '(.9) !(.9) C" }
{ "C" "F [+ '(.7) !(.9) $ B L] '(.9) !(.9) B" }
{ "L" "~c(8){+f(.1)-f(.1)-f(.1)+|+f(.1)-f(.1)-f(.1)}" }
} >>rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: main ( -- ) [ L-system abop-2 "L-system" open-window ] with-ui ;
MAIN: main

View File

@ -1,27 +0,0 @@
USING: accessors ui L-system ;
IN: L-system.models.abop-3
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: abop-3 ( <L-system> -- <L-system> )
L-parser-dialect >>commands
[ 30 >>angle ] >>turtle-values
"c(12)FA" >>axiom
{
{ "A" "!(.9)t(.4)FB>(94)B>(132)B" }
{ "B" "[&t(.4)F$A]" }
{ "F" "'(1.25)F'(.8)" }
}
>>rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: main ( -- ) [ L-system abop-3 "L-system" open-window ] with-ui ;
MAIN: main

View File

@ -1,56 +0,0 @@
USING: accessors ui L-system ;
IN: L-system.models.abop-4
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: abop-4 ( <L-system> -- <L-system> )
L-parser-dialect >>commands
[ 18 >>angle ] >>turtle-values
"c(12)&(20)N" >>axiom
{
{
"N"
"FII[&(60)rY]>(90)[&(45)'(0.8)rA]>(90)[&(60)rY]>(90)[&(45)'(0.8)rD]!FIK"
}
{ "Y" "[c(4){++l.--l.--l.++|++l.--l.--l.}]" }
{ "l" "g(.2)l" }
{ "K" "[!c(2)FF>w>(72)w>(72)w>(72)w>(72)w]" }
{ "w" "[c(2)^!F][c(5)&(72){-(54)f(3)+(54)f(3)|-(54)f(3)+(54)f(3)}]" }
{ "f" "_" }
{ "A" "B" }
{ "B" "C" }
{ "C" "D" }
{ "D" "E" }
{ "E" "G" }
{ "G" "H" }
{ "H" "N" }
{ "I" "FoO" }
{ "O" "FoP" }
{ "P" "FoQ" }
{ "Q" "FoR" }
{ "R" "FoS" }
{ "S" "FoT" }
{ "T" "FoU" }
{ "U" "FoV" }
{ "V" "FoW" }
{ "W" "FoX" }
{ "X" "_" }
{ "o" "$t(-0.03)" }
{ "r" "~(30)" }
}
>>rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: main ( -- ) [ L-system abop-4 "L-system" open-window ] with-ui ;
MAIN: main

View File

@ -1,33 +0,0 @@
USING: accessors ui L-system ;
IN: L-system.models.abop-5-angular
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: abop-5-angular ( <L-system> -- <L-system> )
L-parser-dialect >>commands
"&(90)+(90)a" >>axiom
{
{ "a" "F[+(45)l][-(45)l]^;ca" }
{ "l" "j" }
{ "j" "h" }
{ "h" "s" }
{ "s" "d" }
{ "d" "x" }
{ "x" "a" }
{ "F" "'(1.17)F'(.855)" }
}
>>rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: main ( -- ) [ L-system abop-5-angular "L-system" open-window ] with-ui ;
MAIN: main

View File

@ -1,35 +0,0 @@
USING: accessors ui L-system ;
IN: L-system.models.abop-5
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: abop-5 ( <L-system> -- <L-system> )
L-parser-dialect >>commands
[ 5 >>angle ] >>turtle-values
"a" >>axiom
{
{ "a" "F[+(45)l][-(45)l]^;ca" }
{ "l" "j" }
{ "j" "h" }
{ "h" "s" }
{ "s" "d" }
{ "d" "x" }
{ "x" "a" }
{ "F" "'(1.17)F'(.855)" }
}
>>rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: main ( -- ) [ L-system abop-5 "L-system" open-window ] with-ui ;
MAIN: main

View File

@ -1,34 +0,0 @@
USING: accessors ui L-system ;
IN: L-system.models.abop-6
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: abop-6 ( <L-system> -- <L-system> )
L-parser-dialect >>commands
[ 5 >>angle ] >>turtle-values
! "&(90)+(90)FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x"
"FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x"
>>axiom
{
{ "a" "F[cdx][cex]F!(.9)a" }
{ "x" "a" }
{ "d" "+d" }
{ "e" "-e" }
{ "F" "'(1.25)F'(.8)" }
}
>>rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: main ( -- ) [ L-system abop-6 "L-system" open-window ] with-ui ;
MAIN: main

View File

@ -1,52 +0,0 @@
USING: accessors ui L-system ;
IN: L-system.models.airhorse
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: airhorse ( <L-system> -- <L-system> )
L-parser-dialect >>commands
[ 10 >>angle ] >>turtle-values
"C" >>axiom
{
{ "C" "LBW" }
{ "B" "[[''aH]|[g]]" }
{ "a" "Fs+;'a" }
{ "g" "Ft+;'g" }
{ "s" "[::cc!!!!&&[FFcccZ]^^^^FFcccZ]" }
{ "t" "[c!!!!&[FF]^^FF]" }
{ "L" "O" }
{ "O" "P" }
{ "P" "Q" }
{ "Q" "R" }
{ "R" "U" }
{ "U" "X" }
{ "X" "Y" }
{ "Y" "V" }
{ "V" "[cc!!!&(90)[Zp]|[Zp]]" }
{ "p" "h>(120)h>(120)h" }
{ "h" "[+(40)!F'''p]" }
{ "H" "[cccci[>(50)dcFFF][<(50)ecFFF]]" }
{ "d" "Z!&Z!&:'d" }
{ "e" "Z!^Z!^:'e" }
{ "i" "-:/i" }
{ "W" "[%[!!cb][<<<!!cb][>>>!!cb]]" }
{ "b" "Fl!+Fl+;'b" }
{ "l" "[-cc{--z++z++z--|--z++z++z}]" }
}
>>rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: main ( -- ) [ L-system airhorse "L-system" open-window ] with-ui ;
MAIN: main

View File

@ -1,36 +0,0 @@
USING: accessors ui L-system ;
IN: L-system.models.tree-5
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: tree-5 ( <L-system> -- <L-system> )
L-parser-dialect >>commands
[ 5 >>angle ] >>turtle-values
"c(4)FFS" >>axiom
{
{ "S" "FFR>(60)R>(60)R>(60)R>(60)R>(60)R>(30)S" }
{ "R" "[Ba]" }
{ "a" "$tF[Cx]Fb" }
{ "b" "$tF[Dy]Fa" }
{ "B" "&B" }
{ "C" "+C" }
{ "D" "-D" }
{ "x" "a" }
{ "y" "b" }
{ "F" "'(1.25)F'(.8)" }
}
>>rules ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: main ( -- ) [ L-system tree-5 "L-system" open-window ] with-ui ;
MAIN: main

View File

@ -1,307 +0,0 @@
! 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" $nl
"what is an halfspace" $nl
"halfspace touching-corners adjacent-faces" $nl
"touching-corners list of pointers to the corners which touch this face" $nl
"adjacent-faces list of pointers to the faces which touch this face"
{ $subsections
face
<face>
}
"test relative position"
{ $subsections
point-inside-or-on-face?
point-inside-face?
}
"handling face"
{ $subsections
flip-face
face-translate
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"
{ $subsections
solid
<solid>
}
"test relative position"
{ $subsections
point-inside-solid?
point-inside-or-on-solid?
}
"playing with faces and solids"
{ $subsections
add-face
cut-solid
slice-solid
}
"solid handling"
{ $subsections
solid-project
solid-translate
solid-transform
subtract
get-silhouette
solid=
}
;
HELP: solid
{ $class-description "dimension" $nl "silhouettes" $nl "faces" $nl "corners" $nl "adjacencies-valid" $nl "color" $nl "name"
}
;
HELP: add-face
{ $values { "solid" "a solid" } { "face" "a face" } }
{ $description "reshape a solid with a face. The face truncate the solid." } ;
HELP: cut-solid
{ $values { "solid" "a solid" } { "halfspace" "an halfspace" } }
{ $description "like add-face but just with halfspace equation" } ;
HELP: slice-solid
{ $values { "solid" "a solid" } { "face" "a face" } { "solid1" "the outer part of the former solid" } { "solid2" "the inner part of the former solid" } }
{ $description "cut a solid into two parts. The face acts like a knife"
} ;
HELP: solid-project
{ $values { "lights" "lights" } { "ambient" "ambient" } { "solid" "solid" } { "solids" "projection of solid" } }
{ $description "Project the solid using pv vector"
$nl
"TODO: explain how to use lights"
} ;
HELP: solid-translate
{ $values { "solid" "a solid" } { "v" "translating vector" } }
{ $description "Translate a solid using a vector"
$nl
"v and solid must have the same dimension "
} ;
HELP: solid-transform
{ $values { "solid" "a solid" } { "m" "transformation matrix" } }
{ $description "Transform a solid using a matrix"
$nl
"v and solid must have the same dimension "
} ;
HELP: subtract
{ $values { "solid1" "initial shape" } { "solid2" "shape to remove" } { "solids" "resulting shape" } }
{ $description "Substract solid2 from solid1" } ;
! --------------------------------------------------------------
! space
! --------------------------------------------------------------
ARTICLE: "space-page" "Space in ADSODA"
"A space is a collection of solids and lights."
$nl
"link to functions"
$nl
"Defining words"
{ $subsections
space
<space>
suffix-solids
suffix-lights
clear-space-solids
describe-space
}
"Handling space"
{ $subsections
space-ensure-solids
eliminate-empty-solids
space-transform
space-translate
remove-hidden-solids
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
{ $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
{ $values { "space" "a space" } }
{ $description "return a description of space" } ;
HELP: space-project
{ $values { "space" "a space" } { "i" "an integer" } }
{ $description "Project a space along ith coordinate" } ;
! --------------------------------------------------------------
! 3D rendering
! --------------------------------------------------------------
ARTICLE: "3D-rendering-page" "The 3D rendering in ADSODA"
"explanation of 3D rendering"
$nl
"link to functions"
{ $subsections
face->GL
solid->GL
space->GL
}
;
HELP: face->GL
{ $values { "face" "a face" } { "color" "3 3 values array" } }
{ $description "display a face" } ;
HELP: solid->GL
{ $values { "solid" "a solid" } }
{ $description "display a solid" } ;
HELP: space->GL
{ $values { "space" "a space" } }
{ $description "display a space" } ;
! --------------------------------------------------------------
! light
! --------------------------------------------------------------
ARTICLE: "light-page" "Light in ADSODA"
"explanation of light"
$nl
"link to functions"
;
ARTICLE: { "adsoda" "light" } "ADSODA : lights"
{ $code """
! HELP: light position color
! <light> ( -- tuple ) light new ;
! light est un vecteur avec 3 variables pour les couleurs\n
void Light::Apply(Vector& normal, double &cRed, double &cGreen, double &cBlue)\n
{ \n
// Dot the light direction with the normalized normal of Face.
register double intensity = -(normal * (*this));
// Face is a backface, from light's perspective
if (intensity < 0)
return;
// Add the intensity componentwise
cRed += red * intensity;
cGreen += green * intensity;
cBlue += blue * intensity;
// Clip to unit range
if (cRed > 1.0) cRed = 1.0;
if (cGreen > 1.0) cGreen = 1.0;
if (cBlue > 1.0) cBlue = 1.0;
""" }
;
ARTICLE: { "adsoda" "halfspace" } "ADSODA : halfspace"
" defined by the concatenation of the normal vector and a constant"
;
ARTICLE: "adsoda-main-page" "ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm"
"multidimensional handler :"
$nl
"design a solid using face delimitations. Only works on convex shapes"
$nl
{ $emphasis "written in C++ by Greg Ferrar" }
$nl
"full explanation on adsoda page at " { $url "http://www.flowerfire.com/ADSODA/" }
$nl
"Useful words are describe on the following pages: "
{ $subsections
"face-page"
"solid-page"
"space-page"
"light-page"
"3D-rendering-page"
} ;
ABOUT: "adsoda-main-page"

View File

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

View File

@ -1,569 +0,0 @@
! 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 \ remove-hidden-solids? set-value
0.0000001 \ VERY-SMALL-NUM set-value
0.0000001 \ ZERO-VALUE set-value
4 \ MAX-FACE-PER-CORNER set-value
! -------------------------------------------------------------
! sequence complement
: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline
: dimension ( array -- x ) length 1 - ; inline
: change-last ( seq quot -- )
[ [ dimension ] keep ] dip change-nth ; inline
! -------------------------------------------------------------
! 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
sift ;
: (face-silhouette) ( face -- faces )
clone dup adjacent-faces>>
[ backface?
[ intersection-into-silhouette-face ] [ 2drop f ] if
] with map
sift
; 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
sift
<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
sift
[ 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>> ] same? ;
: space-apply ( space m quot -- space )
curry [ map ] curry [ dup solids>> ] dip
[ call ] [ 2drop ] recover drop ; inline
: 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 ;

View File

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

View File

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

View File

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

View File

@ -1,39 +0,0 @@
! Copyright (C) 2008 Jeff Bigot.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays help.markup help.syntax kernel sequences ;
IN: adsoda.combinators
HELP: among
{ $values
{ "array" array } { "n" "number of value to select" }
{ "array" array }
}
{ $description "returns an array containings every possibilities of n choices among a given sequence" } ;
HELP: columnize
{ $values
{ "array" array }
{ "array" array }
}
{ $description "flip a sequence into a sequence of 1 element sequences" } ;
HELP: concat-nth
{ $values
{ "seq1" sequence } { "seq2" sequence }
{ "seq" sequence }
}
{ $description "merges 2 sequences of sequences appending corresponding elements" } ;
HELP: do-cycle
{ $values
{ "array" array }
{ "array" array }
}
{ $description "Copy the first element at the end of the sequence in order to close the cycle." } ;
ARTICLE: "adsoda.combinators" "Combinators"
{ $vocab-link "adsoda.combinators" }
;
ABOUT: "adsoda.combinators"

View File

@ -1,11 +0,0 @@
USING: adsoda.combinators
sequences
tools.test
;
IN: adsoda.combinators.tests
[ { "atoto" "b" "ctoto" } ] [ { "a" "b" "c" } 1 [ "toto" append ] map-but ]
unit-test

View File

@ -1,45 +0,0 @@
! 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 = ] [ 4drop { } ] }
{ [ 2dup < ] [ 2drop [ 1 cut ] dip
[ 1 - among [ append ] with map ]
[ among append ] 2bi
] }
{ [ 2dup = ] [ 3drop 1array ] }
{ [ 2dup > ] [ 4drop { } ] }
} 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

View File

@ -1,126 +0,0 @@
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? ] reject ;
: 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 ;

View File

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

View File

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

View File

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

View File

@ -1 +0,0 @@
Jeff Bigot

View File

@ -1,62 +0,0 @@
! Copyright (C) 2008 Jeff Bigot.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays help.markup help.syntax kernel sequences ;
IN: adsoda.tools
HELP: 3cube
{ $values
{ "array" "array" } { "name" "name" }
{ "solid" "solid" }
}
{ $description "array : xmin xmax ymin ymax zmin zmax"
"returns a 3D solid with given limits"
} ;
HELP: 4cube
{ $values
{ "array" "array" } { "name" "name" }
{ "solid" "solid" }
}
{ $description "array : xmin xmax ymin ymax zmin zmax wmin wmax"
"returns a 4D solid with given limits"
} ;
HELP: equation-system-for-normal
{ $values
{ "points" "a list of n points" }
{ "matrix" "matrix" }
}
{ $description "From a list of points, return the matrix"
"to solve in order to find the vector normal to the plan defined by the points" }
;
HELP: normal-vector
{ $values
{ "points" "a list of n points" }
{ "v" "a vector" }
}
{ $description "From a list of points, returns the vector normal to the plan defined by the points"
"With n points, creates n-1 vectors and then find a vector orthogonal to every others"
"returns { f } if a normal vector can not be found" }
;
HELP: points-to-hyperplane
{ $values
{ "points" "a list of n points" }
{ "hyperplane" "an hyperplane equation" }
}
{ $description "From a list of points, returns the equation of the hyperplan"
"Finds a normal vector and then translate it so that it includes one of the points"
}
;
ARTICLE: "adsoda.tools" "Tools"
{ $vocab-link "adsoda.tools" }
"Tools to help in building an " { $vocab-link "adsoda" } "-space"
;
ABOUT: "adsoda.tools"

View File

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

View File

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

View File

@ -1,27 +0,0 @@
IN: advice
USING: help.markup help.syntax tools.annotations words coroutines ;
HELP: make-advised
{ $values { "word" "a word to annotate in preparation of advising" } }
{ $description "Prepares a word for being advised. This is done by: "
{ $list
{ "Annotating it to call the appropriate words before, around, and after the original body " }
{ "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
{ "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
}
}
{ $see-also advised? annotate } ;
HELP: advised?
{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
{ $description "Determines whether or not the given word has any advice on it." } ;
HELP: ad-do-it
{ $values { "input" "an object" } { "result" "an object" } }
{ $description "Calls either the next applicable around advice or the main body, returning back to the point it was called from when finished. This word should only be called from inside advice." }
{ $see-also coyield } ;
ARTICLE: "advice" "Advice"
"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
ABOUT: "advice"

View File

@ -1,94 +0,0 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences io io.streams.string math tools.test advice math.parser
parser namespaces multiline eval words assocs ;
IN: advice.tests
[
[ ad-do-it ] must-fail
: foo ( -- str ) "foo" ;
\ foo make-advised
{ "bar" "foo" } [
[ "bar" ] "barify" \ foo advise-before
foo
] unit-test
{ "bar" "foo" "baz" } [
[ "baz" ] "bazify" \ foo advise-after
foo
] unit-test
{ "foo" "baz" } [
"barify" \ foo before remove-advice
foo
] unit-test
: bar ( a -- b ) 1 + ;
\ bar make-advised
{ 11 } [
[ 2 * ] "double" \ bar advise-before
5 bar
] unit-test
{ 11/3 } [
[ 3 / ] "third" \ bar advise-after
5 bar
] unit-test
{ -2 } [
[ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
5 bar
] unit-test
: add ( a b -- c ) + ;
\ add make-advised
{ 10 } [
[ [ 2 * ] bi@ ] "double-args" \ add advise-before
2 3 add
] unit-test
{ 21 } [
[ 3 * ad-do-it 1- ] "around1" \ add advise-around
2 3 add
] unit-test
! { 9 } [
! [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
! 2 3 add
! ] unit-test
! { { "around1" "around2" } } [
! \ add around word-prop keys
! ] unit-test
{ 5 f } [
\ add unadvise
2 3 add \ add advised?
] unit-test
! : quux ( a b -- c ) * ;
! { f t 3+3/4 } [
! <" USING: advice kernel math ;
! IN: advice.tests
! \ quux advised?
! ADVISE: quux halve before [ 2 / ] bi@ ;
! \ quux advised?
! 3 5 quux"> eval
! ] unit-test
! { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
! <" USING: advice kernel math math.parser io io.streams.string ;
! IN: advice.tests
! ADVISE: quux log around
! 2dup [ number>string write " " write ] bi@
! ad-do-it
! dup number>string write ;
! [ 3 5 quux ] with-string-writer"> eval
! ] unit-test
] with-scope

View File

@ -1,69 +0,0 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences fry words assocs linked-assocs tools.annotations
coroutines lexer parser quotations arrays namespaces continuations
summary ;
IN: advice
SYMBOLS: before after around advised in-advice? ;
: advised? ( word -- ? )
advised word-prop ;
DEFER: make-advised
<PRIVATE
: init-around-co ( quot -- coroutine )
\ coreset suffix cocreate ;
PRIVATE>
: advise ( quot name word loc -- )
dup around eq? [ [ init-around-co ] 3dip ] when
over advised? [ over make-advised ] unless
word-prop set-at ;
: advise-before ( quot name word -- ) before advise ;
: advise-after ( quot name word -- ) after advise ;
: advise-around ( quot name word -- ) around advise ;
: get-advice ( word type -- seq )
word-prop values ;
: call-before ( word -- )
before get-advice [ call ] each ;
: call-after ( word -- )
after get-advice [ call ] each ;
: call-around ( main word -- )
t in-advice? [
around get-advice tuck
[ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
] with-variable ;
: remove-advice ( name word loc -- )
word-prop delete-at ;
ERROR: ad-do-it-error ;
M: ad-do-it-error summary
drop "ad-do-it should only be called inside 'around' advice" ;
: ad-do-it ( input -- result )
in-advice? get [ ad-do-it-error ] unless coyield ;
: make-advised ( word -- )
[ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
[ { before after around } [ <linked-hash> swap set-word-prop ] with each ]
[ t advised set-word-prop ] tri ;
: unadvise ( word -- )
[ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
SYNTAX: ADVISE: ! word adname location => word adname quot loc
scan-word scan scan-word parse-definition swap [ spin ] dip advise ;
SYNTAX: UNADVISE:
scan-word suffix! \ unadvise suffix! ;

View File

@ -1 +0,0 @@
James Cash

View File

@ -1 +0,0 @@
Implmentation of advice/aspects

View File

@ -1 +0,0 @@
extensions

View File

@ -1 +0,0 @@
Jeremy Hughes

View File

@ -1,34 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.cxx.parser alien.marshall
alien.inline.types classes.mixin classes.tuple kernel namespaces
assocs sequences parser classes.parser alien.marshall.syntax
interpolate locals effects io strings make vocabs.parser words
generic fry quotations ;
IN: alien.cxx
<PRIVATE
: class-mixin ( str -- word )
create-class-in [ define-mixin-class ] keep ;
: class-tuple-word ( word -- word' )
"#" append create-word-in ;
: define-class-tuple ( word mixin -- )
[ drop class-wrapper { } define-tuple-class ]
[ add-mixin-instance ] 2bi ;
PRIVATE>
: define-c++-class ( name superclass-mixin -- )
[ [ class-tuple-word ] [ class-mixin ] bi dup ] dip
add-mixin-instance define-class-tuple ;
:: define-c++-method ( class-name generic name types effect virtual -- )
[ name % "_" % class-name H{ { CHAR: : CHAR: _ } } substitute % ] "" make :> name'
effect [ in>> "self" suffix ] [ out>> ] bi <effect> :> effect'
types class-name "*" append suffix :> types'
effect in>> "," join :> args
class-name virtual [ "#" append ] unless current-vocab lookup :> class
SBUF" " clone dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body
name' types' effect' body define-c-marshalled
class generic create-method name' current-vocab lookup 1quotation define ;

View File

@ -1 +0,0 @@
Jeremy Hughes

View File

@ -1,10 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: parser lexer alien.inline ;
IN: alien.cxx.parser
: parse-c++-class-definition ( -- class superclass-mixin )
scan scan-word ;
: parse-c++-method-definition ( -- class-name generic name types effect )
scan scan-word function-types-effect ;

View File

@ -1 +0,0 @@
Jeremy Hughes

View File

@ -1,113 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test alien.cxx.syntax alien.inline.syntax
alien.marshall.syntax alien.marshall accessors kernel ;
IN: alien.cxx.syntax.tests
DELETE-C-LIBRARY: test
C-LIBRARY: test
COMPILE-AS-C++
C-INCLUDE: <string>
C-TYPEDEF: std::string string
C++-CLASS: std::string c++-root
GENERIC: to-string ( obj -- str )
C++-METHOD: std::string to-string const-char* c_str ( )
CM-FUNCTION: std::string* new_string ( const-char* s )
return new std::string(s);
;
;C-LIBRARY
ALIAS: <std::string> new_string
{ 1 1 } [ new_string ] must-infer-as
{ 1 1 } [ c_str_std__string ] must-infer-as
[ t ] [ "abc" <std::string> std::string? ] unit-test
[ "abc" ] [ "abc" <std::string> to-string ] unit-test
DELETE-C-LIBRARY: inheritance
C-LIBRARY: inheritance
COMPILE-AS-C++
C-INCLUDE: <cstring>
<RAW-C
class alpha {
public:
alpha(const char* s) {
str = s;
};
const char* render() {
return str;
};
virtual const char* chop() {
return str;
};
virtual int length() {
return strlen(str);
};
const char* str;
};
class beta : alpha {
public:
beta(const char* s) : alpha(s + 1) { };
const char* render() {
return str + 1;
};
virtual const char* chop() {
return str + 2;
};
};
RAW-C>
C++-CLASS: alpha c++-root
C++-CLASS: beta alpha
CM-FUNCTION: alpha* new_alpha ( const-char* s )
return new alpha(s);
;
CM-FUNCTION: beta* new_beta ( const-char* s )
return new beta(s);
;
ALIAS: <alpha> new_alpha
ALIAS: <beta> new_beta
GENERIC: render ( obj -- obj )
GENERIC: chop ( obj -- obj )
GENERIC: length ( obj -- n )
C++-METHOD: alpha render const-char* render ( )
C++-METHOD: beta render const-char* render ( )
C++-VIRTUAL: alpha chop const-char* chop ( )
C++-VIRTUAL: beta chop const-char* chop ( )
C++-VIRTUAL: alpha length int length ( )
;C-LIBRARY
{ 1 1 } [ render_alpha ] must-infer-as
{ 1 1 } [ chop_beta ] must-infer-as
{ 1 1 } [ length_alpha ] must-infer-as
[ t ] [ "x" <alpha> alpha#? ] unit-test
[ t ] [ "x" <alpha> alpha? ] unit-test
[ t ] [ "x" <beta> alpha? ] unit-test
[ f ] [ "x" <beta> alpha#? ] unit-test
[ 5 ] [ "hello" <alpha> length ] unit-test
[ 4 ] [ "hello" <beta> length ] unit-test
[ "hello" ] [ "hello" <alpha> render ] unit-test
[ "llo" ] [ "hello" <beta> render ] unit-test
[ "ello" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying render ] unit-test
[ "hello" ] [ "hello" <alpha> chop ] unit-test
[ "lo" ] [ "hello" <beta> chop ] unit-test
[ "lo" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying chop ] unit-test

View File

@ -1,13 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.cxx alien.cxx.parser ;
IN: alien.cxx.syntax
SYNTAX: C++-CLASS:
parse-c++-class-definition define-c++-class ;
SYNTAX: C++-METHOD:
parse-c++-method-definition f define-c++-method ;
SYNTAX: C++-VIRTUAL:
parse-c++-method-definition t define-c++-method ;

View File

@ -1 +0,0 @@
Jeremy Hughes

View File

@ -1 +0,0 @@
Jeremy Hughes

View File

@ -1,78 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel strings words.symbol sequences ;
IN: alien.inline.compiler
HELP: C
{ $var-description "A symbol representing C source." } ;
HELP: C++
{ $var-description "A symbol representing C++ source." } ;
HELP: compile-to-library
{ $values
{ "lang" symbol } { "args" sequence } { "contents" string } { "name" string }
}
{ $description "Compiles and links " { $snippet "contents" } " into a shared library called " { $snippet "libname.suffix" }
"in " { $snippet "resource:alien-inline-libs" } ". " { $snippet "suffix" } " is OS specific. "
{ $snippet "args" } " is a sequence of arguments for the linking stage." }
{ $notes
{ $list
"C and C++ are the only supported languages."
{ "Source and object files are placed in " { $snippet "resource:temp" } "." } }
} ;
HELP: compiler
{ $values
{ "lang" symbol }
{ "str" string }
}
{ $description "Returns a compiler name based on OS and source language." }
{ $see-also compiler-descr } ;
HELP: compiler-descr
{ $values
{ "lang" symbol }
{ "descr" "a process description" }
}
{ $description "Returns a compiler process description based on OS and source language." }
{ $see-also compiler } ;
HELP: inline-library-file
{ $values
{ "name" string }
{ "path" "a pathname string" }
}
{ $description "Appends " { $snippet "name" } " to the " { $link inline-libs-directory } "." } ;
HELP: inline-libs-directory
{ $values
{ "path" "a pathname string" }
}
{ $description "The directory where libraries created using " { $snippet "alien.inline" } " are stored." } ;
HELP: library-path
{ $values
{ "str" string }
{ "path" "a pathname string" }
}
{ $description "Converts " { $snippet "name" } " into a full path to the corresponding inline library." } ;
HELP: library-suffix
{ $values
{ "str" string }
}
{ $description "The appropriate shared library suffix for the current OS." } ;
HELP: link-descr
{ $values
{ "lang" "a language" }
{ "descr" sequence }
}
{ $description "Returns part of a process description. OS dependent." } ;
ARTICLE: "alien.inline.compiler" "Inline C compiler"
{ $vocab-link "alien.inline.compiler" }
;
ABOUT: "alien.inline.compiler"

View File

@ -1,93 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators fry generalizations
io.encodings.ascii io.files io.files.temp io.launcher kernel
locals make sequences system vocabs.parser words io.directories
io.pathnames ;
IN: alien.inline.compiler
SYMBOL: C
SYMBOL: C++
: inline-libs-directory ( -- path )
"alien-inline-libs" resource-path dup make-directories ;
: inline-library-file ( name -- path )
inline-libs-directory prepend-path ;
: library-suffix ( -- str )
os {
{ [ dup macosx? ] [ drop ".dylib" ] }
{ [ dup unix? ] [ drop ".so" ] }
{ [ dup windows? ] [ drop ".dll" ] }
} cond ;
: library-path ( str -- path )
'[ "lib" % _ % library-suffix % ] "" make inline-library-file ;
HOOK: compiler os ( lang -- str )
M: word compiler
{
{ C [ "gcc" ] }
{ C++ [ "g++" ] }
} case ;
M: openbsd compiler
{
{ C [ "gcc" ] }
{ C++ [ "eg++" ] }
} case ;
M: windows compiler
{
{ C [ "gcc" ] }
{ C++ [ "g++" ] }
} case ;
HOOK: compiler-descr os ( lang -- descr )
M: word compiler-descr compiler 1array ;
M: macosx compiler-descr
call-next-method cpu x86.64?
[ { "-arch" "x86_64" } append ] when ;
HOOK: link-descr os ( lang -- descr )
M: word link-descr drop { "-shared" "-o" } ;
M: macosx link-descr
drop { "-g" "-prebind" "-dynamiclib" "-o" }
cpu x86.64? [ { "-arch" "x86_64" } prepend ] when ;
M: windows link-descr
{
{ C [ { "-mno-cygwin" "-shared" "-o" } ] }
{ C++ [ { "-lstdc++" "-mno-cygwin" "-shared" "-o" } ] }
} case ;
<PRIVATE
: src-suffix ( lang -- str )
{
{ C [ ".c" ] }
{ C++ [ ".cpp" ] }
} case ;
: link-command ( args in out lang -- descr )
[ 2array ] dip [ compiler 1array ] [ link-descr ] bi
append prepend prepend ;
:: compile-to-object ( lang contents name -- )
name ".o" append temp-file
contents name lang src-suffix append temp-file
[ ascii set-file-contents ] keep 2array
lang compiler-descr { "-fPIC" "-c" "-o" } append prepend
try-process ;
:: link-object ( lang args name -- )
args name [ library-path ]
[ ".o" append temp-file ] bi
lang link-command try-process ;
PRIVATE>
:: compile-to-library ( lang args contents name -- )
lang contents name compile-to-object
lang args name link-object ;

View File

@ -1,113 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel strings effects quotations ;
IN: alien.inline
<PRIVATE
: $binding-note ( x -- )
drop
{ "This word requires that certain variables are correctly bound. "
"Call " { $link POSTPONE: define-c-library } " to set them up." } print-element ;
PRIVATE>
HELP: compile-c-library
{ $description "Writes, compiles, and links code generated since last invocation of " { $link POSTPONE: define-c-library } ". "
"Also calls " { $snippet "add-library" } ". "
"This word does nothing if the shared library is younger than the factor source file." }
{ $notes $binding-note } ;
HELP: c-use-framework
{ $values
{ "str" string }
}
{ $description "OS X only. Adds " { $snippet "-framework name" } " to linker command." }
{ $notes $binding-note }
{ $see-also c-link-to c-link-to/use-framework } ;
HELP: define-c-function
{ $values
{ "function" "function name" } { "types" "a sequence of C types" } { "effect" effect } { "body" string }
}
{ $description "Defines a C function and a factor word which calls it." }
{ $notes
{ $list
{ "The number of " { $snippet "types" } " must match the " { $snippet "in" } " count of the " { $snippet "effect" } "." }
{ "There must be only one " { $snippet "out" } " element. It must be a legal C return type with dashes (-) instead of spaces." }
$binding-note
}
}
{ $see-also POSTPONE: define-c-function' } ;
HELP: define-c-function'
{ $values
{ "function" "function name" } { "effect" effect } { "body" string }
}
{ $description "Defines a C function and a factor word which calls it. See " { $link define-c-function } " for more information." }
{ $notes
{ $list
{ "Each effect element must be a legal C type with dashes (-) instead of spaces. "
"C argument names will be generated alphabetically, starting with " { $snippet "a" } "." }
$binding-note
}
}
{ $see-also define-c-function } ;
HELP: c-include
{ $values
{ "str" string }
}
{ $description "Appends an include line to the C library in scope." }
{ $notes $binding-note } ;
HELP: define-c-library
{ $values
{ "name" string }
}
{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " words can be used after this one." } ;
HELP: c-link-to
{ $values
{ "str" string }
}
{ $description "Adds " { $snippet "-lname" } " to linker command." }
{ $notes $binding-note }
{ $see-also c-use-framework c-link-to/use-framework } ;
HELP: c-link-to/use-framework
{ $values
{ "str" string }
}
{ $description "Equivalent to " { $link c-use-framework } " on OS X and " { $link c-link-to } " everywhere else." }
{ $notes $binding-note }
{ $see-also c-link-to c-use-framework } ;
HELP: define-c-struct
{ $values
{ "name" string } { "fields" "type/name pairs" }
}
{ $description "Defines a C struct and factor words which operate on it." }
{ $notes $binding-note } ;
HELP: define-c-typedef
{ $values
{ "old" "C type" } { "new" "C type" }
}
{ $description "Define C and factor typedefs." }
{ $notes $binding-note } ;
HELP: delete-inline-library
{ $values
{ "name" string }
}
{ $description "Delete the shared library file corresponding to " { $snippet "name" } "." }
{ $notes "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } ;
HELP: with-c-library
{ $values
{ "name" string } { "quot" quotation }
}
{ $description "Calls " { $link define-c-library } ", then the quotation, then " { $link compile-c-library } ", then sets all variables bound by " { $snippet "define-c-library" } " to " { $snippet "f" } "." } ;
HELP: raw-c
{ $values { "str" string } }
{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;

View File

@ -1,131 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.inline.compiler alien.inline.types
alien.libraries alien.parser arrays assocs effects fry
generalizations grouping io.directories io.files
io.files.info io.files.temp kernel lexer math math.order
math.ranges multiline namespaces sequences source-files
splitting strings system vocabs.loader vocabs.parser words
alien.c-types alien.structs make parser continuations ;
IN: alien.inline
SYMBOL: c-library
SYMBOL: library-is-c++
SYMBOL: linker-args
SYMBOL: c-strings
<PRIVATE
: cleanup-variables ( -- )
{ c-library library-is-c++ linker-args c-strings }
[ off ] each ;
: arg-list ( types -- params )
CHAR: a swap length CHAR: a + [a,b]
[ 1string ] map ;
: compile-library? ( -- ? )
c-library get library-path dup exists? [
file get [
path>>
[ file-info modified>> ] bi@ <=> +lt+ =
] [ drop t ] if*
] [ drop t ] if ;
: compile-library ( -- )
library-is-c++ get [ C++ ] [ C ] if
linker-args get
c-strings get "\n" join
c-library get compile-to-library ;
: c-library-name ( name -- name' )
[ current-vocab name>> % "_" % % ] "" make ;
PRIVATE>
: parse-arglist ( parameters return -- types effect )
[ 2 group unzip [ "," ?tail drop ] map ]
[ [ { } ] [ 1array ] if-void ]
bi* <effect> ;
: append-function-body ( prototype-str body -- str )
[ swap % " {\n" % % "\n}\n" % ] "" make ;
: function-types-effect ( -- function types effect )
scan scan swap ")" parse-tokens
[ "(" subseq? ] reject swap parse-arglist ;
: prototype-string ( function types effect -- str )
[ [ cify-type ] map ] dip
types-effect>params-return cify-type -rot
[ " " join ] map ", " join
"(" prepend ")" append 3array " " join
library-is-c++ get [ "extern \"C\" " prepend ] when ;
: prototype-string' ( function types return -- str )
[ dup arg-list ] <effect> prototype-string ;
: factor-function ( function types effect -- word quot effect )
annotate-effect [ c-library get ] 3dip
[ [ factorize-type ] map ] dip
types-effect>params-return factorize-type -roll
concat make-function ;
: define-c-library ( name -- )
c-library-name [ c-library set ] [ "c-library" set ] bi
V{ } clone c-strings set
V{ } clone linker-args set ;
: compile-c-library ( -- )
compile-library? [ compile-library ] when
c-library get dup library-path cdecl add-library ;
: define-c-function ( function types effect body -- )
[
[ factor-function define-declared ]
[ prototype-string ] 3bi
] dip append-function-body c-strings get push ;
: define-c-function' ( function effect body -- )
[
[ in>> ] keep
[ factor-function define-declared ]
[ out>> prototype-string' ] 3bi
] dip append-function-body c-strings get push ;
: c-link-to ( str -- )
"-l" prepend linker-args get push ;
: c-use-framework ( str -- )
"-framework" swap linker-args get '[ _ push ] bi@ ;
: c-link-to/use-framework ( str -- )
os macosx? [ c-use-framework ] [ c-link-to ] if ;
: c-include ( str -- )
"#include " prepend c-strings get push ;
: define-c-typedef ( old new -- )
[ typedef ] [
[ swap "typedef " % % " " % % ";" % ]
"" make c-strings get push
] 2bi ;
: define-c-struct ( name fields -- )
[ current-vocab swap define-struct ] [
over
[
"typedef struct " % "_" % % " {\n" %
[ first2 swap % " " % % ";\n" % ] each
"} " % % ";\n" %
] "" make c-strings get push
] 2bi ;
: delete-inline-library ( name -- )
c-library-name [ remove-library ]
[ library-path dup exists? [ delete-file ] [ drop ] if ] bi ;
: with-c-library ( name quot -- )
[ [ define-c-library ] dip call compile-c-library ]
[ cleanup-variables ] [ ] cleanup ; inline
: raw-c ( str -- )
[ "\n" % % "\n" % ] "" make c-strings get push ;

View File

@ -1 +0,0 @@
Jeremy Hughes

View File

@ -1,100 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax alien.inline ;
IN: alien.inline.syntax
HELP: ;C-LIBRARY
{ $syntax ";C-LIBRARY" }
{ $description "Writes, compiles, and links code generated since previous invocation of " { $link POSTPONE: C-LIBRARY: } "." }
{ $see-also POSTPONE: compile-c-library } ;
HELP: C-FRAMEWORK:
{ $syntax "C-FRAMEWORK: name" }
{ $description "OS X only. Link to named framework. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
{ $see-also POSTPONE: c-use-framework } ;
HELP: C-FUNCTION:
{ $syntax "C-FUNCTION: return name ( args ... )\nbody\n;" }
{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." }
{ $examples
{ $example
"USING: alien.inline.syntax prettyprint ;"
"IN: cmath.ffi"
""
"C-LIBRARY: cmathlib"
""
"C-FUNCTION: int add ( int a, int b )"
" return a + b;"
";"
""
";C-LIBRARY"
""
"1 2 add ."
"3" }
}
{ $see-also POSTPONE: define-c-function } ;
HELP: C-INCLUDE:
{ $syntax "C-INCLUDE: name" }
{ $description "Appends an include line to the C library in scope." }
{ $see-also POSTPONE: c-include } ;
HELP: C-LIBRARY:
{ $syntax "C-LIBRARY: name" }
{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." }
{ $examples
{ $example
"USING: alien.inline.syntax ;"
"IN: rectangle.ffi"
""
"C-LIBRARY: rectlib"
""
"C-STRUCTURE: rectangle { \"int\" \"width\" } { \"int\" \"height\" } ;"
""
"C-FUNCTION: int area ( rectangle c )"
" return c.width * c.height;"
";"
""
";C-LIBRARY"
"" }
}
{ $see-also POSTPONE: define-c-library } ;
HELP: C-LINK/FRAMEWORK:
{ $syntax "C-LINK/FRAMEWORK: name" }
{ $description "Equivalent to " { $link POSTPONE: C-FRAMEWORK: } " on OS X and " { $link POSTPONE: C-LINK: } " everywhere else." }
{ $see-also POSTPONE: c-link-to/use-framework } ;
HELP: C-LINK:
{ $syntax "C-LINK: name" }
{ $description "Link to named library. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
{ $see-also POSTPONE: c-link-to } ;
HELP: C-STRUCTURE:
{ $syntax "C-STRUCTURE: name pairs ... ;" }
{ $description "Like " { $snippet "C-STRUCT:" } " but also generates equivalent C code."}
{ $see-also POSTPONE: define-c-struct } ;
HELP: C-TYPEDEF:
{ $syntax "C-TYPEDEF: old new" }
{ $description "Like " { $snippet "TYPEDEF:" } " but generates a C typedef statement too." }
{ $see-also POSTPONE: define-c-typedef } ;
HELP: COMPILE-AS-C++
{ $syntax "COMPILE-AS-C++" }
{ $description "Insert this word anywhere between " { $link POSTPONE: C-LIBRARY: } " and " { $link POSTPONE: ;C-LIBRARY } " and the generated code will be treated as C++ with " { $snippet "extern \"C\"" } " prepended to each function prototype." } ;
HELP: DELETE-C-LIBRARY:
{ $syntax "DELETE-C-LIBRARY: name" }
{ $description "Deletes the shared library file corresponding to " { $snippet "name" } " . " }
{ $notes
{ $list
{ "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " }
"This word is mainly useful for unit tests."
}
}
{ $see-also POSTPONE: delete-inline-library } ;
HELP: <RAW-C
{ $syntax "<RAW-C code RAW-C>" }
{ $description "Insert a (multiline) string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;

View File

@ -1,72 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.inline alien.inline.syntax io.directories io.files
kernel namespaces tools.test alien.c-types alien.data alien.structs ;
IN: alien.inline.syntax.tests
DELETE-C-LIBRARY: test
C-LIBRARY: test
C-FUNCTION: const-int add ( int a, int b )
return a + b;
;
C-TYPEDEF: double bigfloat
C-FUNCTION: bigfloat smaller ( bigfloat a )
return a / 10;
;
C-STRUCTURE: rectangle
{ "int" "width" }
{ "int" "height" } ;
C-FUNCTION: int area ( rectangle c )
return c.width * c.height;
;
;C-LIBRARY
{ 2 1 } [ add ] must-infer-as
[ 5 ] [ 2 3 add ] unit-test
[ t ] [ "double" "bigfloat" [ resolve-typedef ] same? ] unit-test
{ 1 1 } [ smaller ] must-infer-as
[ 1.0 ] [ 10 smaller ] unit-test
[ t ] [ "rectangle" resolve-typedef struct-type? ] unit-test
{ 1 1 } [ area ] must-infer-as
[ 20 ] [
"rectangle" <c-object>
4 over set-rectangle-width
5 over set-rectangle-height
area
] unit-test
DELETE-C-LIBRARY: cpplib
C-LIBRARY: cpplib
COMPILE-AS-C++
C-INCLUDE: <string>
C-FUNCTION: const-char* hello ( )
std::string s("hello world");
return s.c_str();
;
;C-LIBRARY
{ 0 1 } [ hello ] must-infer-as
[ "hello world" ] [ hello ] unit-test
DELETE-C-LIBRARY: compile-error
C-LIBRARY: compile-error
C-FUNCTION: char* breakme ( )
return not a string;
;
<< [ compile-c-library ] must-fail >>

View File

@ -1,31 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.inline lexer multiline namespaces parser ;
IN: alien.inline.syntax
SYNTAX: C-LIBRARY: scan define-c-library ;
SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
SYNTAX: C-LINK: scan c-link-to ;
SYNTAX: C-FRAMEWORK: scan c-use-framework ;
SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ;
SYNTAX: C-INCLUDE: scan c-include ;
SYNTAX: C-FUNCTION:
function-types-effect parse-here define-c-function ;
SYNTAX: C-TYPEDEF: scan scan define-c-typedef ;
SYNTAX: C-STRUCTURE:
scan parse-definition define-c-struct ;
SYNTAX: ;C-LIBRARY compile-c-library ;
SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ;
SYNTAX: <RAW-C "RAW-C>" parse-multiline-string raw-c ;

View File

@ -1 +0,0 @@
Jeremy Hughes

View File

@ -1,102 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types assocs combinators.short-circuit
continuations effects fry kernel math memoize sequences
splitting strings peg.ebnf make words ;
IN: alien.inline.types
: cify-type ( str -- str' )
dup word? [ name>> ] when
H{ { CHAR: - CHAR: space } } substitute ;
: factorize-type ( str -- str' )
cify-type
"const " ?head drop
"unsigned " ?head [ "u" prepend ] when
"long " ?head [ "long" prepend ] when
" const" ?tail drop ;
: const-pointer? ( str -- ? )
cify-type { [ " const" tail? ] [ "&" tail? ] } 1|| ;
: pointer-to-const? ( str -- ? )
cify-type "const " head? ;
: template-class? ( str -- ? )
[ CHAR: < = ] any? ;
MEMO: resolved-primitives ( -- seq )
primitive-types [ resolve-typedef ] map ;
: primitive-type? ( type -- ? )
[
factorize-type resolve-typedef [ resolved-primitives ] dip
'[ _ = ] any?
] [ 2drop f ] recover ;
: pointer? ( type -- ? )
factorize-type [ "*" tail? ] [ "&" tail? ] bi or ;
: type-sans-pointer ( type -- type' )
factorize-type [ '[ _ = ] "*&" swap any? ] trim-tail ;
: pointer-to-primitive? ( type -- ? )
factorize-type
{ [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ;
: pointer-to-non-const-primitive? ( str -- ? )
{
[ pointer-to-const? not ]
[ factorize-type pointer-to-primitive? ]
} 1&& ;
: types-effect>params-return ( types effect -- params return )
[ in>> zip ]
[ nip out>> dup length 0 > [ first ] [ drop "void" ] if ]
2bi ;
: annotate-effect ( types effect -- types effect' )
[ in>> ] [ out>> ] bi [
zip
[ over pointer-to-primitive? [ ">" prepend ] when ]
assoc-map unzip
] dip <effect> ;
TUPLE: c++-type name params ptr ;
C: <c++-type> c++-type
EBNF: (parse-c++-type)
dig = [0-9]
alpha = [a-zA-Z]
alphanum = [1-9a-zA-Z]
name = [_a-zA-Z] [_a-zA-Z1-9:]* => [[ first2 swap prefix >string ]]
ptr = [*&] => [[ empty? not ]]
param = "," " "* type " "* => [[ third ]]
params = "<" " "* type " "* param* ">" => [[ [ 4 swap nth ] [ third ] bi prefix ]]
type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 <c++-type> ]]
;EBNF
: parse-c++-type ( str -- c++-type )
factorize-type (parse-c++-type) ;
DEFER: c++-type>string
: params>string ( params -- str )
[ "<" % [ c++-type>string ] map "," join % ">" % ] "" make ;
: c++-type>string ( c++-type -- str )
[
[ name>> % ]
[ params>> [ params>string % ] when* ]
[ ptr>> [ "*" % ] when ]
tri
] "" make ;
GENERIC: c++-type ( obj -- c++-type/f )
M: object c++-type drop f ;
M: c++-type c-type ;

View File

@ -1 +0,0 @@
Jeremy Hughes

View File

@ -1,638 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations sequences
strings alien alien.c-types alien.data math byte-arrays ;
IN: alien.marshall
<PRIVATE
: $memory-note ( arg -- )
drop "This word returns a pointer to unmanaged memory."
print-element ;
: $c-ptr-note ( arg -- )
drop "Does nothing if its argument is a non false c-ptr."
print-element ;
: $see-article ( arg -- )
drop { "See " { $vocab-link "alien.inline" } "." }
print-element ;
PRIVATE>
HELP: ?malloc-byte-array
{ $values
{ "c-type" c-type }
{ "alien" alien }
}
{ $description "Does nothing if input is an alien, otherwise assumes it is a byte array and calls "
{ $snippet "malloc-byte-array" } "."
}
{ $notes $memory-note } ;
HELP: alien-wrapper
{ $var-description "For wrapping C pointers in a structure factor can dispatch on." } ;
HELP: unmarshall-cast
{ $values
{ "alien-wrapper" alien-wrapper }
{ "alien-wrapper'" alien-wrapper }
}
{ $description "Called immediately after unmarshalling. Useful for automatically casting to subtypes." } ;
HELP: marshall-bool
{ $values
{ "?" "a generalized boolean" }
{ "n" "0 or 1" }
}
{ $description "Marshalls objects to bool." }
{ $notes "Will treat " { $snippet "0" } " as " { $snippet "t" } "." } ;
HELP: marshall-bool*
{ $values
{ "?/seq" "t/f or sequence" }
{ "alien" alien }
}
{ $description "When the argument is a sequence, returns a pointer to an array of bool, "
"otherwise returns a pointer to a single bool value."
}
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-bool**
{ $values
{ "seq" sequence }
{ "alien" alien }
}
{ $description "Takes a one or two dimensional array of generalized booleans "
"and returns a pointer to the equivalent C structure."
}
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-primitive
{ $values
{ "n" number }
{ "n" number }
}
{ $description "Marshall numbers to C primitives."
$nl
"Factor marshalls numbers to primitives for FFI calls, so all "
"this word does is convert " { $snippet "t" } " to " { $snippet "1" }
", " { $snippet "f" } " to " { $snippet "0" } ", and lets anything else "
"pass through untouched."
} ;
HELP: marshall-char*
{ $values
{ "n/seq" "number or sequence" }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-char**
{ $values
{ "seq" sequence }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-char**-or-strings
{ $values
{ "seq" "a sequence of strings" }
{ "alien" alien }
}
{ $description "Marshalls an array of strings or characters to an array of C strings." }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-char*-or-string
{ $values
{ "n/string" "a number or string" }
{ "alien" alien }
}
{ $description "Marshalls a string to a C string or a number to a pointer to " { $snippet "char" } "." }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-double*
{ $values
{ "n/seq" "a number or sequence" }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-double**
{ $values
{ "seq" sequence }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-float*
{ $values
{ "n/seq" "a number or sequence" }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-float**
{ $values
{ "seq" sequence }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-int*
{ $values
{ "n/seq" "a number or sequence" }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-int**
{ $values
{ "seq" sequence }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-long*
{ $values
{ "n/seq" "a number or sequence" }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-long**
{ $values
{ "seq" sequence }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-longlong*
{ $values
{ "n/seq" "a number or sequence" }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-longlong**
{ $values
{ "seq" sequence }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-non-pointer
{ $values
{ "alien-wrapper/byte-array" "an alien-wrapper or byte-array" }
{ "byte-array" byte-array }
}
{ $description "Converts argument to a byte array." }
{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
HELP: marshall-pointer
{ $values
{ "obj" object }
{ "alien" alien }
}
{ $description "Converts argument to a C pointer." }
{ $notes "Can marshall the following types: " { $snippet "alien, f, byte-array, alien-wrapper, struct-array" } "." } ;
HELP: marshall-short*
{ $values
{ "n/seq" "a number or sequence" }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-short**
{ $values
{ "seq" sequence }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-uchar*
{ $values
{ "n/seq" "a number or sequence" }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-uchar**
{ $values
{ "seq" sequence }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-uint*
{ $values
{ "n/seq" "a number or sequence" }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-uint**
{ $values
{ "seq" sequence }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-ulong*
{ $values
{ "n/seq" "a number or sequence" }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-ulong**
{ $values
{ "seq" sequence }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-ulonglong*
{ $values
{ "n/seq" "a number or sequence" }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-ulonglong**
{ $values
{ "seq" sequence }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-ushort*
{ $values
{ "n/seq" "a number or sequence" }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-ushort**
{ $values
{ "seq" sequence }
{ "alien" alien }
}
{ $description $see-article }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshall-void**
{ $values
{ "seq" sequence }
{ "alien" alien }
}
{ $description "Marshalls a sequence of objects to an array of pointers to void." }
{ $notes { $list $c-ptr-note $memory-note } } ;
HELP: marshaller
{ $values
{ "type" "a C type string" }
{ "quot" quotation }
}
{ $description "Given a C type, returns a quotation that will marshall its argument to that type." } ;
HELP: out-arg-unmarshaller
{ $values
{ "type" "a C type string" }
{ "quot" quotation }
}
{ $description "Like " { $link unmarshaller } " but returns an empty quotation "
"for all types except pointers to non-const primitives."
} ;
HELP: class-unmarshaller
{ $values
{ "type" " a C type string" }
{ "quot/f" quotation }
}
{ $description "If in the vocab in which this word is called, there is a subclass of " { $link alien-wrapper }
" named after the type argument, " { $snippet "pointer-unmarshaller" } " will return a quotation which "
"wraps its argument in an instance of that subclass. In any other case it returns an empty quotation."
}
{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
HELP: primitive-marshaller
{ $values
{ "type" "a C type string" }
{ "quot/f" "a quotation or f" }
}
{ $description "Returns a quotation to marshall objects to the argument type." }
{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
HELP: primitive-unmarshaller
{ $values
{ "type" "a C type string" }
{ "quot/f" "a quotation or f" }
}
{ $description "Returns a quotation to unmarshall objects from the argument type." }
{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
HELP: struct-field-unmarshaller
{ $values
{ "type" "a C type string" }
{ "quot" quotation }
}
{ $description "Like " { $link unmarshaller } " but returns a quotation that "
"does not call " { $snippet "free" } " on its argument."
}
{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
HELP: struct-primitive-unmarshaller
{ $values
{ "type" "a C type string" }
{ "quot/f" "a quotation or f" }
}
{ $description "Like " { $link primitive-unmarshaller } " but returns a quotation that "
"does not call " { $snippet "free" } " on its argument." }
{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
HELP: struct-unmarshaller
{ $values
{ "type" "a C type string" }
{ "quot/f" quotation }
}
{ $description "Returns a quotation which wraps its argument in the subclass of "
{ $link struct-wrapper } " which matches the " { $snippet "type" } " arg."
}
{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
HELP: struct-wrapper
{ $var-description "For wrapping C structs in a structure factor can dispatch on." } ;
HELP: unmarshall-bool
{ $values
{ "n" number }
{ "?" boolean }
}
{ $description "Unmarshalls a number to a boolean." } ;
HELP: unmarshall-bool*
{ $values
{ "alien" alien }
{ "?" boolean }
}
{ $description "Unmarshalls a C pointer to a boolean." } ;
HELP: unmarshall-bool*-free
{ $values
{ "alien" alien }
{ "?" boolean }
}
{ $description "Unmarshalls a C pointer to a boolean and frees the pointer." } ;
HELP: unmarshall-char*
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-char*-free
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-char*-to-string
{ $values
{ "alien" alien }
{ "string" string }
}
{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string." } ;
HELP: unmarshall-char*-to-string-free
{ $values
{ "alien" alien }
{ "string" string }
}
{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string and frees the pointer." } ;
HELP: unmarshall-double*
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-double*-free
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-float*
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-float*-free
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-int*
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-int*-free
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-long*
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-long*-free
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-longlong*
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-longlong*-free
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-short*
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-short*-free
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-uchar*
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-uchar*-free
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-uint*
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-uint*-free
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-ulong*
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-ulong*-free
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-ulonglong*
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-ulonglong*-free
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-ushort*
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshall-ushort*-free
{ $values
{ "alien" alien }
{ "n" number }
}
{ $description $see-article } ;
HELP: unmarshaller
{ $values
{ "type" "a C type string" }
{ "quot" quotation }
}
{ $description "Given a C type, returns a quotation that will unmarshall values of that type." } ;
ARTICLE: "alien.marshall" "C marshalling"
{ $vocab-link "alien.marshall" } " provides alien wrappers and marshalling words for the "
"automatic marshalling and unmarshalling of C function arguments, return values, and output parameters."
{ $subheading "Important words" }
"Wrap an alien:" { $subsections alien-wrapper }
"Wrap a struct:" { $subsections struct-wrapper }
"Get the marshaller for a C type:" { $subsections marshaller }
"Get the unmarshaller for a C type:" { $subsections unmarshaller }
"Get the unmarshaller for an output parameter:" { $subsections out-arg-unmarshaller }
"Get the unmarshaller for a struct field:" { $subsections struct-field-unmarshaller }
$nl
"Other marshalling and unmarshalling words in this vocabulary are not intended to be "
"invoked directly."
$nl
"Most marshalling words allow non false c-ptrs to pass through unchanged."
{ $subheading "Primitive marshallers" }
{ $subsections marshall-primitive } "for marshalling primitive values."
{ $subsections marshall-int* }
"marshalls a number or sequence of numbers. If argument is a sequence, returns a pointer "
"to a C array, otherwise returns a pointer to a single value."
{ $subsections marshall-int** }
"marshalls a 1D or 2D array of numbers. Returns an array of pointers to arrays."
{ $subheading "Primitive unmarshallers" }
{ $snippet "unmarshall-<prim>*" } " and " { $snippet "unmarshall-<prim>*-free" }
" for all values of " { $snippet "<prim>" } " in " { $link primitive-types } "."
{ $subsections unmarshall-int* }
"unmarshalls a pointer to primitive. Returns a number. "
"Assumes the pointer is not an array (if it is, only the first value is returned). "
"C functions that return arrays are not handled correctly by " { $snippet "alien.marshall" }
" and must be unmarshalled by hand."
{ $subsections unmarshall-int*-free }
"unmarshalls a pointer to primitive, and then frees the pointer."
$nl
"Primitive values require no unmarshalling. The factor FFI already does this."
;
ABOUT: "alien.marshall"

View File

@ -1,326 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.inline.types
alien.marshall.private alien.strings byte-arrays classes
combinators combinators.short-circuit destructors fry
io.encodings.utf8 kernel libc sequences alien.data
specialized-arrays strings unix.utilities vocabs.parser
words libc.private locals generalizations math ;
FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: bool
SPECIALIZED-ARRAY: char
SPECIALIZED-ARRAY: double
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: long
SPECIALIZED-ARRAY: longlong
SPECIALIZED-ARRAY: short
SPECIALIZED-ARRAY: uchar
SPECIALIZED-ARRAY: uint
SPECIALIZED-ARRAY: ulong
SPECIALIZED-ARRAY: ulonglong
SPECIALIZED-ARRAY: ushort
SPECIALIZED-ARRAY: void*
IN: alien.marshall
<< primitive-types [ [ void* = ] [ bool = ] bi or not ]
filter [ define-primitive-marshallers ] each >>
TUPLE: alien-wrapper { underlying alien } ;
TUPLE: struct-wrapper < alien-wrapper disposed ;
TUPLE: class-wrapper < alien-wrapper disposed ;
MIXIN: c++-root
GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
M: alien-wrapper unmarshall-cast ;
M: struct-wrapper unmarshall-cast ;
M: struct-wrapper dispose* underlying>> free ;
M: class-wrapper c++-type class name>> parse-c++-type ;
: marshall-pointer ( obj -- alien )
{
{ [ dup alien? ] [ ] }
{ [ dup not ] [ ] }
{ [ dup byte-array? ] [ malloc-byte-array ] }
{ [ dup alien-wrapper? ] [ underlying>> ] }
} cond ;
: marshall-primitive ( n -- n )
[ bool>arg ] ptr-pass-through ;
ALIAS: marshall-void* marshall-pointer
: marshall-void** ( seq -- alien )
[ marshall-void* ] void*-array{ } map-as malloc-underlying ;
: (marshall-char*-or-string) ( n/string -- alien )
dup string?
[ utf8 string>alien malloc-byte-array ]
[ (marshall-char*) ] if ;
: marshall-char*-or-string ( n/string -- alien )
[ (marshall-char*-or-string) ] ptr-pass-through ;
: (marshall-char**-or-strings) ( seq -- alien )
[ marshall-char*-or-string ] void*-array{ } map-as
malloc-underlying ;
: marshall-char**-or-strings ( seq -- alien )
[ (marshall-char**-or-strings) ] ptr-pass-through ;
: marshall-bool ( ? -- n )
>boolean [ 1 ] [ 0 ] if ;
: (marshall-bool*) ( ?/seq -- alien )
[ marshall-bool <bool> malloc-byte-array ]
[ >bool-array malloc-underlying ]
marshall-x* ;
: marshall-bool* ( ?/seq -- alien )
[ (marshall-bool*) ] ptr-pass-through ;
: (marshall-bool**) ( seq -- alien )
[ marshall-bool* ] map >void*-array malloc-underlying ;
: marshall-bool** ( seq -- alien )
[ (marshall-bool**) ] ptr-pass-through ;
: unmarshall-bool ( n -- ? )
0 = not ;
: unmarshall-bool* ( alien -- ? )
*bool unmarshall-bool ;
: unmarshall-bool*-free ( alien -- ? )
[ *bool unmarshall-bool ] keep add-malloc free ;
: primitive-marshaller ( type -- quot/f )
{
{ "bool" [ [ ] ] }
{ "boolean" [ [ marshall-bool ] ] }
{ "char" [ [ marshall-primitive ] ] }
{ "uchar" [ [ marshall-primitive ] ] }
{ "short" [ [ marshall-primitive ] ] }
{ "ushort" [ [ marshall-primitive ] ] }
{ "int" [ [ marshall-primitive ] ] }
{ "uint" [ [ marshall-primitive ] ] }
{ "long" [ [ marshall-primitive ] ] }
{ "ulong" [ [ marshall-primitive ] ] }
{ "long" [ [ marshall-primitive ] ] }
{ "ulong" [ [ marshall-primitive ] ] }
{ "float" [ [ marshall-primitive ] ] }
{ "double" [ [ marshall-primitive ] ] }
{ "bool*" [ [ marshall-bool* ] ] }
{ "boolean*" [ [ marshall-bool* ] ] }
{ "char*" [ [ marshall-char*-or-string ] ] }
{ "uchar*" [ [ marshall-uchar* ] ] }
{ "short*" [ [ marshall-short* ] ] }
{ "ushort*" [ [ marshall-ushort* ] ] }
{ "int*" [ [ marshall-int* ] ] }
{ "uint*" [ [ marshall-uint* ] ] }
{ "long*" [ [ marshall-long* ] ] }
{ "ulong*" [ [ marshall-ulong* ] ] }
{ "longlong*" [ [ marshall-longlong* ] ] }
{ "ulonglong*" [ [ marshall-ulonglong* ] ] }
{ "float*" [ [ marshall-float* ] ] }
{ "double*" [ [ marshall-double* ] ] }
{ "bool&" [ [ marshall-bool* ] ] }
{ "boolean&" [ [ marshall-bool* ] ] }
{ "char&" [ [ marshall-char* ] ] }
{ "uchar&" [ [ marshall-uchar* ] ] }
{ "short&" [ [ marshall-short* ] ] }
{ "ushort&" [ [ marshall-ushort* ] ] }
{ "int&" [ [ marshall-int* ] ] }
{ "uint&" [ [ marshall-uint* ] ] }
{ "long&" [ [ marshall-long* ] ] }
{ "ulong&" [ [ marshall-ulong* ] ] }
{ "longlong&" [ [ marshall-longlong* ] ] }
{ "ulonglong&" [ [ marshall-ulonglong* ] ] }
{ "float&" [ [ marshall-float* ] ] }
{ "double&" [ [ marshall-double* ] ] }
{ "void*" [ [ marshall-void* ] ] }
{ "bool**" [ [ marshall-bool** ] ] }
{ "boolean**" [ [ marshall-bool** ] ] }
{ "char**" [ [ marshall-char**-or-strings ] ] }
{ "uchar**" [ [ marshall-uchar** ] ] }
{ "short**" [ [ marshall-short** ] ] }
{ "ushort**" [ [ marshall-ushort** ] ] }
{ "int**" [ [ marshall-int** ] ] }
{ "uint**" [ [ marshall-uint** ] ] }
{ "long**" [ [ marshall-long** ] ] }
{ "ulong**" [ [ marshall-ulong** ] ] }
{ "longlong**" [ [ marshall-longlong** ] ] }
{ "ulonglong**" [ [ marshall-ulonglong** ] ] }
{ "float**" [ [ marshall-float** ] ] }
{ "double**" [ [ marshall-double** ] ] }
{ "void**" [ [ marshall-void** ] ] }
[ drop f ]
} case ;
: marshall-non-pointer ( alien-wrapper/byte-array -- byte-array )
{
{ [ dup byte-array? ] [ ] }
{ [ dup alien-wrapper? ]
[ [ underlying>> ] [ class name>> heap-size ] bi
memory>byte-array ] }
} cond ;
: marshaller ( type -- quot )
factorize-type dup primitive-marshaller [ nip ] [
pointer?
[ [ marshall-pointer ] ]
[ [ marshall-non-pointer ] ] if
] if* ;
: unmarshall-char*-to-string ( alien -- string )
utf8 alien>string ;
: unmarshall-char*-to-string-free ( alien -- string )
[ unmarshall-char*-to-string ] keep add-malloc free ;
: primitive-unmarshaller ( type -- quot/f )
{
{ "bool" [ [ ] ] }
{ "boolean" [ [ unmarshall-bool ] ] }
{ "char" [ [ ] ] }
{ "uchar" [ [ ] ] }
{ "short" [ [ ] ] }
{ "ushort" [ [ ] ] }
{ "int" [ [ ] ] }
{ "uint" [ [ ] ] }
{ "long" [ [ ] ] }
{ "ulong" [ [ ] ] }
{ "longlong" [ [ ] ] }
{ "ulonglong" [ [ ] ] }
{ "float" [ [ ] ] }
{ "double" [ [ ] ] }
{ "bool*" [ [ unmarshall-bool*-free ] ] }
{ "boolean*" [ [ unmarshall-bool*-free ] ] }
{ "char*" [ [ ] ] }
{ "uchar*" [ [ unmarshall-uchar*-free ] ] }
{ "short*" [ [ unmarshall-short*-free ] ] }
{ "ushort*" [ [ unmarshall-ushort*-free ] ] }
{ "int*" [ [ unmarshall-int*-free ] ] }
{ "uint*" [ [ unmarshall-uint*-free ] ] }
{ "long*" [ [ unmarshall-long*-free ] ] }
{ "ulong*" [ [ unmarshall-ulong*-free ] ] }
{ "longlong*" [ [ unmarshall-long*-free ] ] }
{ "ulonglong*" [ [ unmarshall-ulong*-free ] ] }
{ "float*" [ [ unmarshall-float*-free ] ] }
{ "double*" [ [ unmarshall-double*-free ] ] }
{ "bool&" [ [ unmarshall-bool*-free ] ] }
{ "boolean&" [ [ unmarshall-bool*-free ] ] }
{ "char&" [ [ ] ] }
{ "uchar&" [ [ unmarshall-uchar*-free ] ] }
{ "short&" [ [ unmarshall-short*-free ] ] }
{ "ushort&" [ [ unmarshall-ushort*-free ] ] }
{ "int&" [ [ unmarshall-int*-free ] ] }
{ "uint&" [ [ unmarshall-uint*-free ] ] }
{ "long&" [ [ unmarshall-long*-free ] ] }
{ "ulong&" [ [ unmarshall-ulong*-free ] ] }
{ "longlong&" [ [ unmarshall-longlong*-free ] ] }
{ "ulonglong&" [ [ unmarshall-ulonglong*-free ] ] }
{ "float&" [ [ unmarshall-float*-free ] ] }
{ "double&" [ [ unmarshall-double*-free ] ] }
[ drop f ]
} case ;
: struct-primitive-unmarshaller ( type -- quot/f )
{
{ "bool" [ [ unmarshall-bool ] ] }
{ "boolean" [ [ unmarshall-bool ] ] }
{ "char" [ [ ] ] }
{ "uchar" [ [ ] ] }
{ "short" [ [ ] ] }
{ "ushort" [ [ ] ] }
{ "int" [ [ ] ] }
{ "uint" [ [ ] ] }
{ "long" [ [ ] ] }
{ "ulong" [ [ ] ] }
{ "longlong" [ [ ] ] }
{ "ulonglong" [ [ ] ] }
{ "float" [ [ ] ] }
{ "double" [ [ ] ] }
{ "bool*" [ [ unmarshall-bool* ] ] }
{ "boolean*" [ [ unmarshall-bool* ] ] }
{ "char*" [ [ ] ] }
{ "uchar*" [ [ unmarshall-uchar* ] ] }
{ "short*" [ [ unmarshall-short* ] ] }
{ "ushort*" [ [ unmarshall-ushort* ] ] }
{ "int*" [ [ unmarshall-int* ] ] }
{ "uint*" [ [ unmarshall-uint* ] ] }
{ "long*" [ [ unmarshall-long* ] ] }
{ "ulong*" [ [ unmarshall-ulong* ] ] }
{ "longlong*" [ [ unmarshall-long* ] ] }
{ "ulonglong*" [ [ unmarshall-ulong* ] ] }
{ "float*" [ [ unmarshall-float* ] ] }
{ "double*" [ [ unmarshall-double* ] ] }
{ "bool&" [ [ unmarshall-bool* ] ] }
{ "boolean&" [ [ unmarshall-bool* ] ] }
{ "char&" [ [ unmarshall-char* ] ] }
{ "uchar&" [ [ unmarshall-uchar* ] ] }
{ "short&" [ [ unmarshall-short* ] ] }
{ "ushort&" [ [ unmarshall-ushort* ] ] }
{ "int&" [ [ unmarshall-int* ] ] }
{ "uint&" [ [ unmarshall-uint* ] ] }
{ "long&" [ [ unmarshall-long* ] ] }
{ "ulong&" [ [ unmarshall-ulong* ] ] }
{ "longlong&" [ [ unmarshall-longlong* ] ] }
{ "ulonglong&" [ [ unmarshall-ulonglong* ] ] }
{ "float&" [ [ unmarshall-float* ] ] }
{ "double&" [ [ unmarshall-double* ] ] }
[ drop f ]
} case ;
: ?malloc-byte-array ( c-type -- alien )
dup alien? [ malloc-byte-array ] unless ;
:: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
type type-quot call current-vocab lookup [
dup superclasses superclass swap member?
[ def call ] [ drop clean call f ] if
] [ clean call f ] if* ; inline
: struct-unmarshaller ( type -- quot/f )
[ ] \ struct-wrapper
[ '[ ?malloc-byte-array _ new swap >>underlying ] ]
[ ]
x-unmarshaller ;
: class-unmarshaller ( type -- quot/f )
[ type-sans-pointer "#" append ] \ class-wrapper
[ '[ _ new swap >>underlying ] ]
[ ]
x-unmarshaller ;
: non-primitive-unmarshaller ( type -- quot/f )
{
{ [ dup pointer? ] [ class-unmarshaller ] }
[ struct-unmarshaller ]
} cond ;
: unmarshaller ( type -- quot )
factorize-type {
[ primitive-unmarshaller ]
[ non-primitive-unmarshaller ]
[ drop [ ] ]
} 1|| ;
: struct-field-unmarshaller ( type -- quot )
factorize-type {
[ struct-primitive-unmarshaller ]
[ non-primitive-unmarshaller ]
[ drop [ ] ]
} 1|| ;
: out-arg-unmarshaller ( type -- quot )
dup pointer-to-non-const-primitive?
[ factorize-type primitive-unmarshaller ]
[ drop [ drop ] ] if ;

View File

@ -1 +0,0 @@
Jeremy Hughes

View File

@ -1,61 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.inline arrays
combinators fry functors kernel lexer libc macros math
sequences specialized-arrays libc.private
combinators.short-circuit alien.data ;
SPECIALIZED-ARRAY: void*
IN: alien.marshall.private
: bool>arg ( ? -- 1/0/obj )
{
{ t [ 1 ] }
{ f [ 0 ] }
[ ]
} case ;
MACRO: marshall-x* ( num-quot seq-quot -- alien )
'[ bool>arg dup number? _ _ if ] ;
: ptr-pass-through ( obj quot -- alien )
over { [ c-ptr? ] [ ] } 1&& [ drop ] [ call ] if ; inline
: malloc-underlying ( obj -- alien )
underlying>> malloc-byte-array ;
FUNCTOR: define-primitive-marshallers ( TYPE -- )
<TYPE> IS <${TYPE}>
*TYPE IS *${TYPE}
>TYPE-array IS >${TYPE}-array
marshall-TYPE DEFINES marshall-${TYPE}
(marshall-TYPE*) DEFINES (marshall-${TYPE}*)
(marshall-TYPE**) DEFINES (marshall-${TYPE}**)
marshall-TYPE* DEFINES marshall-${TYPE}*
marshall-TYPE** DEFINES marshall-${TYPE}**
marshall-TYPE*-free DEFINES marshall-${TYPE}*-free
marshall-TYPE**-free DEFINES marshall-${TYPE}**-free
unmarshall-TYPE* DEFINES unmarshall-${TYPE}*
unmarshall-TYPE*-free DEFINES unmarshall-${TYPE}*-free
WHERE
<PRIVATE
: (marshall-TYPE*) ( n/seq -- alien )
[ <TYPE> malloc-byte-array ]
[ >TYPE-array malloc-underlying ]
marshall-x* ;
PRIVATE>
: marshall-TYPE* ( n/seq -- alien )
[ (marshall-TYPE*) ] ptr-pass-through ;
<PRIVATE
: (marshall-TYPE**) ( seq -- alien )
[ marshall-TYPE* ] void*-array{ } map-as malloc-underlying ;
PRIVATE>
: marshall-TYPE** ( seq -- alien )
[ (marshall-TYPE**) ] ptr-pass-through ;
: unmarshall-TYPE* ( alien -- n )
*TYPE ; inline
: unmarshall-TYPE*-free ( alien -- n )
[ unmarshall-TYPE* ] keep add-malloc free ;
;FUNCTOR
SYNTAX: PRIMITIVE-MARSHALLERS:
";" parse-tokens [ define-primitive-marshallers ] each ;

View File

@ -1 +0,0 @@
Jeremy Hughes

View File

@ -1,19 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: classes help.markup help.syntax kernel quotations words
alien.marshall.structs strings alien.structs alien.marshall ;
IN: alien.marshall.structs
HELP: define-marshalled-struct
{ $values
{ "name" string } { "vocab" "a vocabulary specifier" } { "fields" "an alist" }
}
{ $description "Calls " { $link define-struct } " and " { $link define-struct-tuple } "." } ;
HELP: define-struct-tuple
{ $values
{ "name" string }
}
{ $description "Defines a subclass of " { $link struct-wrapper } ", a constructor, "
"and accessor words."
} ;

View File

@ -1,50 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.marshall arrays assocs
classes.tuple combinators destructors generalizations generic
kernel libc locals parser quotations sequences slots words
alien.structs lexer vocabs.parser fry effects alien.data ;
IN: alien.marshall.structs
<PRIVATE
: define-struct-accessor ( class name quot -- )
[ "accessors" create create-method dup make-inline ] dip define ;
: define-struct-getter ( class name word type -- )
[ ">>" append \ underlying>> ] 2dip
struct-field-unmarshaller \ call 4array >quotation
define-struct-accessor ;
: define-struct-setter ( class name word type -- )
[ "<<" append ] 2dip
marshaller [ underlying>> ] \ bi* roll 4array >quotation
define-struct-accessor ;
: define-struct-accessors ( class name type reader writer -- )
[ dup define-protocol-slot ] 3dip
[ drop swap define-struct-getter ]
[ nip swap define-struct-setter ] 5 nbi ;
: define-struct-constructor ( class -- )
{
[ name>> "<" prepend ">" append create-word-in ]
[ '[ _ new ] ]
[ name>> '[ _ malloc-struct >>underlying ] append ]
[ name>> 1array ]
} cleave { } swap <effect> define-declared ;
PRIVATE>
:: define-struct-tuple ( name -- )
name create-word-in :> class
class struct-wrapper { } define-tuple-class
class define-struct-constructor
name c-type fields>> [
class swap
{
[ name>> H{ { CHAR: space CHAR: - } } substitute ]
[ type>> ] [ reader>> ] [ writer>> ]
} cleave define-struct-accessors
] each ;
: define-marshalled-struct ( name vocab fields -- )
[ define-struct ] [ 2drop define-struct-tuple ] 3bi ;

View File

@ -1 +0,0 @@
Jeremy Hughes

View File

@ -1,84 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations words
alien.inline alien.syntax effects alien.marshall
alien.marshall.structs strings sequences alien.inline.syntax ;
IN: alien.marshall.syntax
HELP: CM-FUNCTION:
{ $syntax "CM-FUNCTION: return name args\n body\n;" }
{ $description "Like " { $link POSTPONE: C-FUNCTION: } " but with marshalling "
"of arguments and return values."
}
{ $examples
{ $example
"USING: alien.inline.syntax alien.marshall.syntax prettyprint ;"
"IN: example"
""
"C-LIBRARY: exlib"
""
"C-INCLUDE: <stdio.h>"
"C-INCLUDE: <stdlib.h>"
"CM-FUNCTION: char* sum_diff ( const-int a, const-int b, int* x, int* y )"
" *x = a + b;"
" *y = a - b;"
" char* s = (char*) malloc(sizeof(char) * 64);"
" sprintf(s, \"sum %i, diff %i\", *x, *y);"
" return s;"
";"
""
";C-LIBRARY"
""
"8 5 0 0 sum_diff . . ."
"3\n13\n\"sum 13, diff 3\""
}
}
{ $see-also define-c-marshalled POSTPONE: C-FUNCTION: POSTPONE: M-FUNCTION: } ;
HELP: CM-STRUCTURE:
{ $syntax "CM-STRUCTURE: name fields ... ;" }
{ $description "Like " { $link POSTPONE: C-STRUCTURE: } " but with marshalling of fields. "
"Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
}
{ $see-also POSTPONE: C-STRUCTURE: POSTPONE: M-STRUCTURE: } ;
HELP: M-FUNCTION:
{ $syntax "M-FUNCTION: return name args ;" }
{ $description "Like " { $link POSTPONE: FUNCTION: } " but with marshalling "
"of arguments and return values."
}
{ $see-also marshalled-function POSTPONE: C-FUNCTION: POSTPONE: CM-FUNCTION: } ;
HELP: M-STRUCTURE:
{ $syntax "M-STRUCTURE: name fields ... ;" }
{ $description "Like " { $link POSTPONE: C-STRUCT: } " but with marshalling of fields. "
"Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
}
{ $see-also define-marshalled-struct POSTPONE: C-STRUCTURE: POSTPONE: CM-STRUCTURE: } ;
HELP: define-c-marshalled
{ $values
{ "name" string } { "types" sequence } { "effect" effect } { "body" string }
}
{ $description "Defines a C function and a factor word which calls it with marshalling of "
"args and return values."
}
{ $see-also define-c-marshalled' } ;
HELP: define-c-marshalled'
{ $values
{ "name" string } { "effect" effect } { "body" string }
}
{ $description "Like " { $link define-c-marshalled } ". "
"The effect elements must be C type strings."
} ;
HELP: marshalled-function
{ $values
{ "name" string } { "types" sequence } { "effect" effect }
{ "word" word } { "quot" quotation } { "effect" effect }
}
{ $description "Defines a word which calls the named C function. Arguments, "
"return value, and output parameters are marshalled and unmarshalled."
} ;

View File

@ -1,75 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.inline.syntax alien.marshall.syntax destructors
tools.test accessors kernel ;
IN: alien.marshall.syntax.tests
DELETE-C-LIBRARY: test
C-LIBRARY: test
C-INCLUDE: <stdlib.h>
C-INCLUDE: <string.h>
C-INCLUDE: <stdbool.h>
CM-FUNCTION: void outarg1 ( int* a )
*a += 2;
;
CM-FUNCTION: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b )
unsigned long* x = malloc(sizeof(unsigned long*));
*b = 10 + *b;
*x = a + *b;
return x;
;
CM-STRUCTURE: wedge
{ "double" "degrees" } ;
CM-STRUCTURE: sundial
{ "double" "radius" }
{ "wedge" "wedge" } ;
CM-FUNCTION: double hours ( sundial* d )
return d->wedge.degrees / 30;
;
CM-FUNCTION: void change_time ( double hours, sundial* d )
d->wedge.degrees = hours * 30;
;
CM-FUNCTION: bool c_not ( bool p )
return !p;
;
CM-FUNCTION: char* upcase ( const-char* s )
int len = strlen(s);
char* t = malloc(sizeof(char) * len);
int i;
for (i = 0; i < len; i++)
t[i] = toupper(s[i]);
t[i] = '\0';
return t;
;
;C-LIBRARY
{ 1 1 } [ outarg1 ] must-infer-as
[ 3 ] [ 1 outarg1 ] unit-test
[ 3 ] [ t outarg1 ] unit-test
[ 2 ] [ f outarg1 ] unit-test
{ 2 2 } [ outarg2 ] must-infer-as
[ 18 15 ] [ 3 5 outarg2 ] unit-test
{ 1 1 } [ hours ] must-infer-as
[ 5.0 ] [ <sundial> <wedge> 150 >>degrees >>wedge hours ] unit-test
{ 2 0 } [ change_time ] must-infer-as
[ 150.0 ] [ 5 <sundial> <wedge> 11 >>degrees >>wedge [ change_time ] keep wedge>> degrees>> ] unit-test
{ 1 1 } [ c_not ] must-infer-as
[ f ] [ "x" c_not ] unit-test
[ f ] [ 0 c_not ] unit-test
{ 1 1 } [ upcase ] must-infer-as
[ "ABC" ] [ "abc" upcase ] unit-test

View File

@ -1,50 +0,0 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.inline alien.inline.types alien.marshall
combinators effects generalizations kernel locals make namespaces
quotations sequences words alien.marshall.structs lexer parser
vocabs.parser multiline ;
IN: alien.marshall.syntax
:: marshalled-function ( name types effect -- word quot effect )
name types effect factor-function
[ in>> ]
[ out>> types [ pointer-to-non-const-primitive? ] filter append ]
bi <effect>
[
[
types [ marshaller ] map , \ spread , ,
types length , \ nkeep ,
types [ out-arg-unmarshaller ] map
effect out>> dup empty?
[ drop ] [ first unmarshaller prefix ] if
, \ spread ,
] [ ] make
] dip ;
: define-c-marshalled ( name types effect body -- )
[
[ marshalled-function define-declared ]
[ prototype-string ] 3bi
] dip append-function-body c-strings get push ;
: define-c-marshalled' ( name effect body -- )
[
[ in>> ] keep
[ marshalled-function define-declared ]
[ out>> prototype-string' ] 3bi
] dip append-function-body c-strings get push ;
SYNTAX: CM-FUNCTION:
function-types-effect parse-here define-c-marshalled ;
SYNTAX: M-FUNCTION:
function-types-effect marshalled-function define-declared ;
SYNTAX: M-STRUCTURE:
scan current-vocab parse-definition
define-marshalled-struct ;
SYNTAX: CM-STRUCTURE:
scan current-vocab parse-definition
[ define-marshalled-struct ] [ nip define-c-struct ] 3bi ;

View File

@ -1,67 +0,0 @@
USING: help.markup help.syntax ;
IN: animations
HELP: animate
{ $values
{ "quot" "a quot which uses " { $link progress } }
{ "duration" "a duration of time" }
}
{ $description
{ $link animate } " calls " { $link reset-progress }
" , then continously calls the given quot until the"
" duration of time has elapsed. The quot should use "
{ $link progress } " at least once."
}
{ $examples
{ $unchecked-example
"USING: animations calendar threads prettyprint ;"
"[ 1 sleep progress unparse write \" ms elapsed\" print ] "
"1/20 seconds animate ;"
"46 ms elapsed\n17 ms elapsed"
}
{ $notes "The amount of time elapsed between these iterations will vary." }
} ;
HELP: reset-progress
{ $description
"Initiates the timer. Call this before using "
"a loop which makes use of " { $link progress } "."
} ;
HELP: progress
{ $values { "time" "an integer" } }
{ $description
"Gives the time elapsed since the last time"
" this word was called, in milliseconds."
}
{ $examples
{ $unchecked-example
"USING: animations threads prettyprint ;"
"reset-progress 3 "
"[ 1 sleep progress unparse write \"ms elapsed\" print ] "
"times ;"
"31 ms elapsed\n18 ms elapsed\n16 ms elapsed"
}
{ $notes "The amount of time elapsed between these iterations will vary." }
} ;
ARTICLE: "animations" "Animations"
"Provides a lightweight framework for properly simulating continuous"
" functions of real time. This framework helps one create animations "
"that use rates which do not change across platforms. The speed of the "
"computer should correlate with the smoothness of the animation, not "
"the speed of the animation!"
{ $subsections
animate
reset-progress
progress
}
! A little talk about when to use progress and when to use animate
{ $link progress } " specifically provides the length of time since "
{ $link reset-progress } " was called, and also calls "
{ $link reset-progress } " as its last action. This can be directly "
"used when one's quote runs for a specific number of iterations, instead "
"of a length of time. If the animation is like most, and is expected to "
"run for a specific length of time, " { $link animate } " should be used." ;
ABOUT: "animations"

View File

@ -1,17 +0,0 @@
! Small library for cross-platform continuous functions of real time
USING: kernel shuffle system locals
prettyprint math io namespaces threads calendar ;
IN: animations
SYMBOL: last-loop
SYMBOL: sleep-period
: reset-progress ( -- ) millis last-loop set ;
! : my-progress ( -- progress ) millis
: progress ( -- time ) millis last-loop get - reset-progress ;
: progress-peek ( -- progress ) millis last-loop get - ;
: set-end ( duration -- end-time ) duration>milliseconds millis + ;
: loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ; inline
: animate ( quot duration -- ) reset-progress set-end loop ; inline
: sample ( revs quot -- avg ) reset-progress dupd times progress swap / ; inline

View File

@ -1 +0,0 @@
Reginald Ford

View File

@ -1,45 +0,0 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays cpu.architecture cpu.arm.assembler
cpu.arm.architecture cpu.arm5.assembler kernel kernel.private
math math.private namespaces sequences words quotations
byte-arrays hashtables.private hashtables generator
generator.registers generator.fixup sequences.private
strings.private ;
IN: cpu.arm4
: (%char-slot)
"out" operand string-offset MOV
"out" operand dup "n" operand 2 <LSR> ADD ;
\ char-slot [
(%char-slot)
"out" operand "obj" operand "out" operand <+> LDRH
"out" operand dup %tag-fixnum
] H{
{ +input+ { { f "n" } { f "obj" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
\ set-char-slot [
"val" operand dup %untag-fixnum
(%char-slot)
"val" operand "obj" operand "out" operand <+> STRH
] H{
{ +input+ { { f "val" } { f "n" } { f "obj" } } }
{ +scratch+ { { f "out" } } }
{ +clobber+ { "val" } }
} define-intrinsic
\ alien-signed-1 [ LDRSB ]
\ set-alien-signed-1 [ STRB ]
define-alien-integer-intrinsics
\ alien-unsigned-2 [ LDRH ]
\ set-alien-unsigned-2 [ STRH ]
define-alien-integer-intrinsics
\ alien-signed-2 [ LDRSH ]
\ set-alien-signed-2 [ STRH ]
define-alien-integer-intrinsics

View File

@ -1 +0,0 @@
Slava Pestov

View File

@ -1 +0,0 @@
Additional compiler intrinsics for ARM4

View File

@ -1,79 +0,0 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cpu.architecture cpu.arm.assembler
cpu.arm.architecture namespaces math sequences
generator generator.registers generator.fixup system layouts
alien ;
IN: cpu.arm.allot
: load-zone-ptr ( reg -- ) "nursery" f rot %alien-global ;
: %allot ( header size -- )
! Store a pointer to 'size' bytes allocated from the
! nursery in R11
8 align ! align the size
R12 load-zone-ptr ! nusery -> r12
R11 R12 cell <+> LDR ! nursery.here -> r11
R11 R11 pick ADD ! increment r11
R11 R12 cell <+> STR ! r11 -> nursery.here
R11 R11 rot SUB ! old value
R12 swap type-number tag-fixnum MOV ! compute header
R12 R11 0 <+> STR ! store header
;
: %store-tagged ( reg tag -- )
>r dup fresh-object v>operand R11 r> tag-number ORR ;
: %allot-bignum ( #digits -- )
! 1 cell header, 1 cell length, 1 cell sign, + digits
! length is the # of digits + sign
bignum over 3 + cells %allot
R12 swap 1+ v>operand MOV ! compute the length
R12 R11 cell <+> STR ! store the length
;
: %allot-bignum-signed-1 ( dst src -- )
! on entry, reg is a 30-bit quantity sign-extended to
! 32-bits.
! exits with tagged ptr to bignum in reg.
[
"end" define-label
! is it zero?
dup v>operand 0 CMP
0 >bignum pick EQ load-literal
"end" get EQ B
! ! it is non-zero
1 %allot-bignum
! is the fixnum negative?
dup v>operand 0 CMP
! negative sign
R12 1 LT MOV
! negate fixnum
dup v>operand dup 0 LT RSB
! positive sign
R12 0 GE MOV
! store sign
R12 R11 2 cells <+> STR
! store the number
v>operand R11 3 cells <+> STR
! tag the bignum, store it in reg
bignum %store-tagged
"end" resolve-label
] with-scope ;
M: arm-backend %box-alien ( dst src -- )
"end" define-label
dup v>operand 0 CMP
over v>operand f v>operand EQ MOV
"end" get EQ B
alien 4 cells %allot
! Store offset
v>operand R11 3 cells <+> STR
R12 f v>operand MOV
! Store expired slot
R12 R11 1 cells <+> STR
! Store underlying-alien slot
R12 R11 2 cells <+> STR
! Store tagged ptr in reg
object %store-tagged
"end" resolve-label ;

View File

@ -1 +0,0 @@
Slava Pestov

Some files were not shown because too many files have changed in this diff Show More