unmaintained: New repo here: https://github.com/factor/factor-unmaintained
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
parent
9e76899dbd
commit
9aacb29667
|
@ -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
|
||||
|
||||
|
|
|
@ -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"
|
|
@ -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
|
||||
|
||||
|
|
@ -1 +0,0 @@
|
|||
Jeff Bigot
|
|
@ -1 +0,0 @@
|
|||
Adam Wendt
|
|
@ -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"
|
|
@ -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 ;
|
|
@ -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"
|
|
@ -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
|
||||
|
|
@ -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 }
|
||||
}
|
|
@ -1 +0,0 @@
|
|||
Jeff Bigot
|
|
@ -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 ;
|
||||
|
|
@ -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>
|
|
@ -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>
|
|
@ -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>
|
|
@ -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>
|
|
@ -1 +0,0 @@
|
|||
Jeff Bigot
|
|
@ -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"
|
|
@ -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*
|
||||
;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Simple tool to navigate through a 4D space with projections on 4 3D spaces
|
|
@ -1 +0,0 @@
|
|||
4D viewer
|
|
@ -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>
|
|
@ -1 +0,0 @@
|
|||
Eduardo Cavazos
|
|
@ -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"
|
|
@ -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 ;
|
|
@ -1 +0,0 @@
|
|||
Jeff Bigot
|
|
@ -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"
|
|
@ -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 ;
|
|
@ -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"
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
|
@ -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
|
|
@ -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"
|
|
@ -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
|
|
@ -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 ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
;
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
Jeff Bigot
|
||||
Greg Ferrar
|
|
@ -1 +0,0 @@
|
|||
JF Bigot, after Greg Ferrar
|
|
@ -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"
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
A modification of solution to approximate solutions
|
|
@ -1 +0,0 @@
|
|||
ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm
|
|
@ -1 +0,0 @@
|
|||
adsoda 4D viewer
|
|
@ -1 +0,0 @@
|
|||
Jeff Bigot
|
|
@ -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"
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
||||
;
|
||||
|
|
@ -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"
|
|
@ -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
|
|
@ -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! ;
|
|
@ -1 +0,0 @@
|
|||
James Cash
|
|
@ -1 +0,0 @@
|
|||
Implmentation of advice/aspects
|
|
@ -1 +0,0 @@
|
|||
extensions
|
|
@ -1 +0,0 @@
|
|||
Jeremy Hughes
|
|
@ -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 ;
|
|
@ -1 +0,0 @@
|
|||
Jeremy Hughes
|
|
@ -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 ;
|
|
@ -1 +0,0 @@
|
|||
Jeremy Hughes
|
|
@ -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
|
|
@ -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 ;
|
|
@ -1 +0,0 @@
|
|||
Jeremy Hughes
|
|
@ -1 +0,0 @@
|
|||
Jeremy Hughes
|
|
@ -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"
|
|
@ -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 ;
|
|
@ -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" } "." } ;
|
|
@ -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 ;
|
|
@ -1 +0,0 @@
|
|||
Jeremy Hughes
|
|
@ -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" } "." } ;
|
|
@ -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 >>
|
|
@ -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 ;
|
|
@ -1 +0,0 @@
|
|||
Jeremy Hughes
|
|
@ -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 ;
|
|
@ -1 +0,0 @@
|
|||
Jeremy Hughes
|
|
@ -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"
|
|
@ -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 ;
|
|
@ -1 +0,0 @@
|
|||
Jeremy Hughes
|
|
@ -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 ;
|
|
@ -1 +0,0 @@
|
|||
Jeremy Hughes
|
|
@ -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."
|
||||
} ;
|
|
@ -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 ;
|
|
@ -1 +0,0 @@
|
|||
Jeremy Hughes
|
|
@ -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."
|
||||
} ;
|
||||
|
|
@ -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
|
|
@ -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 ;
|
|
@ -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"
|
|
@ -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
|
|
@ -1 +0,0 @@
|
|||
Reginald Ford
|
|
@ -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
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
|
@ -1 +0,0 @@
|
|||
Additional compiler intrinsics for ARM4
|
|
@ -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 ;
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue