Merge branch 'master' into new_ui
Slava Pestov
commit
b37bf90b33
|
|
@ -76,3 +76,5 @@ IN: bit-arrays.tests
|
|||
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
|
||||
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
|
||||
} bit-array>integer ] unit-test
|
||||
|
||||
[ 49 ] [ 49 <bit-array> dup set-bits [ ] count ] unit-test
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ TUPLE: bit-array
|
|||
|
||||
: (set-bits) ( bit-array n -- )
|
||||
[ [ length bits>cells ] keep ] dip swap underlying>>
|
||||
'[ [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
|
||||
'[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -327,7 +327,7 @@ HELP: $table
|
|||
|
||||
HELP: $values
|
||||
{ $values { "element" "an array of pairs of markup elements" } }
|
||||
{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder is either a single class word, or an element. If it is a class word " { $snippet "class" } ", it is intereted as if it were shorthand for " { $snippet "{ $instance class }" } "." }
|
||||
{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder is either a single class word, or an element. If it is a class word " { $snippet "class" } ", it is inserted as if it were shorthand for " { $snippet "{ $instance class }" } "." }
|
||||
{ $see-also $maybe $instance $quotation } ;
|
||||
|
||||
HELP: $instance
|
||||
|
|
|
|||
|
|
@ -4,9 +4,9 @@ USING: combinators io locals kernel math math.functions
|
|||
math.ranges namespaces random sequences hashtables sets ;
|
||||
IN: math.miller-rabin
|
||||
|
||||
: >even ( n -- int ) dup even? [ 1- ] unless ; foldable
|
||||
<PRIVATE
|
||||
|
||||
: >odd ( n -- int ) dup even? [ 1+ ] when ; foldable
|
||||
: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ;
|
||||
|
||||
TUPLE: positive-even-expected n ;
|
||||
|
||||
|
|
@ -28,6 +28,10 @@ TUPLE: positive-even-expected n ;
|
|||
] unless drop
|
||||
] each prime? ] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ;
|
||||
|
||||
: miller-rabin* ( n numtrials -- ? )
|
||||
over {
|
||||
{ [ dup 1 <= ] [ 3drop f ] }
|
||||
|
|
@ -46,11 +50,15 @@ TUPLE: positive-even-expected n ;
|
|||
|
||||
ERROR: no-relative-prime n ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (find-relative-prime) ( n guess -- p )
|
||||
over 1 <= [ over no-relative-prime ] when
|
||||
dup 1 <= [ drop 3 ] when
|
||||
2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: find-relative-prime* ( n guess -- p )
|
||||
#! find a prime relative to n with initial guess
|
||||
>odd (find-relative-prime) ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,400 @@
|
|||
! Copyright (C) 2008 Jean-François Bigot.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel quotations strings ;
|
||||
IN: 4DNav
|
||||
|
||||
HELP: (mvt-4D)
|
||||
{ $values
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: 4D-Rxw
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Rz" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: 4D-Rxy
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Rx" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: 4D-Rxz
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Ry" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: 4D-Ryw
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Ry" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: 4D-Ryz
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Rx" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: 4D-Rzw
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Rz" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: 4DNav
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: >observer3d
|
||||
{ $values
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: >present-space
|
||||
{ $values
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
|
||||
HELP: >view1
|
||||
{ $values
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: >view2
|
||||
{ $values
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: >view3
|
||||
{ $values
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: >view4
|
||||
{ $values
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: add-keyboard-delegate
|
||||
{ $values
|
||||
{ "obj" object }
|
||||
{ "obj" object }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: button*
|
||||
{ $values
|
||||
{ "string" string } { "quot" quotation }
|
||||
{ "button" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: camera-action
|
||||
{ $values
|
||||
{ "quot" quotation }
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: camera-button
|
||||
{ $values
|
||||
{ "string" string } { "quot" quotation }
|
||||
{ "button" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: controller-window*
|
||||
{ $values
|
||||
{ "gadget" "a gadget" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
|
||||
HELP: init-models
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: init-variables
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: menu-3D
|
||||
{ $values
|
||||
{ "gadget" null }
|
||||
}
|
||||
{ $description "The menu dedicated to 3D movements of the camera" } ;
|
||||
|
||||
HELP: menu-4D
|
||||
{ $values
|
||||
|
||||
{ "gadget" null }
|
||||
}
|
||||
{ $description "The menu dedicated to 4D movements of space" } ;
|
||||
|
||||
HELP: menu-bar
|
||||
{ $values
|
||||
|
||||
{ "gadget" null }
|
||||
}
|
||||
{ $description "return gadget containing menu buttons" } ;
|
||||
|
||||
HELP: model-projection
|
||||
{ $values
|
||||
{ "x" null }
|
||||
{ "space" null }
|
||||
}
|
||||
{ $description "Project space following coordinate x" } ;
|
||||
|
||||
HELP: mvt-3D-1
|
||||
{ $values
|
||||
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "return a quotation to orientate space to see it from first point of view" } ;
|
||||
|
||||
HELP: mvt-3D-2
|
||||
{ $values
|
||||
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "return a quotation to orientate space to see it from second point of view" } ;
|
||||
|
||||
HELP: mvt-3D-3
|
||||
{ $values
|
||||
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "return a quotation to orientate space to see it from third point of view" } ;
|
||||
|
||||
HELP: mvt-3D-4
|
||||
{ $values
|
||||
|
||||
{ "quot" quotation }
|
||||
}
|
||||
{ $description "return a quotation to orientate space to see it from first point of view" } ;
|
||||
|
||||
HELP: observer3d
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: observer3d>
|
||||
{ $values
|
||||
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: present-space
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: present-space>
|
||||
{ $values
|
||||
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: load-model-file
|
||||
{ $description "load space from file" } ;
|
||||
|
||||
HELP: rotation-4D
|
||||
{ $values
|
||||
{ "m" "a rotation matrix" }
|
||||
}
|
||||
{ $description "Apply a 4D rotation matrix" } ;
|
||||
|
||||
HELP: translation-4D
|
||||
{ $values
|
||||
{ "v" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: update-model-projections
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: update-observer-projections
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: view1
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: view1>
|
||||
{ $values
|
||||
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: view2
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: view2>
|
||||
{ $values
|
||||
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: view3
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: view3>
|
||||
{ $values
|
||||
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: view4
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: view4>
|
||||
{ $values
|
||||
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: viewer-windows*
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: win3D
|
||||
{ $values
|
||||
{ "text" null } { "gadget" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: windows
|
||||
{ $description "" } ;
|
||||
|
||||
ARTICLE: "Space file" "Create a new space file"
|
||||
"\nTo build a new space, create an XML file using " { $vocab-link "adsoda" } " model description. \nAn example is:"
|
||||
$nl
|
||||
|
||||
"\n<model>"
|
||||
"\n<space>"
|
||||
"\n <dimension>4</dimension>"
|
||||
"\n <solid>"
|
||||
"\n <name>4cube1</name>"
|
||||
"\n <dimension>4</dimension>"
|
||||
"\n <face>1,0,0,0,100</face>"
|
||||
"\n <face>-1,0,0,0,-150</face>"
|
||||
"\n <face>0,1,0,0,100</face>"
|
||||
"\n <face>0,-1,0,0,-150</face>"
|
||||
"\n <face>0,0,1,0,100</face>"
|
||||
"\n <face>0,0,-1,0,-150</face>"
|
||||
"\n <face>0,0,0,1,100</face>"
|
||||
"\n <face>0,0,0,-1,-150</face>"
|
||||
"\n <color>1,0,0</color>"
|
||||
"\n </solid>"
|
||||
"\n <solid>"
|
||||
"\n <name>4triancube</name>"
|
||||
"\n <dimension>4</dimension>"
|
||||
"\n <face>1,0,0,0,160</face>"
|
||||
"\n <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>"
|
||||
"\n <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>"
|
||||
"\n <face>0,0,1,0,140</face>"
|
||||
"\n <face>0,0,-1,0,-180</face>"
|
||||
"\n <face>0,0,0,1,110</face>"
|
||||
"\n <face>0,0,0,-1,-180</face>"
|
||||
"\n <color>0,1,0</color>"
|
||||
"\n </solid>"
|
||||
"\n <solid>"
|
||||
"\n <name>triangone</name>"
|
||||
"\n <dimension>4</dimension>"
|
||||
"\n <face>1,0,0,0,60</face>"
|
||||
"\n <face>0.5,0.8660254037844386,0,0,60</face>"
|
||||
"\n <face>-0.5,0.8660254037844387,0,0,-20</face>"
|
||||
"\n <face>-1.0,0,0,0,-100</face>"
|
||||
"\n <face>-0.5,-0.8660254037844384,0,0,-100</face>"
|
||||
"\n <face>0.5,-0.8660254037844387,0,0,-20</face>"
|
||||
"\n <face>0,0,1,0,120</face>"
|
||||
"\n <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>"
|
||||
"\n <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>"
|
||||
"\n <color>0,1,1</color>"
|
||||
"\n </solid>"
|
||||
"\n <light>"
|
||||
"\n <direction>1,1,1,1</direction>"
|
||||
"\n <color>0.2,0.2,0.6</color>"
|
||||
"\n </light>"
|
||||
"\n <color>0.8,0.9,0.9</color>"
|
||||
"\n</space>"
|
||||
"\n</model>"
|
||||
|
||||
|
||||
;
|
||||
|
||||
ARTICLE: "TODO" "Todo"
|
||||
{ $list
|
||||
"A file chooser"
|
||||
"A vocab to initialize parameters"
|
||||
"an editor mode"
|
||||
{ $list "add a face to a solid"
|
||||
"add a solid to the space"
|
||||
"move a face"
|
||||
"move a solid"
|
||||
"select a solid in a list"
|
||||
"select a face"
|
||||
"display selected face"
|
||||
"edit a solid color"
|
||||
"add a light"
|
||||
"edit a light color"
|
||||
"move a light"
|
||||
}
|
||||
"add a tool wich give an hyperplane normal vector with enought points. Will use adsoda.intersect-hyperplanes with { { 0 } { 0 } { 1 } } "
|
||||
"decorrelate 3D camera and activate them with select buttons"
|
||||
|
||||
|
||||
|
||||
} ;
|
||||
|
||||
|
||||
ARTICLE: "4DNav" "4DNav"
|
||||
{ $vocab-link "4DNav" }
|
||||
$nl
|
||||
{ $heading "4D Navigator" }
|
||||
"4DNav is a simple tool to visualize 4 dimensionnal objects."
|
||||
"\n"
|
||||
"It uses " { $vocab-link "adsoda" } " library to display a 4D space and navigate thru it."
|
||||
|
||||
"It will display:"
|
||||
{ $list
|
||||
{ "a menu window" }
|
||||
{ "4 visualization windows" }
|
||||
}
|
||||
"Each window represents the projection of the 4D space on a particular 3D space."
|
||||
$nl
|
||||
|
||||
{ $heading "Initialization" }
|
||||
"put the space file " { $strong "space-exemple.xml" } " in temp directory"
|
||||
" and then type:" { $code "\"4DNav\" run" }
|
||||
{ $heading "Navigation" }
|
||||
"4D submenu move the space in translations and rotation."
|
||||
"\n3D submenu move the camera in 3D space. Cameras in every 3D spaces are manipulated as a single one"
|
||||
$nl
|
||||
|
||||
|
||||
|
||||
|
||||
{ $heading "Links" }
|
||||
{ $subsection "Space file" }
|
||||
|
||||
{ $subsection "TODO" }
|
||||
|
||||
|
||||
;
|
||||
|
||||
ABOUT: "4DNav"
|
||||
|
|
@ -0,0 +1,524 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel
|
||||
namespaces
|
||||
accessors
|
||||
make
|
||||
math
|
||||
math.functions
|
||||
math.trig
|
||||
math.parser
|
||||
hashtables
|
||||
sequences
|
||||
combinators
|
||||
continuations
|
||||
colors
|
||||
prettyprint
|
||||
vars
|
||||
quotations
|
||||
io
|
||||
io.directories
|
||||
io.pathnames
|
||||
help.markup
|
||||
io.files
|
||||
ui.gadgets.panes
|
||||
ui
|
||||
ui.gadgets
|
||||
ui.traverse
|
||||
ui.gadgets.borders
|
||||
ui.gadgets.handler
|
||||
ui.gadgets.slate
|
||||
ui.gadgets.theme
|
||||
ui.gadgets.frames
|
||||
ui.gadgets.tracks
|
||||
ui.gadgets.labels
|
||||
ui.gadgets.labelled
|
||||
ui.gadgets.lists
|
||||
ui.gadgets.buttons
|
||||
ui.gadgets.packs
|
||||
ui.gadgets.grids
|
||||
ui.gestures
|
||||
ui.tools.workspace
|
||||
ui.gadgets.scrollers
|
||||
splitting
|
||||
vectors
|
||||
math.vectors
|
||||
rewrite-closures
|
||||
self
|
||||
values
|
||||
4DNav.turtle
|
||||
4DNav.window3D
|
||||
4DNav.deep
|
||||
4DNav.space-file-decoder
|
||||
models
|
||||
fry
|
||||
adsoda
|
||||
adsoda.tools
|
||||
;
|
||||
|
||||
IN: 4DNav
|
||||
VALUE: selected-file
|
||||
VALUE: translation-step
|
||||
VALUE: rotation-step
|
||||
|
||||
3 to: translation-step
|
||||
5 to: rotation-step
|
||||
|
||||
VAR: selected-file-model
|
||||
VAR: observer3d
|
||||
VAR: view1
|
||||
VAR: view2
|
||||
VAR: view3
|
||||
VAR: view4
|
||||
VAR: present-space
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! replacement of namespaces.lib
|
||||
|
||||
: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! waiting for deep-cleave-quots
|
||||
|
||||
: 4D-Rxy ( angle -- Rx ) deg>rad
|
||||
[ 1.0 , 0.0 , 0.0 , 0.0 ,
|
||||
0.0 , 1.0 , 0.0 , 0.0 ,
|
||||
0.0 , 0.0 , dup cos , dup sin neg ,
|
||||
0.0 , 0.0 , dup sin , dup cos , ] 4 make-matrix nip ;
|
||||
|
||||
: 4D-Rxz ( angle -- Ry ) deg>rad
|
||||
[ 1.0 , 0.0 , 0.0 , 0.0 ,
|
||||
0.0 , dup cos , 0.0 , dup sin neg ,
|
||||
0.0 , 0.0 , 1.0 , 0.0 ,
|
||||
0.0 , dup sin , 0.0 , dup cos , ] 4 make-matrix nip ;
|
||||
|
||||
: 4D-Rxw ( angle -- Rz ) deg>rad
|
||||
[ 1.0 , 0.0 , 0.0 , 0.0 ,
|
||||
0.0 , dup cos , dup sin neg , 0.0 ,
|
||||
0.0 , dup sin , dup cos , 0.0 ,
|
||||
0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
|
||||
|
||||
: 4D-Ryz ( angle -- Rx ) deg>rad
|
||||
[ dup cos , 0.0 , 0.0 , dup sin neg ,
|
||||
0.0 , 1.0 , 0.0 , 0.0 ,
|
||||
0.0 , 0.0 , 1.0 , 0.0 ,
|
||||
dup sin , 0.0 , 0.0 , dup cos , ] 4 make-matrix nip ;
|
||||
|
||||
: 4D-Ryw ( angle -- Ry ) deg>rad
|
||||
[ dup cos , 0.0 , dup sin neg , 0.0 ,
|
||||
0.0 , 1.0 , 0.0 , 0.0 ,
|
||||
dup sin , 0.0 , dup cos , 0.0 ,
|
||||
0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
|
||||
|
||||
: 4D-Rzw ( angle -- Rz ) deg>rad
|
||||
[ dup cos , dup sin neg , 0.0 , 0.0 ,
|
||||
dup sin , dup cos , 0.0 , 0.0 ,
|
||||
0.0 , 0.0 , 1.0 , 0.0 ,
|
||||
0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! UI
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: button* ( string quot -- button ) closed-quot <repeat-button> ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: model-projection-chooser ( -- gadget )
|
||||
observer3d> projection-mode>>
|
||||
{ { 1 "perspective" } { 0 "orthogonal" } } <toggle-buttons> ;
|
||||
|
||||
: collision-detection-chooser ( -- gadget )
|
||||
observer3d> collision-mode>>
|
||||
{ { t "on" } { f "off" } } <toggle-buttons>
|
||||
;
|
||||
|
||||
: model-projection ( x -- space ) present-space> swap space-project ;
|
||||
|
||||
: update-observer-projections ( -- )
|
||||
view1> relayout-1
|
||||
view2> relayout-1
|
||||
view3> relayout-1
|
||||
view4> relayout-1 ;
|
||||
|
||||
: update-model-projections ( -- )
|
||||
0 model-projection <model> view1> (>>model)
|
||||
1 model-projection <model> view2> (>>model)
|
||||
2 model-projection <model> view3> (>>model)
|
||||
3 model-projection <model> view4> (>>model) ;
|
||||
|
||||
: camera-action ( quot -- quot )
|
||||
[ drop [ ] observer3d> with-self update-observer-projections ]
|
||||
make* closed-quot ;
|
||||
|
||||
: win3D ( text gadget -- ) "navigateur 4D : " rot append open-window ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! 4D object manipulation
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: (mvt-4D) ( quot -- )
|
||||
present-space>
|
||||
swap call space-ensure-solids
|
||||
>present-space
|
||||
update-model-projections
|
||||
update-observer-projections ;
|
||||
|
||||
: rotation-4D ( m -- )
|
||||
'[ _ [ [ middle-of-space dup vneg ] keep swap space-translate ] dip
|
||||
space-transform
|
||||
swap space-translate
|
||||
] (mvt-4D) ;
|
||||
|
||||
: translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! menu
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: menu-rotations-4D ( -- gadget )
|
||||
<frame>
|
||||
<pile> 1 >>fill
|
||||
"XY +" [ drop rotation-step 4D-Rxy rotation-4D ] button* add-gadget
|
||||
"XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] button* add-gadget
|
||||
@top-left grid-add
|
||||
<pile> 1 >>fill
|
||||
"XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] button* add-gadget
|
||||
"XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] button* add-gadget
|
||||
@top grid-add
|
||||
<pile> 1 >>fill
|
||||
"YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] button* add-gadget
|
||||
"YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] button* add-gadget
|
||||
@center grid-add
|
||||
<pile> 1 >>fill
|
||||
"XW +" [ drop rotation-step 4D-Rxw rotation-4D ] button* add-gadget
|
||||
"XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] button* add-gadget
|
||||
@top-right grid-add
|
||||
<pile> 1 >>fill
|
||||
"YW +" [ drop rotation-step 4D-Ryw rotation-4D ] button* add-gadget
|
||||
"YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] button* add-gadget
|
||||
@right grid-add
|
||||
<pile> 1 >>fill
|
||||
"ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] button* add-gadget
|
||||
"ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] button* add-gadget
|
||||
@bottom-right grid-add
|
||||
;
|
||||
|
||||
: menu-translations-4D ( -- gadget )
|
||||
<frame>
|
||||
<pile> 1 >>fill
|
||||
<shelf> 1 >>fill
|
||||
"X+" [ drop { 1 0 0 0 } translation-step v*n translation-4D ]
|
||||
button* add-gadget
|
||||
"X-" [ drop { -1 0 0 0 } translation-step v*n translation-4D ]
|
||||
button* add-gadget
|
||||
add-gadget
|
||||
"YZW" <label> add-gadget
|
||||
@bottom-right grid-add
|
||||
<pile> 1 >>fill
|
||||
"XZW" <label> add-gadget
|
||||
<shelf> 1 >>fill
|
||||
"Y+" [ drop { 0 1 0 0 } translation-step v*n translation-4D ]
|
||||
button* add-gadget
|
||||
"Y-" [ drop { 0 -1 0 0 } translation-step v*n translation-4D ]
|
||||
button* add-gadget
|
||||
add-gadget
|
||||
@top-right grid-add
|
||||
<pile> 1 >>fill
|
||||
"XYW" <label> add-gadget
|
||||
<shelf> 1 >>fill
|
||||
"Z+" [ drop { 0 0 1 0 } translation-step v*n translation-4D ]
|
||||
button* add-gadget
|
||||
"Z-" [ drop { 0 0 -1 0 } translation-step v*n translation-4D ]
|
||||
button* add-gadget
|
||||
add-gadget
|
||||
@top-left grid-add
|
||||
<pile> 1 >>fill
|
||||
<shelf> 1 >>fill
|
||||
"W+" [ drop { 0 0 0 1 } translation-step v*n translation-4D ]
|
||||
button* add-gadget
|
||||
"W-" [ drop { 0 0 0 -1 } translation-step v*n translation-4D ]
|
||||
button* add-gadget
|
||||
add-gadget
|
||||
"XYZ" <label> add-gadget
|
||||
@bottom-left grid-add
|
||||
"X" <label> @center grid-add
|
||||
;
|
||||
|
||||
: menu-4D ( -- gadget )
|
||||
<shelf>
|
||||
"rotations" <label> add-gadget
|
||||
menu-rotations-4D add-gadget
|
||||
"translations" <label> add-gadget
|
||||
menu-translations-4D add-gadget
|
||||
0.5 >>align
|
||||
{ 0 10 } >>gap
|
||||
;
|
||||
|
||||
|
||||
! ------------------------------------------------------
|
||||
|
||||
: redraw-model ( space -- )
|
||||
>present-space
|
||||
update-model-projections
|
||||
update-observer-projections ;
|
||||
|
||||
: load-model-file ( -- )
|
||||
selected-file dup selected-file-model> set-model read-model-file
|
||||
redraw-model ;
|
||||
|
||||
: mvt-3D-X ( turn pitch -- quot )
|
||||
'[ turtle-pos> norm neg reset-turtle
|
||||
_ turn-left
|
||||
_ pitch-up
|
||||
step-turtle ] ;
|
||||
|
||||
: mvt-3D-1 ( -- quot ) 90 0 mvt-3D-X ; inline
|
||||
: mvt-3D-2 ( -- quot ) 0 90 mvt-3D-X ; inline
|
||||
: mvt-3D-3 ( -- quot ) 0 0 mvt-3D-X ; inline
|
||||
: mvt-3D-4 ( -- quot ) 45 45 mvt-3D-X ; inline
|
||||
|
||||
: camera-button ( string quot -- button )
|
||||
[ <label> ] dip camera-action <repeat-button> ;
|
||||
|
||||
! ----------------------------------------------------------
|
||||
! file chooser
|
||||
! ----------------------------------------------------------
|
||||
: <run-file-button> ( file-name -- button )
|
||||
dup '[ drop _ \ selected-file set-value load-model-file
|
||||
]
|
||||
closed-quot <roll-button> { 0 0 } >>align ;
|
||||
|
||||
: <list-runner> ( -- gadget )
|
||||
"resource:extra/4DNav"
|
||||
<pile> 1 >>fill
|
||||
over dup directory-files
|
||||
[ ".xml" tail? ] filter
|
||||
[ append-path ] with map
|
||||
[ <run-file-button> add-gadget ] each
|
||||
swap <labelled-gadget> ;
|
||||
|
||||
! -----------------------------------------------------
|
||||
|
||||
: menu-rotations-3D ( -- gadget )
|
||||
<frame>
|
||||
"Turn\n left" [ rotation-step turn-left ] camera-button
|
||||
@left grid-add
|
||||
"Turn\n right" [ rotation-step turn-right ] camera-button
|
||||
@right grid-add
|
||||
"Pitch down" [ rotation-step pitch-down ] camera-button
|
||||
@bottom grid-add
|
||||
"Pitch up" [ rotation-step pitch-up ] camera-button
|
||||
@top grid-add
|
||||
<shelf> 1 >>fill
|
||||
"Roll left\n (ctl)" [ rotation-step roll-left ] camera-button
|
||||
add-gadget
|
||||
"Roll right\n(ctl)" [ rotation-step roll-right ] camera-button
|
||||
add-gadget
|
||||
@center grid-add
|
||||
;
|
||||
|
||||
: menu-translations-3D ( -- gadget )
|
||||
<frame>
|
||||
"left\n(alt)" [ translation-step strafe-left ] camera-button
|
||||
@left grid-add
|
||||
"right\n(alt)" [ translation-step strafe-right ] camera-button
|
||||
@right grid-add
|
||||
"Strafe up \n (alt)" [ translation-step strafe-up ] camera-button
|
||||
@top grid-add
|
||||
"Strafe down \n (alt)" [ translation-step strafe-down ] camera-button
|
||||
@bottom grid-add
|
||||
<pile> 1 >>fill
|
||||
"Forward (ctl)" [ translation-step step-turtle ] camera-button
|
||||
add-gadget
|
||||
"Backward (ctl)" [ translation-step neg step-turtle ] camera-button
|
||||
add-gadget
|
||||
@center grid-add
|
||||
;
|
||||
|
||||
: menu-quick-views ( -- gadget )
|
||||
<shelf>
|
||||
"View 1 (1)" mvt-3D-1 camera-button add-gadget
|
||||
"View 2 (2)" mvt-3D-2 camera-button add-gadget
|
||||
"View 3 (3)" mvt-3D-3 camera-button add-gadget
|
||||
"View 4 (4)" mvt-3D-4 camera-button add-gadget
|
||||
;
|
||||
|
||||
: menu-3D ( -- gadget )
|
||||
<pile>
|
||||
<shelf>
|
||||
menu-rotations-3D add-gadget
|
||||
menu-translations-3D add-gadget
|
||||
0.5 >>align
|
||||
{ 0 10 } >>gap
|
||||
add-gadget
|
||||
menu-quick-views add-gadget ;
|
||||
|
||||
: add-keyboard-delegate ( obj -- obj )
|
||||
<handler>
|
||||
{
|
||||
{ T{ key-down f f "LEFT" }
|
||||
[ [ rotation-step turn-left ] camera-action ] }
|
||||
{ T{ key-down f f "RIGHT" }
|
||||
[ [ rotation-step turn-right ] camera-action ] }
|
||||
{ T{ key-down f f "UP" }
|
||||
[ [ rotation-step pitch-down ] camera-action ] }
|
||||
{ T{ key-down f f "DOWN" }
|
||||
[ [ rotation-step pitch-up ] camera-action ] }
|
||||
|
||||
{ T{ key-down f { C+ } "UP" }
|
||||
[ [ translation-step step-turtle ] camera-action ] }
|
||||
{ T{ key-down f { C+ } "DOWN" }
|
||||
[ [ translation-step neg step-turtle ] camera-action ] }
|
||||
{ T{ key-down f { C+ } "LEFT" }
|
||||
[ [ rotation-step roll-left ] camera-action ] }
|
||||
{ T{ key-down f { C+ } "RIGHT" }
|
||||
[ [ rotation-step roll-right ] camera-action ] }
|
||||
|
||||
{ T{ key-down f { A+ } "LEFT" }
|
||||
[ [ translation-step strafe-left ] camera-action ] }
|
||||
{ T{ key-down f { A+ } "RIGHT" }
|
||||
[ [ translation-step strafe-right ] camera-action ] }
|
||||
{ T{ key-down f { A+ } "UP" }
|
||||
[ [ translation-step strafe-up ] camera-action ] }
|
||||
{ T{ key-down f { A+ } "DOWN" }
|
||||
[ [ translation-step strafe-down ] camera-action ] }
|
||||
|
||||
|
||||
{ T{ key-down f f "1" } [ mvt-3D-1 camera-action ] }
|
||||
{ T{ key-down f f "2" } [ mvt-3D-2 camera-action ] }
|
||||
{ T{ key-down f f "3" } [ mvt-3D-3 camera-action ] }
|
||||
{ T{ key-down f f "4" } [ mvt-3D-4 camera-action ] }
|
||||
|
||||
} [ make* ] map >hashtable >>table
|
||||
;
|
||||
|
||||
! --------------------------------------------
|
||||
! print elements
|
||||
! --------------------------------------------
|
||||
! print-content
|
||||
|
||||
GENERIC: adsoda-display-model ( x -- )
|
||||
|
||||
M: light adsoda-display-model
|
||||
"\n light : " .
|
||||
{
|
||||
[ direction>> "direction : " pprint . ]
|
||||
[ color>> "color : " pprint . ]
|
||||
} cleave
|
||||
;
|
||||
|
||||
M: face adsoda-display-model
|
||||
{
|
||||
[ halfspace>> "halfspace : " pprint . ]
|
||||
[ touching-corners>> "touching corners : " pprint . ]
|
||||
} cleave
|
||||
;
|
||||
M: solid adsoda-display-model
|
||||
{
|
||||
[ name>> "solid called : " pprint . ]
|
||||
[ color>> "color : " pprint . ]
|
||||
[ dimension>> "dimension : " pprint . ]
|
||||
[ faces>> "composed of faces : " pprint [ adsoda-display-model ] each ]
|
||||
} cleave
|
||||
;
|
||||
M: space adsoda-display-model
|
||||
{
|
||||
[ dimension>> "dimension : " pprint . ]
|
||||
[ ambient-color>> "ambient-color : " pprint . ]
|
||||
[ solids>> "composed of solids : " pprint [ adsoda-display-model ] each ]
|
||||
[ lights>> "composed of lights : " pprint [ adsoda-display-model ] each ]
|
||||
} cleave
|
||||
;
|
||||
|
||||
! ----------------------------------------------
|
||||
: menu-bar ( -- gadget )
|
||||
<shelf>
|
||||
"reinit" [ drop load-model-file ] button* add-gadget
|
||||
selected-file-model> <label-control> add-gadget
|
||||
;
|
||||
|
||||
|
||||
: controller-window* ( -- gadget )
|
||||
{ 0 1 } <track>
|
||||
menu-bar f track-add
|
||||
<list-runner>
|
||||
<limited-scroller>
|
||||
{ 200 400 } >>max-dim
|
||||
f track-add
|
||||
<shelf>
|
||||
"Projection mode : " <label> add-gadget
|
||||
model-projection-chooser add-gadget
|
||||
f track-add
|
||||
<shelf>
|
||||
"Collision detection (slow and buggy ) : " <label> add-gadget
|
||||
collision-detection-chooser add-gadget
|
||||
f track-add
|
||||
<pile>
|
||||
0.5 >>align
|
||||
menu-4D add-gadget
|
||||
light-purple solid-interior
|
||||
"4D movements" <labelled-gadget>
|
||||
f track-add
|
||||
<pile>
|
||||
0.5 >>align
|
||||
{ 2 2 } >>gap
|
||||
menu-3D add-gadget
|
||||
light-purple solid-interior
|
||||
"Camera 3D" <labelled-gadget>
|
||||
f track-add
|
||||
gray solid-interior
|
||||
;
|
||||
|
||||
: viewer-windows* ( -- )
|
||||
"YZW" view1> win3D
|
||||
"XZW" view2> win3D
|
||||
"XYW" view3> win3D
|
||||
"XYZ" view4> win3D
|
||||
;
|
||||
|
||||
: navigator-window* ( -- )
|
||||
controller-window*
|
||||
viewer-windows*
|
||||
add-keyboard-delegate
|
||||
"navigateur 4D" open-window
|
||||
;
|
||||
|
||||
: windows ( -- ) [ [ navigator-window* ] with-scope ] with-ui ;
|
||||
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: init-variables ( -- )
|
||||
"choose a file" <model> >selected-file-model
|
||||
<observer> >observer3d
|
||||
[ observer3d> >self
|
||||
reset-turtle
|
||||
45 turn-left
|
||||
45 pitch-up
|
||||
-300 step-turtle
|
||||
] with-scope
|
||||
|
||||
;
|
||||
|
||||
|
||||
: init-models ( -- )
|
||||
0 model-projection observer3d> <window3D> >view1
|
||||
1 model-projection observer3d> <window3D> >view2
|
||||
2 model-projection observer3d> <window3D> >view3
|
||||
3 model-projection observer3d> <window3D> >view4
|
||||
;
|
||||
|
||||
: 4DNav ( -- )
|
||||
init-variables
|
||||
selected-file read-model-file >present-space
|
||||
init-models
|
||||
windows
|
||||
;
|
||||
|
||||
MAIN: 4DNav
|
||||
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeff Bigot
|
||||
|
|
@ -0,0 +1 @@
|
|||
Adam Wendt
|
||||
|
|
@ -0,0 +1,88 @@
|
|||
! Copyright (C) 2008 Jean-François Bigot.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel ;
|
||||
IN: 4DNav.camera
|
||||
|
||||
HELP: camera-eye
|
||||
{ $values
|
||||
|
||||
{ "point" null }
|
||||
}
|
||||
{ $description "return the position of the camera" } ;
|
||||
|
||||
HELP: camera-focus
|
||||
{ $values
|
||||
|
||||
{ "point" null }
|
||||
}
|
||||
{ $description "return the point the camera looks at" } ;
|
||||
|
||||
HELP: camera-up
|
||||
{ $values
|
||||
|
||||
{ "dirvec" null }
|
||||
}
|
||||
{ $description "In order to precise the roling position of camera give an upward vector" } ;
|
||||
|
||||
HELP: do-look-at
|
||||
{ $values
|
||||
{ "camera" null }
|
||||
}
|
||||
{ $description "Word to use in replacement of gl-look-at when using a camera" } ;
|
||||
|
||||
ARTICLE: "4DNav.camera" "4DNav.camera"
|
||||
{ $vocab-link "4DNav.camera" }
|
||||
"\n"
|
||||
"A camera is defined by:"
|
||||
{ $list
|
||||
{ "a position (" { $link camera-eye } ")" }
|
||||
{ "a focus direction (" { $link camera-focus } ")\n" }
|
||||
{ "an attitude information (" { $link camera-up } ")\n" }
|
||||
}
|
||||
"\nUse " { $link do-look-at } " in opengl statement in placement of gl-look-at"
|
||||
"\n\n"
|
||||
"A camera is a " { $vocab-link "4DNav.turtle" } " object. Its a special vocab to handle mouvements of a 3D object:"
|
||||
{ $list
|
||||
{ "To define a camera"
|
||||
{
|
||||
$unchecked-example
|
||||
|
||||
"VAR: my-camera"
|
||||
": init-my-camera ( -- )"
|
||||
" <turtle> >my-camera"
|
||||
" [ my-camera> >self"
|
||||
" reset-turtle "
|
||||
" ] with-scope ;"
|
||||
} }
|
||||
{ "To move it"
|
||||
{
|
||||
$unchecked-example
|
||||
|
||||
" [ my-camera> >self"
|
||||
" 45 pitch-up "
|
||||
" 5 step-turtle"
|
||||
" ] with-scope "
|
||||
} }
|
||||
{ "or"
|
||||
{
|
||||
$unchecked-example
|
||||
|
||||
" [ my-camera> >self"
|
||||
" 5 strafe-left"
|
||||
" ] with-scope "
|
||||
}
|
||||
}
|
||||
{
|
||||
"to use it in an opengl statement"
|
||||
{
|
||||
$unchecked-example
|
||||
"my-camera> do-look-at"
|
||||
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
;
|
||||
|
||||
ABOUT: "4DNav.camera"
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
USING: kernel namespaces math.vectors opengl 4DNav.turtle self ;
|
||||
|
||||
IN: 4DNav.camera
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: camera-eye ( -- point ) turtle-pos> ;
|
||||
|
||||
: camera-focus ( -- point ) [ 1 step-turtle turtle-pos> ] save-self ;
|
||||
|
||||
: camera-up ( -- dirvec )
|
||||
[ 90 pitch-up turtle-pos> 1 step-turtle turtle-pos> swap v- ] save-self ;
|
||||
|
||||
: do-look-at ( camera -- )
|
||||
[ >self camera-eye camera-focus camera-up gl-look-at ] with-scope ;
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
! Copyright (C) 2008 Jean-François Bigot.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel quotations sequences ;
|
||||
IN: 4DNav.deep
|
||||
|
||||
! HELP: deep-cleave-quots
|
||||
! { $values
|
||||
! { "seq" sequence }
|
||||
! { "quot" quotation }
|
||||
! }
|
||||
! { $description "A word to build a soquence from a sequence of quotation" }
|
||||
!
|
||||
! { $examples
|
||||
! "It is useful to build matrix"
|
||||
! { $example "USING: math math.trig ; "
|
||||
! " 30 deg>rad "
|
||||
! " { { [ cos ] [ sin neg ] 0 } "
|
||||
! " { [ sin ] [ cos ] 0 } "
|
||||
! " { 0 0 1 } "
|
||||
! " } deep-cleave-quots "
|
||||
! " "
|
||||
!
|
||||
!
|
||||
! } }
|
||||
! ;
|
||||
|
||||
ARTICLE: "4DNav.deep" "4DNav.deep"
|
||||
{ $vocab-link "4DNav.deep" }
|
||||
;
|
||||
|
||||
ABOUT: "4DNav.deep"
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
USING: macros quotations math math.functions math.trig sequences.deep kernel make fry combinators grouping ;
|
||||
IN: 4DNav.deep
|
||||
|
||||
! USING: bake ;
|
||||
! MACRO: deep-cleave-quots ( seq -- quot )
|
||||
! [ [ quotation? ] deep-filter ]
|
||||
! [ [ dup quotation? [ drop , ] when ] deep-map ]
|
||||
! bi '[ _ cleave _ bake ] ;
|
||||
|
||||
: make-matrix ( quot width -- matrix ) [ { } make ] dip group ; inline
|
||||
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-c-types? t }
|
||||
{ deploy-word-props? t }
|
||||
{ deploy-name "4DNav" }
|
||||
{ deploy-ui? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-threads? t }
|
||||
{ deploy-reflection 3 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-unicode? t }
|
||||
{ deploy-io 3 }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-word-defs? t }
|
||||
}
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeff Bigot
|
||||
|
|
@ -0,0 +1,144 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING:
|
||||
kernel
|
||||
io.files
|
||||
io.backend
|
||||
io.directories
|
||||
io.files.info
|
||||
io.pathnames
|
||||
sequences
|
||||
models
|
||||
strings
|
||||
ui
|
||||
ui.operations
|
||||
ui.commands
|
||||
ui.gestures
|
||||
ui.gadgets
|
||||
ui.gadgets.buttons
|
||||
ui.gadgets.lists
|
||||
ui.gadgets.labels
|
||||
ui.gadgets.tracks
|
||||
ui.gadgets.packs
|
||||
ui.gadgets.panes
|
||||
ui.gadgets.scrollers
|
||||
prettyprint
|
||||
combinators
|
||||
rewrite-closures
|
||||
accessors
|
||||
values
|
||||
tools.walker
|
||||
fry
|
||||
;
|
||||
IN: 4DNav.file-chooser
|
||||
|
||||
TUPLE: file-chooser < track
|
||||
path
|
||||
extension
|
||||
selected-file
|
||||
presenter
|
||||
hook
|
||||
list
|
||||
;
|
||||
|
||||
: find-file-list ( gadget -- list )
|
||||
[ file-chooser? ] find-parent list>> ;
|
||||
|
||||
file-chooser H{
|
||||
{ T{ key-down f f "UP" } [ find-file-list select-previous ] }
|
||||
{ T{ key-down f f "DOWN" } [ find-file-list select-next ] }
|
||||
{ T{ key-down f f "PAGE_UP" } [ find-file-list list-page-up ] }
|
||||
{ T{ key-down f f "PAGE_DOWN" } [ find-file-list list-page-down ] }
|
||||
{ T{ key-down f f "RET" } [ find-file-list invoke-value-action ] }
|
||||
{ T{ button-down } request-focus }
|
||||
{ T{ button-down f 1 } [ find-file-list invoke-value-action ] }
|
||||
} set-gestures
|
||||
|
||||
: list-of-files ( file-chooser -- seq )
|
||||
[ path>> value>> directory-entries ] [ extension>> ] bi
|
||||
'[ [ name>> _ [ tail? ] with contains? ] [ directory? ] bi or ] filter
|
||||
;
|
||||
|
||||
: update-filelist-model ( file-chooser -- file-chooser )
|
||||
[ list-of-files ] [ model>> ] bi set-model ;
|
||||
|
||||
: init-filelist-model ( file-chooser -- file-chooser )
|
||||
dup list-of-files <model> >>model ;
|
||||
|
||||
: (fc-go) ( file-chooser quot -- )
|
||||
[ [ file-chooser? ] find-parent dup path>> ] dip
|
||||
call
|
||||
normalize-path swap set-model
|
||||
update-filelist-model
|
||||
drop ;
|
||||
|
||||
: fc-go-parent ( file-chooser -- )
|
||||
[ dup value>> parent-directory ] (fc-go) ;
|
||||
|
||||
: fc-go-home ( file-chooser -- )
|
||||
[ home ] (fc-go) ;
|
||||
|
||||
: fc-change-directory ( file-chooser file -- file-chooser )
|
||||
dupd [ path>> value>> normalize-path ] [ name>> ] bi*
|
||||
append-path over path>> set-model
|
||||
update-filelist-model
|
||||
;
|
||||
|
||||
: fc-load-file ( file-chooser file -- )
|
||||
dupd [ selected-file>> ] [ name>> ] bi* swap set-model
|
||||
[ path>> value>> ]
|
||||
[ selected-file>> value>> append ]
|
||||
[ hook>> ] tri
|
||||
call
|
||||
; inline
|
||||
|
||||
! : fc-ok-action ( file-chooser -- quot )
|
||||
! dup selected-file>> value>> "" =
|
||||
! [ drop [ drop ] ] [
|
||||
! [ path>> value>> ]
|
||||
! [ selected-file>> value>> append ]
|
||||
! [ hook>> prefix ] tri
|
||||
! [ drop ] prepend
|
||||
! ] if ;
|
||||
|
||||
: line-selected-action ( file-chooser -- )
|
||||
dup list>> list-value
|
||||
dup directory?
|
||||
[ fc-change-directory ] [ fc-load-file ] if ;
|
||||
|
||||
: present-dir-element ( element -- string )
|
||||
[ name>> ] [ directory? ] bi [ "-> " prepend ] when ;
|
||||
|
||||
: <file-list> ( file-chooser -- list )
|
||||
dup [ nip line-selected-action ] curry
|
||||
[ present-dir-element ] rot model>> <list> ;
|
||||
|
||||
: <file-chooser> ( hook path extension -- gadget )
|
||||
{ 0 1 } file-chooser new-track
|
||||
swap >>extension
|
||||
swap <model> >>path
|
||||
"" <model> >>selected-file
|
||||
swap >>hook
|
||||
init-filelist-model
|
||||
dup <file-list> >>list
|
||||
"choose a file in directory " <label> f track-add
|
||||
dup path>> <label-control> f track-add
|
||||
dup extension>> ", " join "limited to : " prepend <label> f track-add
|
||||
<shelf>
|
||||
"selected file : " <label> add-gadget
|
||||
over selected-file>> <label-control> add-gadget
|
||||
f track-add
|
||||
<shelf>
|
||||
over [ swap fc-go-parent ] curry "go up" swap <bevel-button> add-gadget
|
||||
over [ swap fc-go-home ] curry "go home" swap <bevel-button> add-gadget
|
||||
! over [ swap fc-ok-action ] curry "OK" swap <bevel-button> add-gadget
|
||||
! [ drop ] "Cancel" swap <bevel-button> add-gadget
|
||||
f track-add
|
||||
dup list>> <scroller> 1 track-add
|
||||
;
|
||||
|
||||
M: file-chooser pref-dim* drop { 400 200 } ;
|
||||
|
||||
: file-chooser-window ( -- )
|
||||
[ . ] home { "xml" "txt" } <file-chooser> "Choose a file" open-window ;
|
||||
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
<model>
|
||||
<space>
|
||||
<name>hypercube</name>
|
||||
<dimension>4</dimension>
|
||||
<solid>
|
||||
<name>4cube1</name>
|
||||
<dimension>4</dimension>
|
||||
<face>1,0,0,0,100</face>
|
||||
<face>-1,0,0,0,-150</face>
|
||||
<face>0,1,0,0,100</face>
|
||||
<face>0,-1,0,0,-150</face>
|
||||
<face>0,0,1,0,100</face>
|
||||
<face>0,0,-1,0,-150</face>
|
||||
<face>0,0,0,1,100</face>
|
||||
<face>0,0,0,-1,-150</face>
|
||||
<color>1,0,0</color>
|
||||
</solid>
|
||||
<solid>
|
||||
<name>4cube1</name>
|
||||
<dimension>4</dimension>
|
||||
<face>1,0,0,0,100</face>
|
||||
<face>-1,0,0,0,-150</face>
|
||||
<face>0,1,0,0,100</face>
|
||||
<face>0,-1,0,0,-150</face>
|
||||
<face>0,0,1,0,100</face>
|
||||
<face>0,0,-1,0,-150</face>
|
||||
<face>0,0,0,1,100</face>
|
||||
<face>0,0,0,-1,-150</face>
|
||||
<color>1,0,0</color>
|
||||
</solid>
|
||||
<light>
|
||||
<direction>1,1,1,1</direction>
|
||||
<color>0.2,0.2,0.6</color>
|
||||
</light>
|
||||
<color>0.8,0.9,0.9</color>
|
||||
</space>
|
||||
</model>
|
||||
|
|
@ -0,0 +1,62 @@
|
|||
<model>
|
||||
<space>
|
||||
<name>multi solids</name>
|
||||
<dimension>4</dimension>
|
||||
<solid>
|
||||
<name>4cube1</name>
|
||||
<dimension>4</dimension>
|
||||
<face>1,0,0,0,100</face>
|
||||
<face>-1,0,0,0,-150</face>
|
||||
<face>0,1,0,0,100</face>
|
||||
<face>0,-1,0,0,-150</face>
|
||||
<face>0,0,1,0,100</face>
|
||||
<face>0,0,-1,0,-150</face>
|
||||
<face>0,0,0,1,100</face>
|
||||
<face>0,0,0,-1,-150</face>
|
||||
<color>1,1,1</color>
|
||||
</solid>
|
||||
<solid>
|
||||
<name>4triancube</name>
|
||||
<dimension>4</dimension>
|
||||
<face>1,0,0,0,160</face>
|
||||
<face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>
|
||||
<face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>
|
||||
<face>0,0,1,0,140</face>
|
||||
<face>0,0,-1,0,-180</face>
|
||||
<face>0,0,0,1,110</face>
|
||||
<face>0,0,0,-1,-180</face>
|
||||
<color>1,1,1</color>
|
||||
</solid>
|
||||
<solid>
|
||||
<name>triangone</name>
|
||||
<dimension>4</dimension>
|
||||
<face>1,0,0,0,60</face>
|
||||
<face>0.5,0.8660254037844386,0,0,60</face>
|
||||
<face>-0.5,0.8660254037844387,0,0,-20</face>
|
||||
<face>-1.0,0,0,0,-100</face>
|
||||
<face>-0.5,-0.8660254037844384,0,0,-100</face>
|
||||
<face>0.5,-0.8660254037844387,0,0,-20</face>
|
||||
<face>0,0,1,0,120</face>
|
||||
<face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>
|
||||
<face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>
|
||||
<color>1,1,1</color>
|
||||
</solid>
|
||||
<light>
|
||||
<direction>1,0,0,0</direction>
|
||||
<color>0,0,0,0.6</color>
|
||||
</light>
|
||||
<light>
|
||||
<direction>0,1,0,0</direction>
|
||||
<color>0,0.6,0,0</color>
|
||||
</light>
|
||||
<light>
|
||||
<direction>0,0,1,0</direction>
|
||||
<color>0,0,0.6,0</color>
|
||||
</light>
|
||||
<light>
|
||||
<direction>0,0,0,1</direction>
|
||||
<color>0.6,0.6,0.6</color>
|
||||
</light>
|
||||
<color>0.99,0.99,0.99</color>
|
||||
</space>
|
||||
</model>
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
<model>
|
||||
<space>
|
||||
<name>multi solids</name>
|
||||
<dimension>4</dimension>
|
||||
<solid>
|
||||
<name>4cube1</name>
|
||||
<dimension>4</dimension>
|
||||
<face>1,0,0,0,100</face>
|
||||
<face>-1,0,0,0,-150</face>
|
||||
<face>0,1,0,0,100</face>
|
||||
<face>0,-1,0,0,-150</face>
|
||||
<face>0,0,1,0,100</face>
|
||||
<face>0,0,-1,0,-150</face>
|
||||
<face>0,0,0,1,100</face>
|
||||
<face>0,0,0,-1,-150</face>
|
||||
<color>1,0,0</color>
|
||||
</solid>
|
||||
<solid>
|
||||
<name>4triancube</name>
|
||||
<dimension>4</dimension>
|
||||
<face>1,0,0,0,160</face>
|
||||
<face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>
|
||||
<face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>
|
||||
<face>0,0,1,0,140</face>
|
||||
<face>0,0,-1,0,-180</face>
|
||||
<face>0,0,0,1,110</face>
|
||||
<face>0,0,0,-1,-180</face>
|
||||
<color>0,1,0</color>
|
||||
</solid>
|
||||
<solid>
|
||||
<name>triangone</name>
|
||||
<dimension>4</dimension>
|
||||
<face>1,0,0,0,60</face>
|
||||
<face>0.5,0.8660254037844386,0,0,60</face>
|
||||
<face>-0.5,0.8660254037844387,0,0,-20</face>
|
||||
<face>-1.0,0,0,0,-100</face>
|
||||
<face>-0.5,-0.8660254037844384,0,0,-100</face>
|
||||
<face>0.5,-0.8660254037844387,0,0,-20</face>
|
||||
<face>0,0,1,0,120</face>
|
||||
<face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>
|
||||
<face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>
|
||||
<color>0,1,1</color>
|
||||
</solid>
|
||||
<light>
|
||||
<direction>1,1,1,1</direction>
|
||||
<color>0.2,0.2,0.6</color>
|
||||
</light>
|
||||
<color>0.8,0.9,0.9</color>
|
||||
</space>
|
||||
</model>
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
<model>
|
||||
<space>
|
||||
<name>Prismetragone</name>
|
||||
<dimension>4</dimension>
|
||||
<solid>
|
||||
<name>triangone</name>
|
||||
<dimension>4</dimension>
|
||||
<face>1,0,0,0,60</face>
|
||||
<face>0.5,0.8660254037844386,0,0,60</face>
|
||||
<face>-0.5,0.8660254037844387,0,0,-20</face>
|
||||
<face>-1.0,0,0,0,-100</face>
|
||||
<face>-0.5,-0.8660254037844384,0,0,-100</face>
|
||||
<face>0.5,-0.8660254037844387,0,0,-20</face>
|
||||
<face>0,0,1,0,120</face>
|
||||
<face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>
|
||||
<face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>
|
||||
<color>0,1,1</color>
|
||||
</solid>
|
||||
<light>
|
||||
<direction>1,1,1,1</direction>
|
||||
<color>0.2,0.2,0.6</color>
|
||||
</light>
|
||||
<color>0.8,0.9,0.9</color>
|
||||
</space>
|
||||
</model>
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeff Bigot
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
! Copyright (C) 2008 Jean-François Bigot.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel ;
|
||||
IN: 4DNav.space-file-decoder
|
||||
|
||||
HELP: adsoda-read-model
|
||||
{ $values
|
||||
{ "tag" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: decode-number-array
|
||||
{ $values
|
||||
{ "x" null }
|
||||
{ "y" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: read-model-file
|
||||
{ $values
|
||||
|
||||
{ "path" "path to the file to read" }
|
||||
{ "x" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
ARTICLE: "4DNav.space-file-decoder" "4DNav.space-file-decoder"
|
||||
{ $vocab-link "4DNav.space-file-decoder" }
|
||||
;
|
||||
|
||||
ABOUT: "4DNav.space-file-decoder"
|
||||
|
|
@ -0,0 +1,65 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: adsoda
|
||||
xml
|
||||
xml.utilities
|
||||
accessors
|
||||
combinators
|
||||
sequences
|
||||
math.parser
|
||||
kernel
|
||||
splitting
|
||||
values
|
||||
continuations
|
||||
;
|
||||
IN: 4DNav.space-file-decoder
|
||||
|
||||
: decode-number-array ( x -- y ) "," split [ string>number ] map ;
|
||||
|
||||
PROCESS: adsoda-read-model ( tag -- )
|
||||
|
||||
TAG: dimension adsoda-read-model children>> first string>number ;
|
||||
TAG: direction adsoda-read-model children>> first decode-number-array ;
|
||||
TAG: color adsoda-read-model children>> first decode-number-array ;
|
||||
TAG: name adsoda-read-model children>> first ;
|
||||
TAG: face adsoda-read-model children>> first decode-number-array ;
|
||||
|
||||
TAG: solid adsoda-read-model
|
||||
<solid> swap
|
||||
{
|
||||
[ "dimension" tag-named adsoda-read-model >>dimension ]
|
||||
[ "name" tag-named adsoda-read-model >>name ]
|
||||
[ "color" tag-named adsoda-read-model >>color ]
|
||||
[ "face" tags-named [ adsoda-read-model cut-solid ] each ]
|
||||
} cleave
|
||||
ensure-adjacencies
|
||||
;
|
||||
|
||||
TAG: light adsoda-read-model
|
||||
<light> swap
|
||||
{
|
||||
[ "direction" tag-named adsoda-read-model >>direction ]
|
||||
[ "color" tag-named adsoda-read-model >>color ]
|
||||
} cleave
|
||||
;
|
||||
|
||||
TAG: space adsoda-read-model
|
||||
<space> swap
|
||||
{
|
||||
[ "dimension" tag-named adsoda-read-model >>dimension ]
|
||||
[ "name" tag-named adsoda-read-model >>name ]
|
||||
[ "color" tag-named adsoda-read-model >>ambient-color ]
|
||||
[ "solid" tags-named [ adsoda-read-model suffix-solids ] each ]
|
||||
[ "light" tags-named [ adsoda-read-model suffix-lights ] each ]
|
||||
} cleave
|
||||
;
|
||||
|
||||
: read-model-file ( path -- x )
|
||||
dup
|
||||
[
|
||||
[ file>xml "space" tags-named first adsoda-read-model ]
|
||||
[ drop <space> ] recover
|
||||
] [ drop <space> ] if
|
||||
|
||||
;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
4DNav : simmple tool to navigate thru a 4D space view as projections on 4 3D spaces.
|
||||
|
|
@ -0,0 +1 @@
|
|||
4D viewer
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
<model>
|
||||
<space>
|
||||
<name>triancube</name>
|
||||
<dimension>4</dimension>
|
||||
<solid>
|
||||
<name>triancube</name>
|
||||
<dimension>4</dimension>
|
||||
<face>1,0,0,0,160</face>
|
||||
<face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>
|
||||
<face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>
|
||||
<face>0,0,1,0,140</face>
|
||||
<face>0,0,-1,0,-180</face>
|
||||
<face>0,0,0,1,110</face>
|
||||
<face>0,0,0,-1,-180</face>
|
||||
<color>0,1,0</color>
|
||||
</solid>
|
||||
<light>
|
||||
<direction>1,1,1,1</direction>
|
||||
<color>0.2,0.2,0.6</color>
|
||||
</light>
|
||||
<color>0.8,0.9,0.9</color>
|
||||
</space>
|
||||
</model>
|
||||
|
|
@ -0,0 +1 @@
|
|||
Eduardo Cavazos
|
||||
|
|
@ -0,0 +1,229 @@
|
|||
! Copyright (C) 2008 Jean-François Bigot.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays help.markup help.syntax kernel sequences ;
|
||||
IN: 4DNav.turtle
|
||||
|
||||
HELP: <turtle>
|
||||
{ $values
|
||||
|
||||
{ "turtle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: >turtle-ori
|
||||
{ $values
|
||||
{ "val" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: >turtle-pos
|
||||
{ $values
|
||||
{ "val" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: Rx
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Rz" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: Ry
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Ry" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: Rz
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
{ "Rx" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: V
|
||||
{ $values
|
||||
|
||||
{ "V" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: X
|
||||
{ $values
|
||||
|
||||
{ "3array" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: Y
|
||||
{ $values
|
||||
|
||||
{ "3array" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: Z
|
||||
{ $values
|
||||
|
||||
{ "3array" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: apply-rotation
|
||||
{ $values
|
||||
{ "rotation" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: distance
|
||||
{ $values
|
||||
{ "turtle" null } { "turtle" null }
|
||||
{ "n" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: move-by
|
||||
{ $values
|
||||
{ "point" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: pitch-down
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: pitch-up
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: reset-turtle
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: roll-left
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: roll-right
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: roll-until-horizontal
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: rotate-x
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: rotate-y
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: rotate-z
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: set-X
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: set-Y
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: set-Z
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: step-turtle
|
||||
{ $values
|
||||
{ "length" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: step-vector
|
||||
{ $values
|
||||
{ "length" null }
|
||||
{ "array" array }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: strafe-down
|
||||
{ $values
|
||||
{ "length" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: strafe-left
|
||||
{ $values
|
||||
{ "length" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: strafe-right
|
||||
{ $values
|
||||
{ "length" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: strafe-up
|
||||
{ $values
|
||||
{ "length" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: turn-left
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: turn-right
|
||||
{ $values
|
||||
{ "angle" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: turtle
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: turtle-ori>
|
||||
{ $values
|
||||
|
||||
{ "val" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: turtle-pos>
|
||||
{ $values
|
||||
|
||||
{ "val" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
ARTICLE: "4DNav.turtle" "4DNav.turtle"
|
||||
{ $vocab-link "4DNav.turtle" }
|
||||
;
|
||||
|
||||
ABOUT: "4DNav.turtle"
|
||||
|
|
@ -0,0 +1,152 @@
|
|||
USING: kernel math arrays math.vectors math.matrices
|
||||
namespaces make
|
||||
math.constants math.functions
|
||||
math.vectors
|
||||
splitting grouping self math.trig
|
||||
sequences accessors 4DNav.deep models ;
|
||||
IN: 4DNav.turtle
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: turtle pos ori ;
|
||||
|
||||
: <turtle> ( -- turtle )
|
||||
turtle new
|
||||
{ 0 0 0 } clone >>pos
|
||||
3 identity-matrix >>ori
|
||||
;
|
||||
|
||||
|
||||
TUPLE: observer < turtle projection-mode collision-mode ;
|
||||
|
||||
: <observer> ( -- object )
|
||||
observer new
|
||||
0 <model> >>projection-mode
|
||||
f <model> >>collision-mode
|
||||
;
|
||||
|
||||
|
||||
: turtle-pos> ( -- val ) self> pos>> ;
|
||||
: >turtle-pos ( val -- ) self> (>>pos) ;
|
||||
|
||||
: turtle-ori> ( -- val ) self> ori>> ;
|
||||
: >turtle-ori ( val -- ) self> (>>ori) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! These rotation matrices are from
|
||||
! `Computer Graphics: Principles and Practice'
|
||||
|
||||
|
||||
! waiting for deep-cleave-quots
|
||||
|
||||
! : Rz ( angle -- Rx ) deg>rad
|
||||
! { { [ cos ] [ sin neg ] 0 }
|
||||
! { [ sin ] [ cos ] 0 }
|
||||
! { 0 0 1 }
|
||||
! } deep-cleave-quots ;
|
||||
|
||||
! : Ry ( angle -- Ry ) deg>rad
|
||||
! { { [ cos ] 0 [ sin ] }
|
||||
! { 0 1 0 }
|
||||
! { [ sin neg ] 0 [ cos ] }
|
||||
! } deep-cleave-quots ;
|
||||
|
||||
! : Rx ( angle -- Rz ) deg>rad
|
||||
! { { 1 0 0 }
|
||||
! { 0 [ cos ] [ sin neg ] }
|
||||
! { 0 [ sin ] [ cos ] }
|
||||
! } deep-cleave-quots ;
|
||||
|
||||
: Rz ( angle -- Rx ) deg>rad
|
||||
[ dup cos , dup sin neg , 0 ,
|
||||
dup sin , dup cos , 0 ,
|
||||
0 , 0 , 1 , ] 3 make-matrix nip ;
|
||||
|
||||
: Ry ( angle -- Ry ) deg>rad
|
||||
[ dup cos , 0 , dup sin ,
|
||||
0 , 1 , 0 ,
|
||||
dup sin neg , 0 , dup cos , ] 3 make-matrix nip ;
|
||||
|
||||
: Rx ( angle -- Rz ) deg>rad
|
||||
[ 1 , 0 , 0 ,
|
||||
0 , dup cos , dup sin neg ,
|
||||
0 , dup sin , dup cos , ] 3 make-matrix nip ;
|
||||
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: apply-rotation ( rotation -- ) turtle-ori> swap m. >turtle-ori ;
|
||||
|
||||
: rotate-x ( angle -- ) Rx apply-rotation ;
|
||||
: rotate-y ( angle -- ) Ry apply-rotation ;
|
||||
: rotate-z ( angle -- ) Rz apply-rotation ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: pitch-up ( angle -- ) neg rotate-x ;
|
||||
: pitch-down ( angle -- ) rotate-x ;
|
||||
|
||||
: turn-left ( angle -- ) rotate-y ;
|
||||
: turn-right ( angle -- ) neg rotate-y ;
|
||||
|
||||
: roll-left ( angle -- ) neg rotate-z ;
|
||||
: roll-right ( angle -- ) rotate-z ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! roll-until-horizontal
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: V ( -- V ) { 0 1 0 } ;
|
||||
|
||||
: X ( -- 3array ) turtle-ori> [ first ] map ;
|
||||
: Y ( -- 3array ) turtle-ori> [ second ] map ;
|
||||
: Z ( -- 3array ) turtle-ori> [ third ] map ;
|
||||
|
||||
: set-X ( seq -- ) turtle-ori> [ set-first ] 2each ;
|
||||
: set-Y ( seq -- ) turtle-ori> [ set-second ] 2each ;
|
||||
: set-Z ( seq -- ) turtle-ori> [ set-third ] 2each ;
|
||||
|
||||
: roll-until-horizontal ( -- )
|
||||
V Z cross normalize set-X
|
||||
Z X cross normalize set-Y ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: distance ( turtle turtle -- n ) pos>> swap pos>> v- [ sq ] map sum sqrt ;
|
||||
|
||||
: move-by ( point -- ) turtle-pos> v+ >turtle-pos ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: reset-turtle ( -- )
|
||||
{ 0 0 0 } clone >turtle-pos 3 identity-matrix >turtle-ori ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: step-vector ( length -- array ) { 0 0 1 } n*v ;
|
||||
|
||||
: step-turtle ( length -- )
|
||||
step-vector turtle-ori> swap m.v turtle-pos> v+ >turtle-pos ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: strafe-up ( length -- )
|
||||
90 pitch-up
|
||||
step-turtle
|
||||
90 pitch-down ;
|
||||
|
||||
: strafe-down ( length -- )
|
||||
90 pitch-down
|
||||
step-turtle
|
||||
90 pitch-up ;
|
||||
|
||||
: strafe-left ( length -- )
|
||||
90 turn-left
|
||||
step-turtle
|
||||
90 turn-right ;
|
||||
|
||||
: strafe-right ( length -- )
|
||||
90 turn-right
|
||||
step-turtle
|
||||
90 turn-left ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeff Bigot
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
! Copyright (C) 2008 Jean-François Bigot.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel ;
|
||||
IN: 4DNav.window3D
|
||||
|
||||
HELP: <window3D>
|
||||
{ $values
|
||||
{ "model" null } { "observer" null }
|
||||
{ "gadget" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: window3D
|
||||
{ $description "" } ;
|
||||
|
||||
ARTICLE: "4DNav.window3D" "4DNav.window3D"
|
||||
{ $vocab-link "4DNav.window3D" }
|
||||
;
|
||||
|
||||
ABOUT: "4DNav.window3D"
|
||||
|
|
@ -0,0 +1,82 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel
|
||||
ui.gadgets
|
||||
ui.render
|
||||
opengl
|
||||
opengl.gl
|
||||
opengl.glu
|
||||
4DNav.camera
|
||||
4DNav.turtle
|
||||
math
|
||||
values
|
||||
alien.c-types
|
||||
accessors
|
||||
namespaces
|
||||
adsoda
|
||||
models
|
||||
accessors
|
||||
prettyprint
|
||||
;
|
||||
|
||||
IN: 4DNav.window3D
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! drawing functions
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: window3D < gadget observer ;
|
||||
|
||||
: <window3D> ( model observer -- gadget )
|
||||
window3D new-gadget
|
||||
swap 2dup
|
||||
projection-mode>> add-connection
|
||||
2dup
|
||||
collision-mode>> add-connection
|
||||
>>observer
|
||||
swap <model> >>model
|
||||
t >>root?
|
||||
;
|
||||
|
||||
M: window3D pref-dim* ( gadget -- dim ) drop { 300 300 } ;
|
||||
|
||||
M: window3D draw-gadget* ( gadget -- )
|
||||
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
0.6 0.6 0.6 .9 glClearColor
|
||||
dup observer>> projection-mode>> value>> 1 =
|
||||
[ 60.0 1.0 0.1 3000.0 gluPerspective ]
|
||||
[ -400.0 400.0 -400.0 400.0 0.0 4000.0 glOrtho ] if
|
||||
dup observer>> collision-mode>> value>>
|
||||
\ remove-hidden-solids?
|
||||
set-value
|
||||
dup observer>> do-look-at
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
0.9 0.9 0.9 1.0 glClearColor
|
||||
1.0 glClearDepth
|
||||
GL_LINE_SMOOTH glEnable
|
||||
GL_BLEND glEnable
|
||||
GL_DEPTH_TEST glEnable
|
||||
GL_LEQUAL glDepthFunc
|
||||
GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
|
||||
GL_LINE_SMOOTH_HINT GL_NICEST glHint
|
||||
1.25 glLineWidth
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
glLoadIdentity
|
||||
GL_LIGHTING glEnable
|
||||
GL_LIGHT0 glEnable
|
||||
GL_COLOR_MATERIAL glEnable
|
||||
GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
|
||||
! *************************
|
||||
|
||||
model>> value>>
|
||||
[ space->GL ] when*
|
||||
|
||||
! *************************
|
||||
;
|
||||
|
||||
M: window3D graft* drop ;
|
||||
|
||||
M: window3D model-changed nip relayout ;
|
||||
|
|
@ -0,0 +1,300 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax ;
|
||||
|
||||
IN: adsoda
|
||||
|
||||
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! faces
|
||||
! --------------------------------------------------------------
|
||||
ARTICLE: "face-page" "face in ADSODA"
|
||||
"explanation of faces"
|
||||
$nl
|
||||
"link to functions"
|
||||
"what is an halfspace"
|
||||
"halfspace touching-corners adjacent-faces"
|
||||
"touching-corners list of pointers to the corners which touch this face\n"
|
||||
|
||||
"adjacent-faces list of pointers to the faces which touch this face\n"
|
||||
{ $subsection face }
|
||||
{ $subsection <face> }
|
||||
"test relative position"
|
||||
{ $subsection point-inside-or-on-face? }
|
||||
{ $subsection point-inside-face? }
|
||||
"handling face"
|
||||
{ $subsection flip-face }
|
||||
{ $subsection face-translate }
|
||||
{ $subsection face-transform }
|
||||
|
||||
;
|
||||
|
||||
HELP: face
|
||||
{ $class-description "a face is defined by"
|
||||
{ $list "halfspace equation" }
|
||||
{ $list "list of touching corners" }
|
||||
{ $list "list of adjacent faces" }
|
||||
$nl
|
||||
"Touching corners and adjacent faces are defined by algorithm thanks to other faces of the solid"
|
||||
}
|
||||
|
||||
|
||||
;
|
||||
HELP: <face>
|
||||
{ $values { "v" "an halfspace equation" } { "tuple" "a face" } } ;
|
||||
HELP: flip-face
|
||||
{ $values { "face" "a face" } { "face" "flipped face" } }
|
||||
{ $description "change the orientation of a face" }
|
||||
;
|
||||
|
||||
HELP: face-translate
|
||||
{ $values { "face" "a face" } { "v" "a vector" } }
|
||||
{ $description
|
||||
"translate a face following a vector"
|
||||
$nl
|
||||
"a translation of an halfspace doesn't change the normal vector. this word just compute the new constant term" }
|
||||
|
||||
|
||||
;
|
||||
HELP: face-transform
|
||||
{ $values { "face" "a face" } { "m" "a transformation matrix" } }
|
||||
{ $description "compute the transformation of a face using a transformation matrix" }
|
||||
|
||||
;
|
||||
! --------------------------------
|
||||
! solid
|
||||
! --------------------------------------------------------------
|
||||
ARTICLE: "solid-page" "solid in ADSODA"
|
||||
"explanation of solids"
|
||||
$nl
|
||||
"link to functions"
|
||||
{ $subsection solid }
|
||||
{ $subsection <solid> }
|
||||
"test relative position"
|
||||
{ $subsection point-inside-solid? }
|
||||
{ $subsection point-inside-or-on-solid? }
|
||||
"playing with faces and solids"
|
||||
{ $subsection add-face }
|
||||
{ $subsection cut-solid }
|
||||
{ $subsection slice-solid }
|
||||
"solid handling"
|
||||
{ $subsection solid-project }
|
||||
{ $subsection solid-translate }
|
||||
{ $subsection solid-transform }
|
||||
{ $subsection subtract }
|
||||
|
||||
{ $subsection get-silhouette }
|
||||
|
||||
{ $subsection solid= }
|
||||
|
||||
|
||||
;
|
||||
|
||||
HELP: solid
|
||||
{ $class-description "dimension" $nl "silhouettes" $nl "faces" $nl "corners" $nl "adjacencies-valid" $nl "color" $nl "name"
|
||||
}
|
||||
;
|
||||
|
||||
HELP: add-face
|
||||
{ $values { "solid" "a solid" } { "face" "a face" } }
|
||||
{ $description "reshape a solid with a face. The face truncate the solid." } ;
|
||||
|
||||
HELP: cut-solid
|
||||
{ $values { "solid" "a solid" } { "halfspace" "an halfspace" } }
|
||||
{ $description "like add-face but just with halfspace equation" } ;
|
||||
|
||||
HELP: slice-solid
|
||||
{ $values { "solid" "a solid" } { "face" "a face" } { "solid1" "the outer part of the former solid" } { "solid2" "the inner part of the former solid" } }
|
||||
{ $description "cut a solid into two parts. The face acts like a knife"
|
||||
} ;
|
||||
|
||||
|
||||
HELP: solid-project
|
||||
{ $values { "lights" "lights" } { "ambient" "ambient" } { "solid" "solid" } { "solids" "projection of solid" } }
|
||||
{ $description "Project the solid using pv vector"
|
||||
$nl
|
||||
"TODO: explain how to use lights"
|
||||
} ;
|
||||
|
||||
HELP: solid-translate
|
||||
{ $values { "solid" "a solid" } { "v" "translating vector" } }
|
||||
{ $description "Translate a solid using a vector"
|
||||
$nl
|
||||
"v and solid must have the same dimension "
|
||||
} ;
|
||||
|
||||
HELP: solid-transform
|
||||
{ $values { "solid" "a solid" } { "m" "transformation matrix" } }
|
||||
{ $description "Transform a solid using a matrix"
|
||||
$nl
|
||||
"v and solid must have the same dimension "
|
||||
} ;
|
||||
|
||||
HELP: subtract
|
||||
{ $values { "solid1" "initial shape" } { "solid2" "shape to remove" } { "solids" "resulting shape" } }
|
||||
{ $description " " } ;
|
||||
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! space
|
||||
! --------------------------------------------------------------
|
||||
ARTICLE: "space-page" "space in ADSODA"
|
||||
"A space is a collection of solids and lights."
|
||||
$nl
|
||||
"link to functions"
|
||||
$nl
|
||||
"Defining words"
|
||||
{ $subsection space }
|
||||
{ $subsection <space> }
|
||||
{ $subsection suffix-solids }
|
||||
{ $subsection suffix-lights }
|
||||
{ $subsection clear-space-solids }
|
||||
{ $subsection describe-space }
|
||||
|
||||
|
||||
"Handling space"
|
||||
{ $subsection space-ensure-solids }
|
||||
{ $subsection eliminate-empty-solids }
|
||||
{ $subsection space-transform }
|
||||
{ $subsection space-translate }
|
||||
{ $subsection remove-hidden-solids }
|
||||
{ $subsection space-project }
|
||||
|
||||
|
||||
;
|
||||
|
||||
HELP: space
|
||||
{ $class-description
|
||||
"dimension" $nl " solids" $nl " ambient-color" $nl "lights"
|
||||
}
|
||||
;
|
||||
|
||||
HELP: suffix-solids
|
||||
"( space solid -- space )"
|
||||
{ $values { "space" "a space" } { "solid" "a solid to add" } }
|
||||
{ $description "Add solid to space definition" } ;
|
||||
|
||||
HELP: suffix-lights
|
||||
"( space light -- space ) "
|
||||
{ $values { "space" "a space" } { "light" "a light to add" } }
|
||||
{ $description "Add a light to space definition" } ;
|
||||
|
||||
HELP: clear-space-solids
|
||||
"( space -- space )"
|
||||
{ $values { "space" "a space" } }
|
||||
{ $description "remove all solids in space" } ;
|
||||
|
||||
HELP: space-ensure-solids
|
||||
{ $values { "space" "a space" } }
|
||||
{ $description "rebuild corners of all solids in space" } ;
|
||||
|
||||
|
||||
|
||||
HELP: space-transform
|
||||
" ( space m -- space )"
|
||||
{ $values { "space" "a space" } { "m" "a matrix" } }
|
||||
{ $description "Transform a space using a matrix" } ;
|
||||
|
||||
HELP: space-translate
|
||||
{ $values { "space" "a space" } { "v" "a vector" } }
|
||||
{ $description "Translate a space following a vector" } ;
|
||||
|
||||
HELP: describe-space " ( space -- )"
|
||||
{ $values { "space" "a space" } }
|
||||
{ $description "return a description of space" } ;
|
||||
|
||||
HELP: space-project
|
||||
{ $values { "space" "a space" } { "i" "an integer" } }
|
||||
{ $description "Project a space along ith coordinate" } ;
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! 3D rendering
|
||||
! --------------------------------------------------------------
|
||||
ARTICLE: "3D-rendering-page" "3D rendering in ADSODA"
|
||||
"explanation of 3D rendering"
|
||||
$nl
|
||||
"link to functions"
|
||||
{ $subsection face->GL }
|
||||
{ $subsection solid->GL }
|
||||
{ $subsection space->GL }
|
||||
|
||||
;
|
||||
|
||||
HELP: face->GL
|
||||
{ $values { "face" "a face" } { "color" "3 3 values array" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: solid->GL
|
||||
{ $values { "solid" "a solid" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: space->GL
|
||||
{ $values { "space" "a space" } }
|
||||
{ $description "" } ;
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! light
|
||||
! --------------------------------------------------------------
|
||||
|
||||
ARTICLE: "light-page" "light in ADSODA"
|
||||
"explanation of light"
|
||||
$nl
|
||||
"link to functions"
|
||||
;
|
||||
|
||||
ARTICLE: { "adsoda" "light" } "ADSODA : lights"
|
||||
"! HELP: light position color"
|
||||
"! <light> ( -- tuple ) light new ;"
|
||||
|
||||
"! light est un vecteur avec 3 variables pour les couleurs\n"
|
||||
|
||||
" void Light::Apply(Vector& normal, double &cRed, double &cGreen, double &cBlue)\n"
|
||||
" { \n"
|
||||
" // Dot the light direction with the normalized normal of Face."
|
||||
" register double intensity = -(normal * (*this));"
|
||||
|
||||
" // Face is a backface, from light's perspective"
|
||||
" if (intensity < 0)"
|
||||
" return;"
|
||||
" "
|
||||
" // Add the intensity componentwise"
|
||||
" cRed += red * intensity;"
|
||||
" cGreen += green * intensity;"
|
||||
" cBlue += blue * intensity;"
|
||||
|
||||
" // Clip to unit range"
|
||||
" if (cRed > 1.0) cRed = 1.0;"
|
||||
" if (cGreen > 1.0) cGreen = 1.0;"
|
||||
" if (cBlue > 1.0) cBlue = 1.0;"
|
||||
|
||||
|
||||
;
|
||||
|
||||
|
||||
|
||||
ARTICLE: { "adsoda" "halfspace" } "ADSODA : halfspace"
|
||||
"! demi espace défini par un vecteur normal et une constante"
|
||||
" defined by the concatenation of the normal vector and a constant"
|
||||
;
|
||||
|
||||
|
||||
|
||||
ARTICLE: "adsoda-main-page" "ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm"
|
||||
"multidimensional handler :"
|
||||
$nl
|
||||
"design a solid using face delimitations. Only works on convex shapes"
|
||||
$nl
|
||||
{ $emphasis "written in C++ by Greg Ferrar" }
|
||||
$nl
|
||||
"full explanation on adsoda page at " { $url "http://www.flowerfire.com/ADSODA/" }
|
||||
$nl
|
||||
"Useful words are describe on the following pages: "
|
||||
{ $subsection "face-page" }
|
||||
{ $subsection "solid-page" }
|
||||
{ $subsection "space-page" }
|
||||
{ $subsection "light-page" }
|
||||
{ $subsection "3D-rendering-page" }
|
||||
;
|
||||
|
||||
ABOUT: "adsoda-main-page"
|
||||
|
|
@ -0,0 +1,310 @@
|
|||
USING: adsoda
|
||||
kernel
|
||||
math
|
||||
accessors
|
||||
sequences
|
||||
adsoda.solution2
|
||||
fry
|
||||
tools.test
|
||||
arrays ;
|
||||
|
||||
IN: adsoda.tests
|
||||
|
||||
|
||||
|
||||
: s1 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"s1" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 -1 -5 } cut-solid
|
||||
{ -1 -1 -21 } cut-solid
|
||||
{ -1 0 -12 } cut-solid
|
||||
{ 1 2 16 } cut-solid
|
||||
;
|
||||
: solid1 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid1" >>name
|
||||
{ 1 -1 -5 } cut-solid
|
||||
{ -1 -1 -21 } cut-solid
|
||||
{ -1 0 -12 } cut-solid
|
||||
{ 1 2 16 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
: solid2 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid2" >>name
|
||||
{ -1 1 -10 } cut-solid
|
||||
{ -1 -1 -28 } cut-solid
|
||||
{ 1 0 13 } cut-solid
|
||||
! { 1 2 16 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
|
||||
: solid3 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid3" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 0 16 } cut-solid
|
||||
{ -1 0 -36 } cut-solid
|
||||
{ 0 1 1 } cut-solid
|
||||
{ 0 -1 -17 } cut-solid
|
||||
! { 1 2 16 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
|
||||
;
|
||||
|
||||
: solid4 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid4" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 0 21 } cut-solid
|
||||
{ -1 0 -36 } cut-solid
|
||||
{ 0 1 1 } cut-solid
|
||||
{ 0 -1 -17 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
|
||||
: solid5 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid5" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 0 6 } cut-solid
|
||||
{ -1 0 -17 } cut-solid
|
||||
{ 0 1 17 } cut-solid
|
||||
{ 0 -1 -19 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
|
||||
: solid7 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid7" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 0 38 } cut-solid
|
||||
{ 1 -5 -66 } cut-solid
|
||||
{ -2 1 -75 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
|
||||
: solid6s ( -- seq )
|
||||
solid3 clone solid2 clone subtract
|
||||
;
|
||||
|
||||
: space1 ( -- space )
|
||||
<space>
|
||||
2 >>dimension
|
||||
! solid3 suffix-solids
|
||||
solid1 suffix-solids
|
||||
solid2 suffix-solids
|
||||
! solid6s [ suffix-solids ] each
|
||||
solid4 suffix-solids
|
||||
! solid5 suffix-solids
|
||||
solid7 suffix-solids
|
||||
{ 1 1 1 } >>ambient-color
|
||||
<light>
|
||||
{ -100 -100 } >>position
|
||||
{ 0.2 0.7 0.1 } >>color
|
||||
suffix-lights
|
||||
;
|
||||
|
||||
: space2 ( -- space )
|
||||
<space>
|
||||
4 >>dimension
|
||||
! 4cube suffix-solids
|
||||
{ 1 1 1 } >>ambient-color
|
||||
<light>
|
||||
{ -100 -100 } >>position
|
||||
{ 0.2 0.7 0.1 } >>color
|
||||
suffix-lights
|
||||
|
||||
;
|
||||
|
||||
|
||||
|
||||
! {
|
||||
! { 1 0 0 0 }
|
||||
! { 0 1 0 0 }
|
||||
! { 0 0 0.984807753012208 -0.1736481776669303 }
|
||||
! { 0 0 0.1736481776669303 0.984807753012208 }
|
||||
! }
|
||||
|
||||
! ------------------------------------------------------------
|
||||
! constant+
|
||||
[ { 1 2 5 } ] [ { 1 2 3 } 2 constant+ ] unit-test
|
||||
|
||||
! ------------------------------------------------------------
|
||||
! translate
|
||||
[ { 1 -1 0 } ] [ { 1 -1 -5 } { 3 -2 } translate ] unit-test
|
||||
|
||||
! ------------------------------------------------------------
|
||||
! transform
|
||||
[ { -1 -1 -5 21.0 } ] [ { -1 -1 -5 21 }
|
||||
{ { 1 0 0 }
|
||||
{ 0 1 0 }
|
||||
{ 0 0 1 }
|
||||
} transform
|
||||
] unit-test
|
||||
|
||||
! ------------------------------------------------------------
|
||||
! compare-nleft-to-identity-matrix
|
||||
[ t ] [
|
||||
{
|
||||
{ 1 0 0 1232 }
|
||||
{ 0 1 0 0 321 }
|
||||
{ 0 0 1 0 } }
|
||||
3 compare-nleft-to-identity-matrix
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
{ { 1 0 0 } { 0 1 0 } { 0 0 0 } }
|
||||
3 compare-nleft-to-identity-matrix
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
{ { 2 0 0 } { 0 1 0 } { 0 0 1 } }
|
||||
3 compare-nleft-to-identity-matrix
|
||||
] unit-test
|
||||
! ------------------------------------------------------------
|
||||
[ t ] [
|
||||
{ { 1 0 0 }
|
||||
{ 0 1 0 }
|
||||
{ 0 0 1 } } 3 valid-solution?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
{ { 1 0 0 1 }
|
||||
{ 0 0 0 1 }
|
||||
{ 0 0 1 0 } } 3 valid-solution?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
{ { 1 0 0 1 }
|
||||
{ 0 0 0 1 } } 3 valid-solution?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
{ { 1 0 0 1 }
|
||||
{ 0 0 0 1 }
|
||||
{ 0 0 1 0 } } 2 valid-solution?
|
||||
] unit-test
|
||||
|
||||
! ------------------------------------------------------------
|
||||
[ 3 ] [ { 1 2 3 } last ] unit-test
|
||||
|
||||
[ { 1 2 5 } ] [ { 1 2 3 } dup [ 2 + ] change-last ] unit-test
|
||||
|
||||
! ------------------------------------------------------------
|
||||
! position-point
|
||||
[ 0 ] [
|
||||
{ 1 -1 -5 } { 2 7 } position-point
|
||||
] unit-test
|
||||
|
||||
! ------------------------------------------------------------
|
||||
|
||||
! transform
|
||||
! TODO construire un exemple
|
||||
|
||||
|
||||
! ------------------------------------------------------------
|
||||
! slice-solid
|
||||
|
||||
! ------------------------------------------------------------
|
||||
! solve-equation
|
||||
! deux cas de tests, avec solution et sans solution
|
||||
|
||||
[ { 2 7 } ]
|
||||
[ { { 1 -1 -5 } { 1 2 16 } } intersect-hyperplanes ]
|
||||
unit-test
|
||||
|
||||
[ f ]
|
||||
[ { { 1 -1 -5 } { 1 2 16 } { -1 -1 -21 } } intersect-hyperplanes ]
|
||||
unit-test
|
||||
|
||||
[ f ]
|
||||
[ { { 1 0 -5 } { 1 0 16 } } intersect-hyperplanes ]
|
||||
unit-test
|
||||
|
||||
! ------------------------------------------------------------
|
||||
! point-inside-halfspace
|
||||
[ t ] [ { 1 -1 -5 } { 0 0 } point-inside-halfspace? ]
|
||||
unit-test
|
||||
[ f ] [ { 1 -1 -5 } { 8 13 } point-inside-halfspace? ]
|
||||
unit-test
|
||||
[ t ] [ { 1 -1 -5 } { 8 13 } point-inside-or-on-halfspace? ]
|
||||
unit-test
|
||||
|
||||
|
||||
! ------------------------------
|
||||
! order solid
|
||||
|
||||
[ 1 ] [ 0 >pv solid1 solid2 order-solid ] unit-test
|
||||
[ -1 ] [ 0 >pv solid2 solid1 order-solid ] unit-test
|
||||
[ f ] [ 1 >pv solid1 solid2 order-solid ] unit-test
|
||||
[ f ] [ 1 >pv solid2 solid1 order-solid ] unit-test
|
||||
|
||||
|
||||
! clip-solid
|
||||
[ { { 13 15 } { 15 13 } { 13 13 } } ]
|
||||
[ 0 >pv solid2 solid1 clip-solid first corners>> ] unit-test
|
||||
|
||||
solid1 corners>> '[ _ ]
|
||||
[ 0 >pv solid1 solid1 clip-solid first corners>> ] unit-test
|
||||
|
||||
solid1 corners>> '[ _ ]
|
||||
[ 0 >pv solid1 solid2 clip-solid first corners>> ] unit-test
|
||||
|
||||
solid1 corners>> '[ _ ]
|
||||
[ 1 >pv solid1 solid2 clip-solid first corners>> ] unit-test
|
||||
solid2 corners>> '[ _ ]
|
||||
[ 1 >pv solid2 solid1 clip-solid first corners>> ] unit-test
|
||||
|
||||
!
|
||||
[
|
||||
{
|
||||
{ { 13 15 } { 15 13 } { 13 13 } }
|
||||
{ { 16 17 } { 16 13 } { 36 17 } { 36 13 } }
|
||||
{ { 16 1 } { 16 2 } { 36 1 } { 36 2 } }
|
||||
}
|
||||
] [ 0 >pv solid2 solid3 2array
|
||||
solid1 (solids-silhouette-subtract)
|
||||
[ corners>> ] map
|
||||
] unit-test
|
||||
|
||||
|
||||
[
|
||||
{
|
||||
{ { 8 13 } { 2 7 } { 12 9 } { 12 2 } }
|
||||
{ { 13 15 } { 15 13 } { 13 13 } }
|
||||
{ { 16 17 } { 16 15 } { 36 17 } { 36 15 } }
|
||||
{ { 16 1 } { 16 2 } { 36 1 } { 36 2 } }
|
||||
}
|
||||
] [
|
||||
0 >pv <space> solid1 suffix-solids
|
||||
solid2 suffix-solids
|
||||
solid3 suffix-solids
|
||||
remove-hidden-solids
|
||||
solids>> [ corners>> ] map
|
||||
] unit-test
|
||||
|
||||
! { }
|
||||
! { }
|
||||
! <light> { 0.2 0.3 0.4 } >>color { 1 -1 1 } >>direction suffix
|
||||
! <light> { 0.4 0.3 0.1 } >>color { -1 -1 -1 } >>direction suffix
|
||||
! suffix
|
||||
! { 0.1 0.1 0.1 } suffix ! ambient color
|
||||
! { 0.23 0.32 0.17 } suffix ! solid color
|
||||
! solid3 faces>> first
|
||||
|
||||
! enlight-projection
|
||||
|
|
@ -0,0 +1,543 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors
|
||||
arrays
|
||||
assocs
|
||||
combinators
|
||||
kernel
|
||||
fry
|
||||
math
|
||||
math.constants
|
||||
math.functions
|
||||
math.libm
|
||||
math.order
|
||||
math.vectors
|
||||
math.matrices
|
||||
math.parser
|
||||
namespaces
|
||||
prettyprint
|
||||
sequences
|
||||
sequences.deep
|
||||
sets
|
||||
slots
|
||||
sorting
|
||||
tools.time
|
||||
vars
|
||||
continuations
|
||||
words
|
||||
opengl
|
||||
opengl.gl
|
||||
colors
|
||||
adsoda.solution2
|
||||
adsoda.combinators
|
||||
opengl.demo-support
|
||||
values
|
||||
tools.walker
|
||||
;
|
||||
|
||||
IN: adsoda
|
||||
|
||||
DEFER: combinations
|
||||
VAR: pv
|
||||
|
||||
|
||||
! ---------------------------------------------------------------------
|
||||
! global values
|
||||
VALUE: remove-hidden-solids?
|
||||
VALUE: VERY-SMALL-NUM
|
||||
VALUE: ZERO-VALUE
|
||||
VALUE: MAX-FACE-PER-CORNER
|
||||
|
||||
t to: remove-hidden-solids?
|
||||
0.0000001 to: VERY-SMALL-NUM
|
||||
0.0000001 to: ZERO-VALUE
|
||||
4 to: MAX-FACE-PER-CORNER
|
||||
! ---------------------------------------------------------------------
|
||||
! sequence complement
|
||||
|
||||
: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline
|
||||
|
||||
: dimension ( array -- x ) length 1- ; inline
|
||||
: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline
|
||||
: change-last ( seq quot -- ) [ [ dimension ] keep ] dip change-nth ;
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! light
|
||||
! --------------------------------------------------------------
|
||||
|
||||
TUPLE: light name { direction array } color ;
|
||||
: <light> ( -- tuple ) light new ;
|
||||
|
||||
! -----------------------------------------------------------------------
|
||||
! halfspace manipulation
|
||||
! -----------------------------------------------------------------------
|
||||
|
||||
: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;
|
||||
: translate ( u v -- w ) dupd v* sum constant+ ;
|
||||
|
||||
: transform ( u matrix -- w )
|
||||
[ swap m.v ] 2keep ! compute new normal vector
|
||||
[
|
||||
[ [ abs ZERO-VALUE > ] find ] keep ! find a point on the frontier
|
||||
! be sure it's not null vector
|
||||
last ! get constant
|
||||
swap /f neg swap ! intercept value
|
||||
] dip
|
||||
flip
|
||||
nth
|
||||
[ * ] with map ! apply intercep value
|
||||
over v*
|
||||
sum neg
|
||||
suffix ! add value as constant at the end of equation
|
||||
;
|
||||
|
||||
: position-point ( halfspace v -- x )
|
||||
-1 suffix v* sum ; inline
|
||||
: point-inside-halfspace? ( halfspace v -- ? )
|
||||
position-point VERY-SMALL-NUM > ;
|
||||
: point-inside-or-on-halfspace? ( halfspace v -- ? )
|
||||
position-point VERY-SMALL-NUM neg > ;
|
||||
: project-vector ( seq -- seq ) pv> [ head ] [ 1+ tail ] 2bi append ;
|
||||
: get-intersection ( matrice -- seq ) [ 1 tail* ] map flip first ;
|
||||
|
||||
: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;
|
||||
|
||||
: compare-nleft-to-identity-matrix ( seq n -- ? )
|
||||
[ [ head ] curry map ] keep identity-matrix m-
|
||||
flatten
|
||||
[ abs ZERO-VALUE < ] all?
|
||||
;
|
||||
|
||||
: valid-solution? ( matrice n -- ? )
|
||||
islenght=?
|
||||
[ compare-nleft-to-identity-matrix ]
|
||||
[ 2drop f ] if ; inline
|
||||
|
||||
: intersect-hyperplanes ( matrice -- seq )
|
||||
[ solution dup ] [ first dimension ] bi
|
||||
valid-solution? [ get-intersection ] [ drop f ] if ;
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! faces
|
||||
! --------------------------------------------------------------
|
||||
|
||||
TUPLE: face { halfspace array } touching-corners adjacent-faces ;
|
||||
: <face> ( v -- tuple ) face new swap >>halfspace ;
|
||||
: flip-face ( face -- face ) [ vneg ] change-halfspace ;
|
||||
: erase-face-touching-corners ( face -- face ) f >>touching-corners ;
|
||||
: erase-face-adjacent-faces ( face -- face ) f >>adjacent-faces ;
|
||||
: faces-intersection ( faces -- v )
|
||||
[ halfspace>> ] map intersect-hyperplanes ;
|
||||
: face-translate ( face v -- face )
|
||||
[ translate ] curry change-halfspace ; inline
|
||||
: face-transform ( face m -- face )
|
||||
[ transform ] curry change-halfspace ; inline
|
||||
: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;
|
||||
: backface? ( face -- face ? ) dup face-orientation 0 <= ;
|
||||
: pv-factor ( face -- f face )
|
||||
halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline
|
||||
: suffix-touching-corner ( face corner -- face )
|
||||
[ suffix ] curry change-touching-corners ; inline
|
||||
: real-face? ( face -- ? )
|
||||
[ touching-corners>> length ] [ halfspace>> dimension ] bi >= ;
|
||||
|
||||
: (add-to-adjacent-faces) ( face face -- face )
|
||||
over adjacent-faces>> 2dup member?
|
||||
[ 2drop ] [ swap suffix >>adjacent-faces ] if ;
|
||||
|
||||
: add-to-adjacent-faces ( face face -- face )
|
||||
2dup = [ drop ] [ (add-to-adjacent-faces) ] if ;
|
||||
|
||||
: update-adjacent-faces ( faces corner -- )
|
||||
'[ [ _ suffix-touching-corner drop ] each ] keep
|
||||
2 among [
|
||||
[ first ] keep second
|
||||
[ add-to-adjacent-faces drop ] 2keep
|
||||
swap add-to-adjacent-faces drop
|
||||
] each ; inline
|
||||
|
||||
: face-project-dim ( face -- x ) halfspace>> length 2 - ;
|
||||
|
||||
: apply-light ( color light normal -- u )
|
||||
over direction>> v.
|
||||
neg dup 0 >
|
||||
[
|
||||
[ color>> swap ] dip
|
||||
[ * ] curry map v+
|
||||
[ 1 min ] map
|
||||
]
|
||||
[ 2drop ]
|
||||
if
|
||||
;
|
||||
|
||||
: enlight-projection ( array face -- color )
|
||||
! array = lights + ambient color
|
||||
[ [ third ] [ second ] [ first ] tri ]
|
||||
[ halfspace>> project-vector normalize ] bi*
|
||||
[ apply-light ] curry each
|
||||
v*
|
||||
;
|
||||
|
||||
: (intersection-into-face) ( face-init face-adja quot -- face )
|
||||
[
|
||||
[ [ pv-factor ] bi@
|
||||
roll
|
||||
[ map ] 2bi@
|
||||
v-
|
||||
] 2keep
|
||||
[ touching-corners>> ] bi@
|
||||
[ swap [ = ] curry find nip f = ] curry find nip
|
||||
] dip over
|
||||
[
|
||||
call
|
||||
dupd
|
||||
point-inside-halfspace? [ vneg ] unless
|
||||
<face>
|
||||
] [ 3drop f ] if
|
||||
; inline
|
||||
|
||||
: intersection-into-face ( face-init face-adja -- face )
|
||||
[ [ project-vector ] bi@ ] (intersection-into-face) ;
|
||||
|
||||
: intersection-into-silhouette-face ( face-init face-adja -- face )
|
||||
[ ] (intersection-into-face) ;
|
||||
|
||||
: intersections-into-faces ( face -- faces )
|
||||
clone dup adjacent-faces>> [ intersection-into-face ] with map
|
||||
[ ] filter ;
|
||||
|
||||
: (face-silhouette) ( face -- faces )
|
||||
clone dup adjacent-faces>>
|
||||
[ backface?
|
||||
[ intersection-into-silhouette-face ] [ 2drop f ] if
|
||||
] with map
|
||||
[ ] filter
|
||||
; inline
|
||||
|
||||
: face-silhouette ( face -- faces )
|
||||
backface? [ drop f ] [ (face-silhouette) ] if ;
|
||||
|
||||
! --------------------------------
|
||||
! solid
|
||||
! --------------------------------------------------------------
|
||||
TUPLE: solid dimension silhouettes faces corners adjacencies-valid color name ;
|
||||
|
||||
: <solid> ( -- tuple ) solid new ;
|
||||
|
||||
: suffix-silhouettes ( solid silhouette -- solid )
|
||||
[ suffix ] curry change-silhouettes ;
|
||||
|
||||
: suffix-face ( solid face -- solid ) [ suffix ] curry change-faces ;
|
||||
|
||||
: suffix-corner ( solid corner -- solid ) [ suffix ] curry change-corners ;
|
||||
|
||||
: erase-solid-corners ( solid -- solid ) f >>corners ;
|
||||
|
||||
: erase-silhouettes ( solid -- solid ) dup dimension>> f <array> >>silhouettes ;
|
||||
|
||||
: filter-real-faces ( solid -- solid ) [ [ real-face? ] filter ] change-faces ;
|
||||
|
||||
: initiate-solid-from-face ( face -- solid )
|
||||
face-project-dim <solid> swap >>dimension ;
|
||||
|
||||
: erase-old-adjacencies ( solid -- solid )
|
||||
erase-solid-corners
|
||||
[ dup [ erase-face-touching-corners erase-face-adjacent-faces drop ] each ]
|
||||
change-faces ;
|
||||
|
||||
: point-inside-or-on-face? ( face v -- ? )
|
||||
[ halfspace>> ] dip point-inside-or-on-halfspace? ;
|
||||
|
||||
: point-inside-face? ( face v -- ? )
|
||||
[ halfspace>> ] dip point-inside-halfspace? ;
|
||||
|
||||
: point-inside-solid? ( solid point -- ? )
|
||||
[ faces>> ] dip [ point-inside-face? ] curry all? ; inline
|
||||
|
||||
: point-inside-or-on-solid? ( solid point -- ? )
|
||||
[ faces>> ] dip [ point-inside-or-on-face? ] curry all? ; inline
|
||||
|
||||
: unvalid-adjacencies ( solid -- solid )
|
||||
erase-old-adjacencies f >>adjacencies-valid erase-silhouettes ;
|
||||
|
||||
: add-face ( solid face -- solid )
|
||||
suffix-face unvalid-adjacencies ;
|
||||
|
||||
: cut-solid ( solid halfspace -- solid ) <face> add-face ;
|
||||
|
||||
: slice-solid ( solid face -- solid1 solid2 )
|
||||
[ [ clone ] bi@ flip-face add-face
|
||||
[ "/outer/" append ] change-name ] 2keep
|
||||
add-face [ "/inner/" append ] change-name ;
|
||||
|
||||
! -------------
|
||||
|
||||
|
||||
: add-silhouette ( solid -- solid )
|
||||
dup
|
||||
! find-adjacencies
|
||||
faces>> { }
|
||||
[ face-silhouette append ] reduce
|
||||
[ ] filter
|
||||
<solid>
|
||||
swap >>faces
|
||||
over dimension>> >>dimension
|
||||
over name>> " silhouette " append
|
||||
pv> number>string append
|
||||
>>name
|
||||
! ensure-adjacencies
|
||||
suffix-silhouettes ; inline
|
||||
|
||||
: find-silhouettes ( solid -- solid )
|
||||
{ } >>silhouettes
|
||||
dup dimension>> [ [ add-silhouette ] with-pv ] each ;
|
||||
|
||||
: ensure-silhouettes ( solid -- solid )
|
||||
dup silhouettes>> [ f = ] all?
|
||||
[ find-silhouettes ] when ;
|
||||
|
||||
! ------------
|
||||
|
||||
: corner-added? ( solid corner -- ? )
|
||||
! add corner to solid if it is inside solid
|
||||
[ ]
|
||||
[ point-inside-or-on-solid? ]
|
||||
[ swap corners>> member? not ]
|
||||
2tri and
|
||||
[ suffix-corner drop t ] [ 2drop f ] if ;
|
||||
|
||||
: process-corner ( solid faces corner -- )
|
||||
swapd
|
||||
[ corner-added? ] keep swap ! test if corner is inside solid
|
||||
[ update-adjacent-faces ]
|
||||
[ 2drop ]
|
||||
if ;
|
||||
|
||||
: compute-intersection ( solid faces -- )
|
||||
dup faces-intersection
|
||||
dup f = [ 3drop ] [ process-corner ] if ;
|
||||
|
||||
: test-faces-combinaisons ( solid n -- )
|
||||
[ dup faces>> ] dip among
|
||||
[ compute-intersection ] with each ;
|
||||
|
||||
: compute-adjacencies ( solid -- solid )
|
||||
dup dimension>> [ >= ] curry
|
||||
[ keep swap ] curry MAX-FACE-PER-CORNER swap
|
||||
[ [ test-faces-combinaisons ] 2keep 1- ] [ ] while drop ;
|
||||
|
||||
: find-adjacencies ( solid -- solid )
|
||||
erase-old-adjacencies
|
||||
compute-adjacencies
|
||||
filter-real-faces
|
||||
t >>adjacencies-valid ;
|
||||
|
||||
: ensure-adjacencies ( solid -- solid )
|
||||
dup adjacencies-valid>>
|
||||
[ find-adjacencies ] unless
|
||||
ensure-silhouettes
|
||||
;
|
||||
|
||||
: (non-empty-solid?) ( solid -- ? ) [ dimension>> ] [ corners>> length ] bi < ;
|
||||
: non-empty-solid? ( solid -- ? ) ensure-adjacencies (non-empty-solid?) ;
|
||||
|
||||
: compare-corners-roughly ( corner corner -- ? )
|
||||
2drop t ;
|
||||
! : remove-inner-faces ( -- ) ;
|
||||
: face-project ( array face -- seq )
|
||||
backface?
|
||||
[ 2drop f ]
|
||||
[ [ enlight-projection ]
|
||||
[ initiate-solid-from-face ]
|
||||
[ intersections-into-faces ] tri
|
||||
>>faces
|
||||
swap >>color
|
||||
] if ;
|
||||
|
||||
: solid-project ( lights ambient solid -- solids )
|
||||
ensure-adjacencies
|
||||
[ color>> ] [ faces>> ] bi [ 3array ] dip
|
||||
[ face-project ] with map
|
||||
[ ] filter
|
||||
[ ensure-adjacencies ] map
|
||||
;
|
||||
|
||||
: (solid-move) ( solid v move -- solid )
|
||||
curry [ map ] curry
|
||||
[ dup faces>> ] dip call drop
|
||||
unvalid-adjacencies ; inline
|
||||
|
||||
: solid-translate ( solid v -- solid ) [ face-translate ] (solid-move) ;
|
||||
: solid-transform ( solid m -- solid ) [ face-transform ] (solid-move) ;
|
||||
|
||||
: find-corner-in-silhouette ( s1 s2 -- elt bool )
|
||||
pv> swap silhouettes>> nth
|
||||
swap corners>>
|
||||
[ point-inside-solid? ] with find swap ;
|
||||
|
||||
: valid-face-for-order ( solid point -- face )
|
||||
[ point-inside-face? not ]
|
||||
[ drop face-orientation 0 = not ] 2bi and ;
|
||||
|
||||
: check-orientation ( s1 s2 pt -- int )
|
||||
[ nip faces>> ] dip
|
||||
[ valid-face-for-order ] curry find swap
|
||||
[ face-orientation ] [ drop f ] if ;
|
||||
|
||||
: (order-solid) ( s1 s2 -- int )
|
||||
2dup find-corner-in-silhouette
|
||||
[ check-orientation ] [ 3drop f ] if ;
|
||||
|
||||
: order-solid ( solid solid -- i )
|
||||
2dup (order-solid)
|
||||
[ 2nip ]
|
||||
[ swap (order-solid)
|
||||
[ neg ] [ f ] if*
|
||||
] if* ;
|
||||
|
||||
: subtract ( solid1 solid2 -- solids )
|
||||
faces>> swap clone ensure-adjacencies ensure-silhouettes
|
||||
[ swap slice-solid drop ] curry map
|
||||
[ non-empty-solid? ] filter
|
||||
[ ensure-adjacencies ] map
|
||||
; inline
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! space
|
||||
! --------------------------------------------------------------
|
||||
TUPLE: space name dimension solids ambient-color lights ;
|
||||
: <space> ( -- space ) space new ;
|
||||
: suffix-solids ( space solid -- space ) [ suffix ] curry change-solids ; inline
|
||||
: suffix-lights ( space light -- space ) [ suffix ] curry change-lights ; inline
|
||||
: clear-space-solids ( space -- space ) f >>solids ;
|
||||
|
||||
: space-ensure-solids ( space -- space )
|
||||
[ [ ensure-adjacencies ] map ] change-solids ;
|
||||
: eliminate-empty-solids ( space -- space )
|
||||
[ [ non-empty-solid? ] filter ] change-solids ;
|
||||
|
||||
: projected-space ( space solids -- space )
|
||||
swap dimension>> 1- <space> swap >>dimension swap >>solids ;
|
||||
|
||||
: get-silhouette ( solid -- silhouette ) silhouettes>> pv> swap nth ;
|
||||
: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;
|
||||
|
||||
: space-apply ( space m quot -- space )
|
||||
curry [ map ] curry [ dup solids>> ] dip
|
||||
[ call ] [ drop ] recover drop ;
|
||||
: space-transform ( space m -- space ) [ solid-transform ] space-apply ;
|
||||
: space-translate ( space v -- space ) [ solid-translate ] space-apply ;
|
||||
|
||||
: describe-space ( space -- )
|
||||
solids>> [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;
|
||||
|
||||
: clip-solid ( solid solid -- solids )
|
||||
[ ]
|
||||
[ solid= not ]
|
||||
[ order-solid -1 = ] 2tri
|
||||
and
|
||||
[ get-silhouette subtract ]
|
||||
[ drop 1array ]
|
||||
if
|
||||
|
||||
;
|
||||
|
||||
: (solids-silhouette-subtract) ( solids solid -- solids )
|
||||
[ clip-solid append ] curry { } -rot each ; inline
|
||||
|
||||
: solids-silhouette-subtract ( solids i solid -- solids )
|
||||
! solids is an array of 1 solid arrays
|
||||
[ (solids-silhouette-subtract) ] curry map-but
|
||||
; inline
|
||||
|
||||
: remove-hidden-solids ( space -- space )
|
||||
! We must include each solid in a sequence because during substration
|
||||
! a solid can be divided in more than on solid
|
||||
[
|
||||
[ [ 1array ] map ]
|
||||
[ length ]
|
||||
[ ]
|
||||
tri
|
||||
[ solids-silhouette-subtract ] 2each
|
||||
{ } [ append ] reduce
|
||||
] change-solids
|
||||
eliminate-empty-solids ! TODO include into change-solids
|
||||
;
|
||||
|
||||
: space-project ( space i -- space )
|
||||
[
|
||||
[ clone
|
||||
remove-hidden-solids? [ remove-hidden-solids ] when
|
||||
dup
|
||||
[ solids>> ]
|
||||
[ lights>> ]
|
||||
[ ambient-color>> ] tri
|
||||
[ rot solid-project ] 2curry
|
||||
map
|
||||
[ append ] { } -rot each
|
||||
! TODO project lights
|
||||
projected-space
|
||||
! remove-inner-faces
|
||||
!
|
||||
eliminate-empty-solids
|
||||
] with-pv
|
||||
] [ 3drop <space> ] recover
|
||||
; inline
|
||||
|
||||
: middle-of-space ( space -- point )
|
||||
solids>> [ corners>> ] map concat
|
||||
[ [ ] [ v+ ] map-reduce ] [ length ] bi v/n
|
||||
;
|
||||
|
||||
! --------------------------------------------------------------
|
||||
! 3D rendering
|
||||
! --------------------------------------------------------------
|
||||
|
||||
: face-reference ( face -- halfspace point vect )
|
||||
[ halfspace>> ]
|
||||
[ touching-corners>> first ]
|
||||
[ touching-corners>> second ] tri
|
||||
over v-
|
||||
;
|
||||
|
||||
: theta ( v halfspace point vect -- v x )
|
||||
[ [ over ] dip v- ] dip
|
||||
[ cross dup norm >float ]
|
||||
[ v. >float ]
|
||||
2bi
|
||||
fatan2
|
||||
-rot v.
|
||||
0 < [ neg ] when
|
||||
;
|
||||
|
||||
: ordered-face-points ( face -- corners )
|
||||
[ touching-corners>> 1 head ]
|
||||
[ touching-corners>> 1 tail ]
|
||||
[ face-reference [ theta ] 3curry ] tri
|
||||
{ } map>assoc sort-values keys
|
||||
append
|
||||
; inline
|
||||
|
||||
: point->GL ( point -- ) gl-vertex ;
|
||||
: points->GL ( array -- ) do-cycle [ point->GL ] each ;
|
||||
|
||||
: face->GL ( face color -- )
|
||||
[ ordered-face-points ] dip
|
||||
[ first3 1.0 glColor4d GL_POLYGON [ [ point->GL ] each ] do-state ] curry
|
||||
[ 0 0 0 1 glColor4d GL_LINE_LOOP [ [ point->GL ] each ] do-state ]
|
||||
bi
|
||||
; inline
|
||||
|
||||
: solid->GL ( solid -- )
|
||||
[ faces>> ]
|
||||
[ color>> ] bi
|
||||
[ face->GL ] curry each ; inline
|
||||
|
||||
: space->GL ( space -- )
|
||||
solids>>
|
||||
[ solid->GL ] each ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,147 @@
|
|||
! : init-4D-demo ( -- space )
|
||||
! OK
|
||||
! espace de dimension 4 et de couleur 0,3 0.3 0.3
|
||||
<space>
|
||||
4 >>dimension
|
||||
{ 0.3 0.3 0.3 } >>ambient-color
|
||||
{ 100 150 100 150 100 150 100 150 } "4cube1" 4cube suffix-solids
|
||||
{ 160 180 160 180 160 180 160 180 } "4cube2" 4cube suffix-solids
|
||||
<light>
|
||||
{ -100 -100 -100 -100 } >>position
|
||||
{ 0.2 0.7 0.1 } >>color
|
||||
suffix-lights
|
||||
! ;
|
||||
! : init-3D-demo ( -- space )
|
||||
! OK
|
||||
! espace de dimension 4 et de couleur 0,3 0.3 0.3
|
||||
<space>
|
||||
3 >>dimension
|
||||
{ 0.3 0.3 0.3 } >>ambient-color
|
||||
{ 100 150 100 150 100 150 } "3cube1" 3cube suffix-solids
|
||||
! { -150 -10 -150 -10 -150 -10 -150 -10 } "4cube2" 4cube suffix-solids
|
||||
<light>
|
||||
{ -100 -100 -100 -100 } >>position
|
||||
{ 0.2 0.7 0.1 } >>color
|
||||
suffix-lights
|
||||
! ;
|
||||
|
||||
|
||||
: s1 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"s1" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 -1 -5 } cut-solid
|
||||
{ -1 -1 -21 } cut-solid
|
||||
{ -1 0 -12 } cut-solid
|
||||
{ 1 2 16 } cut-solid
|
||||
;
|
||||
: solid1 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid1" >>name
|
||||
{ 1 -1 -5 } cut-solid
|
||||
{ -1 -1 -21 } cut-solid
|
||||
{ -1 0 -12 } cut-solid
|
||||
{ 1 2 16 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
: solid2 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid2" >>name
|
||||
{ -1 1 -10 } cut-solid
|
||||
{ -1 -1 -28 } cut-solid
|
||||
{ 1 0 13 } cut-solid
|
||||
! { 1 2 16 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
|
||||
: solid3 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid3" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 0 16 } cut-solid
|
||||
{ -1 0 -36 } cut-solid
|
||||
{ 0 1 1 } cut-solid
|
||||
{ 0 -1 -17 } cut-solid
|
||||
! { 1 2 16 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
|
||||
;
|
||||
|
||||
: solid4 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid4" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 0 21 } cut-solid
|
||||
{ -1 0 -36 } cut-solid
|
||||
{ 0 1 1 } cut-solid
|
||||
{ 0 -1 -17 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
|
||||
: solid5 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid5" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 0 6 } cut-solid
|
||||
{ -1 0 -17 } cut-solid
|
||||
{ 0 1 17 } cut-solid
|
||||
{ 0 -1 -19 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
|
||||
: solid7 ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
"solid7" >>name
|
||||
{ 1 1 1 } >>color
|
||||
{ 1 0 38 } cut-solid
|
||||
{ 1 -5 -66 } cut-solid
|
||||
{ -2 1 -75 } cut-solid
|
||||
ensure-adjacencies
|
||||
|
||||
;
|
||||
|
||||
: solid6s ( -- seq )
|
||||
solid3 clone solid2 clone subtract
|
||||
;
|
||||
|
||||
: space1 ( -- space )
|
||||
<space>
|
||||
2 >>dimension
|
||||
! solid3 suffix-solids
|
||||
solid1 suffix-solids
|
||||
solid2 suffix-solids
|
||||
! solid6s [ suffix-solids ] each
|
||||
solid4 suffix-solids
|
||||
! solid5 suffix-solids
|
||||
solid7 suffix-solids
|
||||
{ 1 1 1 } >>ambient-color
|
||||
<light>
|
||||
{ -100 -100 } >>position
|
||||
{ 0.2 0.7 0.1 } >>color
|
||||
suffix-lights
|
||||
;
|
||||
|
||||
: space2 ( -- space )
|
||||
<space>
|
||||
4 >>dimension
|
||||
! 4cube suffix-solids
|
||||
{ 1 1 1 } >>ambient-color
|
||||
<light>
|
||||
{ -100 -100 } >>position
|
||||
{ 0.2 0.7 0.1 } >>color
|
||||
suffix-lights
|
||||
|
||||
;
|
||||
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
Jeff Bigot
|
||||
Greg Ferrar
|
||||
|
|
@ -0,0 +1 @@
|
|||
JF Bigot, after Greg Ferrar
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
! Copyright (C) 2008 Your name.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays help.markup help.syntax kernel sequences ;
|
||||
IN: adsoda.combinators
|
||||
|
||||
HELP: among
|
||||
{ $values
|
||||
{ "array" array } { "n" null }
|
||||
{ "array" array }
|
||||
}
|
||||
{ $description "returns an array containings every possibilities of n choices among a given sequence" } ;
|
||||
|
||||
HELP: columnize
|
||||
{ $values
|
||||
{ "array" array }
|
||||
{ "array" array }
|
||||
}
|
||||
{ $description "flip a sequence into a sequence of 1 element sequences" } ;
|
||||
|
||||
HELP: concat-nth
|
||||
{ $values
|
||||
{ "seq1" sequence } { "seq2" sequence }
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "merges 2 sequences of sequences appending corresponding elements" } ;
|
||||
|
||||
HELP: do-cycle
|
||||
{ $values
|
||||
{ "array" array }
|
||||
{ "array" array }
|
||||
}
|
||||
{ $description "Copy the first element at the end of the sequence in order to close the cycle." } ;
|
||||
|
||||
|
||||
ARTICLE: "adsoda.combinators" "adsoda.combinators"
|
||||
{ $vocab-link "adsoda.combinators" }
|
||||
;
|
||||
|
||||
ABOUT: "adsoda.combinators"
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
USING: adsoda.combinators
|
||||
sequences
|
||||
tools.test
|
||||
;
|
||||
|
||||
IN: adsoda.combinators.tests
|
||||
|
||||
|
||||
[ { "atoto" "b" "ctoto" } ] [ { "a" "b" "c" } 1 [ "toto" append ] map-but ]
|
||||
unit-test
|
||||
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays sequences fry math combinators ;
|
||||
|
||||
IN: adsoda.combinators
|
||||
|
||||
! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ;
|
||||
|
||||
! : prefix-each [ prefix ] curry map ; inline
|
||||
|
||||
! : combinations ( seq n -- seqs )
|
||||
! {
|
||||
! { [ dup 0 = ] [ 2drop { { } } ] }
|
||||
! { [ over empty? ] [ 2drop { } ] }
|
||||
! { [ t ] [
|
||||
! [ [ 1- (combinations) ] [ drop first ] 2bi prefix-each ]
|
||||
! [ (combinations) ] 2bi append
|
||||
! ] }
|
||||
! } cond ;
|
||||
|
||||
: columnize ( array -- array ) [ 1array ] map ; inline
|
||||
|
||||
: among ( array n -- array )
|
||||
2dup swap length
|
||||
{
|
||||
{ [ over 1 = ] [ 3drop columnize ] }
|
||||
{ [ over 0 = ] [ 2drop 2drop { } ] }
|
||||
{ [ 2dup < ] [ 2drop [ 1 cut ] dip
|
||||
[ 1- among [ append ] with map ]
|
||||
[ among append ] 2bi
|
||||
] }
|
||||
{ [ 2dup = ] [ 3drop 1array ] }
|
||||
{ [ 2dup > ] [ 2drop 2drop { } ] }
|
||||
} cond
|
||||
;
|
||||
|
||||
: concat-nth ( seq1 seq2 -- seq ) [ nth append ] curry map-index ;
|
||||
|
||||
: do-cycle ( array -- array ) dup first suffix ;
|
||||
|
||||
: map-but ( seq i quot -- seq )
|
||||
! quot : ( seq x -- seq )
|
||||
'[ _ = [ @ ] unless ] map-index ; inline
|
||||
|
||||
|
|
@ -0,0 +1,126 @@
|
|||
USING: kernel
|
||||
sequences
|
||||
namespaces
|
||||
|
||||
math
|
||||
math.vectors
|
||||
math.matrices
|
||||
;
|
||||
IN: adsoda.solution2
|
||||
|
||||
! -------------------
|
||||
! correctif solution
|
||||
! ---------------
|
||||
SYMBOL: matrix
|
||||
: MIN-VAL-adsoda ( -- x ) 0.00000001
|
||||
! 0.000000000001
|
||||
;
|
||||
|
||||
: zero? ( x -- ? )
|
||||
abs MIN-VAL-adsoda <
|
||||
;
|
||||
|
||||
! [ number>string string>number ] map
|
||||
|
||||
: with-matrix ( matrix quot -- )
|
||||
[ swap matrix set call matrix get ] with-scope ; inline
|
||||
|
||||
: nth-row ( row# -- seq ) matrix get nth ;
|
||||
|
||||
: change-row ( row# quot -- seq ) ! row# quot -- | quot: seq -- seq )
|
||||
matrix get swap change-nth ; inline
|
||||
|
||||
: exchange-rows ( row# row# -- ) matrix get exchange ;
|
||||
|
||||
: rows ( -- n ) matrix get length ;
|
||||
|
||||
: cols ( -- n ) 0 nth-row length ;
|
||||
|
||||
: skip ( i seq quot -- n )
|
||||
over [ find-from drop ] dip length or ; inline
|
||||
|
||||
: first-col ( row# -- n )
|
||||
#! First non-zero column
|
||||
0 swap nth-row [ zero? not ] skip ;
|
||||
|
||||
: clear-scale ( col# pivot-row i-row -- n )
|
||||
[ over ] dip nth dup zero? [
|
||||
3drop 0
|
||||
] [
|
||||
[ nth dup zero? ] dip swap [
|
||||
2drop 0
|
||||
] [
|
||||
swap / neg
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: (clear-col) ( col# pivot-row i -- )
|
||||
[ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;
|
||||
|
||||
: rows-from ( row# -- slice )
|
||||
rows dup <slice> ;
|
||||
|
||||
: clear-col ( col# row# rows -- )
|
||||
[ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;
|
||||
|
||||
: do-row ( exchange-with row# -- )
|
||||
[ exchange-rows ] keep
|
||||
[ first-col ] keep
|
||||
dup 1+ rows-from clear-col ;
|
||||
|
||||
: find-row ( row# quot -- i elt )
|
||||
[ rows-from ] dip find ; inline
|
||||
|
||||
: pivot-row ( col# row# -- n )
|
||||
[ dupd nth-row nth zero? not ] find-row 2nip ;
|
||||
|
||||
: (echelon) ( col# row# -- )
|
||||
over cols < over rows < and [
|
||||
2dup pivot-row [ over do-row 1+ ] when*
|
||||
[ 1+ ] dip (echelon)
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: echelon ( matrix -- matrix' )
|
||||
[ 0 0 (echelon) ] with-matrix ;
|
||||
|
||||
: nonzero-rows ( matrix -- matrix' )
|
||||
[ [ zero? ] all? not ] filter ;
|
||||
|
||||
: null/rank ( matrix -- null rank )
|
||||
echelon dup length swap nonzero-rows length [ - ] keep ;
|
||||
|
||||
: leading ( seq -- n elt ) [ zero? not ] find ;
|
||||
|
||||
: reduced ( matrix' -- matrix'' )
|
||||
[
|
||||
rows <reversed> [
|
||||
dup nth-row leading drop
|
||||
dup [ swap dup clear-col ] [ 2drop ] if
|
||||
] each
|
||||
] with-matrix ;
|
||||
|
||||
: basis-vector ( row col# -- )
|
||||
[ clone ] dip
|
||||
[ swap nth neg recip ] 2keep
|
||||
[ 0 spin set-nth ] 2keep
|
||||
[ n*v ] dip
|
||||
matrix get set-nth ;
|
||||
|
||||
: nullspace ( matrix -- seq )
|
||||
echelon reduced dup empty? [
|
||||
dup first length identity-matrix [
|
||||
[
|
||||
dup leading drop
|
||||
dup [ basis-vector ] [ 2drop ] if
|
||||
] each
|
||||
] with-matrix flip nonzero-rows
|
||||
] unless ;
|
||||
|
||||
: 1-pivots ( matrix -- matrix )
|
||||
[ dup leading nip [ recip v*n ] when* ] map ;
|
||||
|
||||
: solution ( matrix -- matrix )
|
||||
echelon nonzero-rows reduced 1-pivots ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
A modification of solution to approximate solutions
|
||||
|
|
@ -0,0 +1 @@
|
|||
ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm
|
||||
|
|
@ -0,0 +1 @@
|
|||
adsoda 4D viewer
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeff Bigot
|
||||
|
|
@ -0,0 +1,76 @@
|
|||
! Copyright (C) 2008 Jeff Bigot.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays help.markup help.syntax kernel sequences ;
|
||||
IN: adsoda.tools
|
||||
|
||||
HELP: 3cube
|
||||
{ $values
|
||||
{ "array" "array" } { "name" "name" }
|
||||
{ "solid" "solid" }
|
||||
}
|
||||
{ $description "array : xmin xmax ymin ymax zmin zmax"
|
||||
"\n returns a 3D solid with given limits"
|
||||
} ;
|
||||
|
||||
HELP: 4cube
|
||||
{ $values
|
||||
{ "array" "array" } { "name" "name" }
|
||||
{ "solid" "solid" }
|
||||
}
|
||||
{ $description "array : xmin xmax ymin ymax zmin zmax wmin wmax"
|
||||
"\n returns a 4D solid with given limits"
|
||||
} ;
|
||||
|
||||
|
||||
HELP: coord-max
|
||||
{ $values
|
||||
{ "x" null } { "array" array }
|
||||
{ "array" array }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: coord-min
|
||||
{ $values
|
||||
{ "x" null } { "array" array }
|
||||
{ "array" array }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: equation-system-for-normal
|
||||
{ $values
|
||||
{ "points" "a list of n points" }
|
||||
{ "matrix" "matrix" }
|
||||
}
|
||||
{ $description "From a list of points, return the matrix"
|
||||
"to solve in order to find the vector normal to the plan defined by the points" }
|
||||
;
|
||||
|
||||
HELP: normal-vector
|
||||
{ $values
|
||||
{ "points" "a list of n points" }
|
||||
{ "v" "a vector" }
|
||||
}
|
||||
{ $description "From a list of points, returns the vector normal to the plan defined by the points"
|
||||
"\nWith n points, creates n-1 vectors and then find a vector orthogonal to every others"
|
||||
"\n returns { f } if a normal vector can not be found" }
|
||||
;
|
||||
|
||||
HELP: points-to-hyperplane
|
||||
{ $values
|
||||
{ "points" "a list of n points" }
|
||||
{ "hyperplane" "an hyperplane equation" }
|
||||
}
|
||||
{ $description "From a list of points, returns the equation of the hyperplan"
|
||||
"\n Finds a normal vector and then translate it so that it includes one of the points"
|
||||
|
||||
}
|
||||
;
|
||||
|
||||
ARTICLE: "adsoda.tools" "adsoda.tools"
|
||||
{ $vocab-link "adsoda.tools" }
|
||||
"\nTools to help in building an " { $vocab-link "adsoda" } "-space"
|
||||
;
|
||||
|
||||
ABOUT: "adsoda.tools"
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING:
|
||||
adsoda.tools
|
||||
tools.test
|
||||
;
|
||||
|
||||
IN: adsoda.tools.tests
|
||||
|
||||
|
||||
[ { 1 0 } ] [ { { 0 0 } { 0 1 } } normal-vector ] unit-test
|
||||
[ f ] [ { { 0 0 } { 0 0 } } normal-vector ] unit-test
|
||||
|
||||
[ { 1/2 1/2 1+1/2 } ] [ { { 1 2 } { 2 1 } } points-to-hyperplane ] unit-test
|
||||
|
|
@ -0,0 +1,145 @@
|
|||
! Copyright (C) 2008 Jeff Bigot
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING:
|
||||
kernel
|
||||
sequences
|
||||
math
|
||||
accessors
|
||||
adsoda
|
||||
math.vectors
|
||||
math.matrices
|
||||
bunny.model
|
||||
io.encodings.ascii
|
||||
io.files
|
||||
sequences.deep
|
||||
combinators
|
||||
adsoda.combinators
|
||||
fry
|
||||
io.files.temp
|
||||
grouping
|
||||
;
|
||||
|
||||
IN: adsoda.tools
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
! ---------------------------------
|
||||
: coord-min ( x array -- array ) swap suffix ;
|
||||
: coord-max ( x array -- array ) swap neg suffix ;
|
||||
|
||||
: 4cube ( array name -- solid )
|
||||
! array : xmin xmax ymin ymax zmin zmax wmin wmax
|
||||
<solid>
|
||||
4 >>dimension
|
||||
swap >>name
|
||||
swap
|
||||
{
|
||||
[ { 1 0 0 0 } coord-min ] [ { -1 0 0 0 } coord-max ]
|
||||
[ { 0 1 0 0 } coord-min ] [ { 0 -1 0 0 } coord-max ]
|
||||
[ { 0 0 1 0 } coord-min ] [ { 0 0 -1 0 } coord-max ]
|
||||
[ { 0 0 0 1 } coord-min ] [ { 0 0 0 -1 } coord-max ]
|
||||
}
|
||||
[ curry call ] 2map
|
||||
[ cut-solid ] each
|
||||
ensure-adjacencies
|
||||
|
||||
; inline
|
||||
|
||||
: 3cube ( array name -- solid )
|
||||
! array : xmin xmax ymin ymax zmin zmax wmin wmax
|
||||
<solid>
|
||||
3 >>dimension
|
||||
swap >>name
|
||||
swap
|
||||
{
|
||||
[ { 1 0 0 } coord-min ] [ { -1 0 0 } coord-max ]
|
||||
[ { 0 1 0 } coord-min ] [ { 0 -1 0 } coord-max ]
|
||||
[ { 0 0 1 } coord-min ] [ { 0 0 -1 } coord-max ]
|
||||
}
|
||||
[ curry call ] 2map
|
||||
[ cut-solid ] each
|
||||
ensure-adjacencies
|
||||
|
||||
; inline
|
||||
|
||||
|
||||
: equation-system-for-normal ( points -- matrix )
|
||||
unclip [ v- 0 suffix ] curry map
|
||||
dup first [ drop 1 ] map suffix
|
||||
;
|
||||
|
||||
: normal-vector ( points -- v )
|
||||
equation-system-for-normal
|
||||
intersect-hyperplanes ;
|
||||
|
||||
: points-to-hyperplane ( points -- hyperplane )
|
||||
[ normal-vector 0 suffix ] [ first ] bi
|
||||
translate ;
|
||||
|
||||
: refs-to-points ( points faces -- faces )
|
||||
[ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] with map
|
||||
;
|
||||
! V{ { 0.1 0.2 } { 1.1 1.3 } } V{ { 1 0 } { 0 1 } }
|
||||
! V{ { { 1.1 1.3 } { 0.1 0.2 } } { { 0.1 0.2 } { 1.1 1.3 } } }
|
||||
|
||||
: ply-model-path ( -- path )
|
||||
|
||||
! "bun_zipper.ply"
|
||||
"screw2.ply"
|
||||
temp-file
|
||||
;
|
||||
|
||||
: read-bunny-model ( -- v )
|
||||
ply-model-path ascii [ parse-model ] with-file-reader
|
||||
|
||||
refs-to-points
|
||||
;
|
||||
|
||||
: 3points-to-normal ( seq -- v )
|
||||
unclip [ v- ] curry map first2 cross normalize
|
||||
;
|
||||
: 2-faces-to-prism ( seq seq -- seq )
|
||||
2dup
|
||||
[ do-cycle 2 clump ] bi@ concat-nth ! 3 faces rectangulaires
|
||||
swap prefix
|
||||
swap prefix
|
||||
;
|
||||
|
||||
: Xpoints-to-prisme ( seq height -- cube )
|
||||
! from 3 points gives a list of faces representing a cube of height "height"
|
||||
! and of based on the three points
|
||||
! a face is a group of 3 or mode points.
|
||||
[ dup dup 3points-to-normal ] dip
|
||||
v*n [ v+ ] curry map ! 2 eme face triangulaire
|
||||
2-faces-to-prism
|
||||
|
||||
! [ dup number? [ 1 + ] when ] deep-map
|
||||
! dup keep
|
||||
;
|
||||
|
||||
|
||||
: Xpoints-to-plane4D ( seq x y -- 4Dplane )
|
||||
! from 3 points gives a list of faces representing a cube in 4th dim
|
||||
! from x to y (height = y-x)
|
||||
! and of based on the X points
|
||||
! a face is a group of 3 or mode points.
|
||||
'[ [ [ _ suffix ] map ] [ [ _ suffix ] map ] bi ] call
|
||||
2-faces-to-prism
|
||||
;
|
||||
|
||||
: 3pointsfaces-to-3Dsolidfaces ( seq -- seq )
|
||||
[ 1 Xpoints-to-prisme [ 100 110 Xpoints-to-plane4D ] map concat ] map
|
||||
|
||||
;
|
||||
|
||||
: test-figure ( -- solid )
|
||||
<solid>
|
||||
2 >>dimension
|
||||
{ 1 -1 -5 } cut-solid
|
||||
{ -1 -1 -21 } cut-solid
|
||||
{ -1 0 -12 } cut-solid
|
||||
{ 1 2 16 } cut-solid
|
||||
;
|
||||
|
||||
|
|
@ -0,0 +1,111 @@
|
|||
|
||||
USING: arrays assocs compiler.units
|
||||
grouping help help.markup help.topics kernel lexer multiline
|
||||
namespaces parser sequences splitting words
|
||||
easy-help.expand-markup ;
|
||||
|
||||
IN: easy-help
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: parse-text-block ( -- array )
|
||||
|
||||
".." parse-multiline-string
|
||||
string-lines
|
||||
1 tail
|
||||
[ dup " " head? [ 4 tail ] [ ] if ] map
|
||||
[ expand-markup ] map
|
||||
concat
|
||||
[ dup "" = [ drop { $nl } ] [ ] if ] map ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: Text: parse-text-block parsed ; parsing
|
||||
|
||||
: Block: scan-word 1array parse-text-block append parsed ; parsing
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: Notes: { $notes } parse-text-block append parsed ; parsing
|
||||
: Description: { $description } parse-text-block append parsed ; parsing
|
||||
: Contract: { $contract } parse-text-block append parsed ; parsing
|
||||
: Checked-Example: { $example } parse-text-block append parsed ; parsing
|
||||
|
||||
: Class-Description:
|
||||
{ $class-description } parse-text-block append parsed ; parsing
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: Code:
|
||||
|
||||
{ $code }
|
||||
parse-text-block [ dup array? [ drop "" ] [ ] if ] map
|
||||
append
|
||||
parsed
|
||||
|
||||
; parsing
|
||||
|
||||
: Example:
|
||||
{ $heading "Example" }
|
||||
{ $code }
|
||||
parse-text-block
|
||||
[ dup array? [ drop "" ] [ ] if ] map ! Each item in $code must be a string
|
||||
append
|
||||
2array parsed ; parsing
|
||||
|
||||
: Introduction:
|
||||
|
||||
{ $heading "Introduction" }
|
||||
parse-text-block
|
||||
2array parsed ; parsing
|
||||
|
||||
: Summary:
|
||||
|
||||
{ $heading "Summary" }
|
||||
parse-text-block
|
||||
2array parsed ; parsing
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: Values:
|
||||
|
||||
".." parse-multiline-string
|
||||
string-lines
|
||||
1 tail
|
||||
[ dup " " head? [ 4 tail ] [ ] if ] map
|
||||
[ " " split1 [ " " first = ] trim-left 2array ] map
|
||||
\ $values prefix
|
||||
parsed
|
||||
|
||||
; parsing
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: Word:
|
||||
|
||||
scan current-vocab create dup old-definitions get
|
||||
[ delete-at ] with each dup set-word
|
||||
|
||||
bootstrap-word dup set-word
|
||||
dup >link save-location
|
||||
\ ; parse-until >array swap set-word-help ; parsing
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: Heading: { $heading } ".." parse-multiline-string suffix parsed ; parsing
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: List:
|
||||
|
||||
{ $list }
|
||||
|
||||
".." parse-multiline-string
|
||||
string-lines
|
||||
1 tail
|
||||
[ dup " " head? [ 4 tail ] [ ] if ] map
|
||||
[ expand-markup ] map
|
||||
|
||||
append parsed
|
||||
|
||||
; parsing
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
|
||||
USING: accessors arrays kernel lexer locals math namespaces parser
|
||||
sequences splitting ;
|
||||
|
||||
IN: easy-help.expand-markup
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: scan-one-array ( string -- array rest )
|
||||
string-lines
|
||||
lexer-factory get call
|
||||
[
|
||||
[
|
||||
\ } parse-until >array
|
||||
lexer get line-text>>
|
||||
lexer get column>> tail
|
||||
]
|
||||
with-lexer
|
||||
]
|
||||
with-scope ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: contains-markup? ( string -- ? ) "{ $" swap subseq? ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: expand-markup ( LINE -- lines )
|
||||
|
||||
LINE contains-markup?
|
||||
[
|
||||
|
||||
[let | N [ "{ $" LINE start ] |
|
||||
|
||||
LINE N head
|
||||
|
||||
LINE N 2 + tail scan-one-array dup " " head? [ 1 tail ] [ ] if
|
||||
|
||||
[ 2array ] dip
|
||||
|
||||
expand-markup
|
||||
|
||||
append ]
|
||||
|
||||
]
|
||||
[ LINE 1array ]
|
||||
if ;
|
||||
|
|
@ -1,13 +1,11 @@
|
|||
! Copyright (C) 2008 Jose Antonio Ortega Ruiz.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: accessors arrays assocs classes classes.tuple
|
||||
combinators compiler.units continuations debugger definitions
|
||||
eval help io io.files io.pathnames io.streams.string kernel
|
||||
lexer listener listener.private make math math.order memoize
|
||||
namespaces parser prettyprint prettyprint.config quotations
|
||||
sequences sets sorting source-files strings summary tools.vocabs
|
||||
vectors vocabs vocabs.loader vocabs.parser words ;
|
||||
USING: accessors arrays assocs classes.tuple combinators
|
||||
compiler.units continuations debugger definitions io io.pathnames
|
||||
io.streams.string kernel lexer math math.order memoize namespaces
|
||||
parser prettyprint sequences sets sorting source-files strings summary
|
||||
tools.vocabs vectors vocabs vocabs.parser words ;
|
||||
|
||||
IN: fuel
|
||||
|
||||
|
|
@ -138,8 +136,23 @@ M: source-file fuel-pprint path>> fuel-pprint ;
|
|||
[ (fuel-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer
|
||||
(fuel-end-eval) ;
|
||||
|
||||
! Loading files
|
||||
|
||||
: fuel-run-file ( path -- ) run-file ; inline
|
||||
|
||||
: fuel-with-autouse ( quot -- )
|
||||
[
|
||||
auto-use? on
|
||||
[ amended-use get clone fuel-eval-set-result ] print-use-hook set
|
||||
call
|
||||
] curry with-scope ;
|
||||
|
||||
: (fuel-get-uses) ( lines -- )
|
||||
[ parse-fresh drop ] curry with-compilation-unit ; inline
|
||||
|
||||
: fuel-get-uses ( lines -- )
|
||||
[ (fuel-get-uses) ] curry fuel-with-autouse ;
|
||||
|
||||
! Edit locations
|
||||
|
||||
: fuel-normalize-loc ( seq -- path line )
|
||||
|
|
|
|||
|
|
@ -1,6 +0,0 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: math.erato
|
||||
|
||||
HELP: lerato
|
||||
{ $values { "n" "a positive number" } { "lazy-list" "a lazy prime numbers generator" } }
|
||||
{ $description "Builds a lazy list containing the prime numbers between 2 and " { $snippet "n" } " (inclusive)." } ;
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
! Copyright (c) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lists.lazy math.erato tools.test ;
|
||||
IN: math.erato.tests
|
||||
|
||||
[ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test
|
||||
|
|
@ -1,43 +0,0 @@
|
|||
! Copyright (c) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors bit-arrays fry kernel lists.lazy math math.functions
|
||||
math.primes.list math.ranges sequences ;
|
||||
IN: math.erato
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: erato limit bits latest ;
|
||||
|
||||
: ind ( n -- i )
|
||||
2/ 1- ; inline
|
||||
|
||||
: is-prime ( n limit -- bool )
|
||||
[ ind ] [ bits>> ] bi* nth ; inline
|
||||
|
||||
: indices ( n erato -- range )
|
||||
limit>> ind over 3 * ind spin <range> ;
|
||||
|
||||
: mark-multiples ( n erato -- )
|
||||
2dup [ sq ] [ limit>> ] bi* <= [
|
||||
[ indices ] keep bits>> '[ _ f -rot set-nth ] each
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: <erato> ( n -- erato )
|
||||
dup ind 1+ <bit-array> dup set-bits 1 erato boa ;
|
||||
|
||||
: next-prime ( erato -- prime/f )
|
||||
[ 2 + ] change-latest [ latest>> ] keep
|
||||
2dup limit>> <= [
|
||||
2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: lerato ( n -- lazy-list )
|
||||
dup 1000003 < [
|
||||
0 primes-under-million seq>list swap '[ _ <= ] lwhile
|
||||
] [
|
||||
<erato> 2 [ drop next-prime ] with lfrom-by [ ] lwhile
|
||||
] if ;
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: math.primes.erato
|
||||
|
||||
HELP: sieve
|
||||
{ $values { "n" "the greatest odd number to consider" } { "arr" "a bit array" } }
|
||||
{ $description "Return a bit array containing a primality bit for every odd number between 3 and " { $snippet "n" } " (inclusive). " { $snippet ">index" } " can be used to retrieve the index of an odd number to be tested." } ;
|
||||
|
||||
HELP: >index
|
||||
{ $values { "n" "an odd number" } { "i" "the corresponding index" } }
|
||||
{ $description "Retrieve the index corresponding to the odd number on the stack." } ;
|
||||
|
||||
{ sieve >index } related-words
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
USING: bit-arrays math.primes.erato tools.test ;
|
||||
|
||||
[ ?{ t t t f t t f t t f t f f t } ] [ 29 sieve ] unit-test
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
USING: bit-arrays kernel math math.functions math.ranges sequences ;
|
||||
IN: math.primes.erato
|
||||
|
||||
: >index ( n -- i )
|
||||
3 - 2 /i ; inline
|
||||
|
||||
: index> ( i -- n )
|
||||
2 * 3 + ; inline
|
||||
|
||||
: mark-multiples ( i arr -- )
|
||||
[ dup index> [ + ] keep ] dip
|
||||
[ length 1 - swap <range> f swap ] keep
|
||||
[ set-nth ] curry with each ;
|
||||
|
||||
: maybe-mark-multiples ( i arr -- )
|
||||
2dup nth [ mark-multiples ] [ 2drop ] if ;
|
||||
|
||||
: init-sieve ( n -- arr )
|
||||
>index 1 + <bit-array> dup set-bits ;
|
||||
|
||||
: sieve ( n -- arr )
|
||||
[ init-sieve ] [ sqrt >index [0,b] ] bi
|
||||
over [ maybe-mark-multiples ] curry each ; foldable
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -4,7 +4,7 @@ IN: math.primes
|
|||
{ next-prime prime? } related-words
|
||||
|
||||
HELP: next-prime
|
||||
{ $values { "n" "a positive integer" } { "p" "a prime number" } }
|
||||
{ $values { "n" "an integer not smaller than 2" } { "p" "a prime number" } }
|
||||
{ $description "Return the next prime number greater than " { $snippet "n" } "." } ;
|
||||
|
||||
HELP: prime?
|
||||
|
|
|
|||
|
|
@ -8,3 +8,7 @@ USING: arrays math.primes tools.test lists.lazy ;
|
|||
{ { 999983 1000003 } } [ 2 999982 lprimes-from ltake list>array ] unit-test
|
||||
{ { 2 3 5 7 } } [ 10 primes-upto >array ] unit-test
|
||||
{ { 999983 1000003 } } [ 999982 1000010 primes-between >array ] unit-test
|
||||
|
||||
{ { 4999963 4999999 5000011 5000077 5000081 } }
|
||||
[ 4999962 5000082 primes-between >array ]
|
||||
unit-test
|
||||
|
|
|
|||
|
|
@ -1,47 +1,39 @@
|
|||
! Copyright (C) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: binary-search combinators kernel lists.lazy math math.functions
|
||||
math.miller-rabin math.primes.list sequences ;
|
||||
math.miller-rabin math.primes.erato math.ranges sequences ;
|
||||
IN: math.primes
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: find-prime-miller-rabin ( n -- p )
|
||||
dup miller-rabin [ 2 + find-prime-miller-rabin ] unless ; foldable
|
||||
: look-in-bitmap ( n -- ? ) >index 4999999 sieve nth ;
|
||||
|
||||
: really-prime? ( n -- ? )
|
||||
dup 5000000 < [ look-in-bitmap ] [ miller-rabin ] if ; foldable
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: next-prime ( n -- p )
|
||||
dup 999983 < [
|
||||
primes-under-million [ natural-search drop 1+ ] keep nth
|
||||
] [
|
||||
next-odd find-prime-miller-rabin
|
||||
] if ; foldable
|
||||
|
||||
: prime? ( n -- ? )
|
||||
dup 1000000 < [
|
||||
dup primes-under-million natural-search nip =
|
||||
] [
|
||||
miller-rabin
|
||||
] if ; foldable
|
||||
{
|
||||
{ [ dup 2 < ] [ drop f ] }
|
||||
{ [ dup even? ] [ 2 = ] }
|
||||
[ really-prime? ]
|
||||
} cond ; foldable
|
||||
|
||||
: lprimes ( -- list )
|
||||
0 primes-under-million seq>list
|
||||
1000003 [ 2 + find-prime-miller-rabin ] lfrom-by
|
||||
lappend ;
|
||||
: next-prime ( n -- p )
|
||||
next-odd [ dup really-prime? ] [ 2 + ] [ ] until ; foldable
|
||||
|
||||
: lprimes ( -- list ) 2 [ next-prime ] lfrom-by ;
|
||||
|
||||
: lprimes-from ( n -- list )
|
||||
dup 3 < [ drop lprimes ] [ 1- next-prime [ next-prime ] lfrom-by ] if ;
|
||||
|
||||
: primes-upto ( n -- seq )
|
||||
{
|
||||
{ [ dup 2 < ] [ drop { } ] }
|
||||
{ [ dup 1000003 < ] [
|
||||
primes-under-million [ natural-search drop 1+ 0 swap ] keep <slice>
|
||||
] }
|
||||
[ primes-under-million 1000003 lprimes-from
|
||||
rot [ <= ] curry lwhile list>array append ]
|
||||
} cond ; foldable
|
||||
dup 2 < [
|
||||
drop V{ }
|
||||
] [
|
||||
3 swap 2 <range> [ prime? ] filter 2 prefix
|
||||
] if ; foldable
|
||||
|
||||
: primes-between ( low high -- seq )
|
||||
primes-upto [ 1- next-prime ] dip
|
||||
|
|
|
|||
|
|
@ -19,10 +19,7 @@ IN: project-euler.010
|
|||
: euler010 ( -- answer )
|
||||
2000000 primes-upto sum ;
|
||||
|
||||
! [ euler010 ] time
|
||||
! 266425 ms run / 10001 ms GC time
|
||||
|
||||
! TODO: this takes well over one minute now that they changed the problem to
|
||||
! two million instead of one. the primes vocab could use some improvements
|
||||
! [ euler010 ] 100 ave-time
|
||||
! 15 ms ave run time - 0.41 SD (100 trials)
|
||||
|
||||
MAIN: euler010
|
||||
|
|
|
|||
|
|
@ -1,19 +1,43 @@
|
|||
|
||||
USING: io io.encodings.ascii io.files io.files.temp io.launcher
|
||||
locals math.parser sequences sequences.deep ;
|
||||
locals math.parser sequences sequences.deep
|
||||
help.syntax
|
||||
easy-help ;
|
||||
|
||||
IN: size-of
|
||||
|
||||
! Use 'size-of' to find out the size in bytes of a C type.
|
||||
!
|
||||
! The 'headers' argument is a list of header files to use. You may
|
||||
! pass 'f' to only use 'stdio.h'.
|
||||
!
|
||||
! Examples:
|
||||
!
|
||||
! f "int" size-of .
|
||||
!
|
||||
! { "X11/Xlib.h" } "XAnyEvent" size-of .
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
Word: size-of
|
||||
|
||||
Values:
|
||||
|
||||
HEADERS sequence : List of header files
|
||||
TYPE string : A C type
|
||||
n integer : Size in number of bytes ..
|
||||
|
||||
Description:
|
||||
|
||||
Use 'size-of' to find out the size in bytes of a C type.
|
||||
|
||||
The 'headers' argument is a list of header files to use. You may
|
||||
pass 'f' to only use 'stdio.h'. ..
|
||||
|
||||
Example:
|
||||
|
||||
! Find the size of 'int'
|
||||
|
||||
f "int" size-of . ..
|
||||
|
||||
Example:
|
||||
|
||||
! Find the size of the 'XAnyEvent' struct from Xlib.h
|
||||
|
||||
{ "X11/Xlib.h" } "XAnyEvent" size-of . ..
|
||||
|
||||
;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: size-of ( HEADERS TYPE -- n )
|
||||
|
||||
|
|
@ -35,4 +59,3 @@ IN: size-of
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
||||
|
|
@ -1,12 +1,41 @@
|
|||
|
||||
USING: kernel quotations arrays sequences math math.ranges fry
|
||||
opengl opengl.gl ui.render ui.gadgets.cartesian processing.shapes
|
||||
accessors ;
|
||||
accessors
|
||||
help.syntax
|
||||
easy-help ;
|
||||
|
||||
IN: ui.gadgets.plot
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
ARTICLE: "ui.gadgets.plot" "Plot Gadget"
|
||||
|
||||
Summary:
|
||||
|
||||
A simple gadget for ploting two dimentional functions.
|
||||
|
||||
Use the arrow keys to move around.
|
||||
|
||||
Use 'a' and 'z' keys to zoom in and out. ..
|
||||
|
||||
Example:
|
||||
|
||||
<plot> [ sin ] add-function gadget. ..
|
||||
|
||||
Example:
|
||||
|
||||
<plot>
|
||||
[ sin ] red function boa add-function
|
||||
[ cos ] blue function boa add-function
|
||||
gadget. ..
|
||||
|
||||
;
|
||||
|
||||
ABOUT: "ui.gadgets.plot"
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: plot < cartesian functions points ;
|
||||
|
||||
: init-plot ( plot -- plot )
|
||||
|
|
@ -29,11 +58,11 @@ TUPLE: function function color ;
|
|||
GENERIC: plot-function ( plot object -- plot )
|
||||
|
||||
M: callable plot-function ( plot quotation -- plot )
|
||||
>r dup plot-range r> '[ dup @ 2array ] map line-strip ;
|
||||
[ dup plot-range ] dip '[ dup @ 2array ] map line-strip ;
|
||||
|
||||
M: function plot-function ( plot function -- plot )
|
||||
dup color>> dup [ >stroke-color ] [ drop ] if
|
||||
>r dup plot-range r> function>> '[ dup @ 2array ] map line-strip ;
|
||||
[ dup plot-range ] dip function>> '[ dup @ 2array ] map line-strip ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -1,8 +1,35 @@
|
|||
|
||||
USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
|
||||
USING: kernel namespaces opengl ui.render ui.gadgets accessors
|
||||
help.syntax
|
||||
easy-help ;
|
||||
|
||||
IN: ui.gadgets.slate
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
ARTICLE: "slate" "Slate Gadget"
|
||||
|
||||
Summary:
|
||||
|
||||
A gadget with an 'action' slot which should be set to a callable. ..
|
||||
|
||||
Example:
|
||||
|
||||
! Load the right vocabs for the examples
|
||||
|
||||
USING: processing.shapes ui.gadgets.slate ; ..
|
||||
|
||||
Example:
|
||||
|
||||
[ { { 10 10 } { 50 30 } { 10 50 } } polygon fill-mode ] <slate>
|
||||
gadget. ..
|
||||
|
||||
;
|
||||
|
||||
ABOUT: "slate"
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: slate < gadget action pdim graft ungraft ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
|||
|
|
@ -1,10 +1,42 @@
|
|||
|
||||
USING: kernel sequences math math.order
|
||||
ui.gadgets ui.gadgets.tracks ui.gestures
|
||||
bake.fry accessors ;
|
||||
ui.gadgets ui.gadgets.tracks ui.gestures accessors fry
|
||||
help.syntax
|
||||
easy-help ;
|
||||
|
||||
IN: ui.gadgets.tiling
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
ARTICLE: "ui.gadgets.tiling" "Tiling Layout Gadgets"
|
||||
|
||||
Summary:
|
||||
|
||||
A gadget which tiles it's children.
|
||||
|
||||
A tiling gadget may contain any number of children, but only a
|
||||
fixed number is displayed at one time. How many are displayed can
|
||||
be controlled via Control-[ and Control-].
|
||||
|
||||
The focus may be switched with Alt-Left and Alt-Right.
|
||||
|
||||
The focused child may be moved via Shift-Alt-Left and
|
||||
Shift-Alt-Right. ..
|
||||
|
||||
Example:
|
||||
|
||||
<tiling-shelf>
|
||||
"resource:" directory-files
|
||||
[ [ drop ] <bevel-button> tiling-add ]
|
||||
each
|
||||
"Files" open-window ..
|
||||
|
||||
;
|
||||
|
||||
ABOUT: "ui.gadgets.tiling"
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: tiling < track gadgets tiles first focused ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -57,6 +57,7 @@ C-cC-eC-r is the same as C-cC-er)).
|
|||
|
||||
- M-. : edit word at point in Emacs
|
||||
- M-TAB : complete word at point
|
||||
- C-cC-eu : update USING: line
|
||||
- C-cC-ev : edit vocabulary (M-x fuel-edit-vocabulary)
|
||||
- C-cC-ew : edit word (M-x fuel-edit-word-at-point)
|
||||
- C-cC-ed : edit word's doc (M-x fuel-edit-word-at-point)
|
||||
|
|
|
|||
|
|
@ -87,7 +87,7 @@
|
|||
|
||||
(defun fuel--string-prefix-p (prefix str)
|
||||
(and (>= (length str) (length prefix))
|
||||
(string= (substring-no-properties 0 (length prefix) str)
|
||||
(string= (substring-no-properties str 0 (length prefix))
|
||||
(substring-no-properties prefix))))
|
||||
|
||||
(defun fuel--respecting-message (format &rest format-args)
|
||||
|
|
|
|||
|
|
@ -235,7 +235,7 @@
|
|||
(not (fuel-con--connection-completed-p con id)))
|
||||
(accept-process-output nil waitsecs)
|
||||
(setq time (- time step)))
|
||||
(error (setq time 1)))
|
||||
(error (setq time 0)))
|
||||
(or (> time 0)
|
||||
(fuel-con--request-deactivate req)
|
||||
nil)))))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,243 @@
|
|||
;;; fuel-debug-uses.el -- retrieving USING: stanzas
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
;; Keywords: languages, fuel, factor
|
||||
;; Start date: Tue Dec 23, 2008 04:23
|
||||
|
||||
;;; Comentary:
|
||||
|
||||
;; Support for getting and updating factor source vocabulary lists.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'fuel-debug)
|
||||
(require 'fuel-eval)
|
||||
(require 'fuel-popup)
|
||||
(require 'fuel-font-lock)
|
||||
(require 'fuel-base)
|
||||
|
||||
|
||||
|
||||
;;; Customization:
|
||||
|
||||
(fuel-font-lock--defface fuel-font-lock-debug-missing-vocab
|
||||
'font-lock-warning-face fuel-debug "missing vocabulary names")
|
||||
|
||||
(fuel-font-lock--defface fuel-font-lock-debug-unneeded-vocab
|
||||
'font-lock-warning-face fuel-debug "unneeded vocabulary names")
|
||||
|
||||
(fuel-font-lock--defface fuel-font-lock-debug-uses-header
|
||||
'bold fuel-debug "headers in Uses buffers")
|
||||
|
||||
(fuel-font-lock--defface fuel-font-lock-debug-uses-prompt
|
||||
'italic fuel-debug "prompts in Uses buffers")
|
||||
|
||||
|
||||
;;; Utility functions:
|
||||
|
||||
(defun fuel-debug--file-lines (file)
|
||||
(when (file-readable-p file)
|
||||
(with-current-buffer (find-file-noselect file)
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(let ((lines) (in-usings))
|
||||
(while (not (eobp))
|
||||
(when (looking-at "^USING: ") (setq in-usings t))
|
||||
(let ((line (substring-no-properties (thing-at-point 'line) 0 -1)))
|
||||
(when in-usings (setq line (concat "! " line)))
|
||||
(push line lines))
|
||||
(when (and in-usings (looking-at ".*\\_<;\\_>")) (setq in-usings nil))
|
||||
(forward-line))
|
||||
(reverse lines))))))
|
||||
|
||||
(defun fuel-debug--highlight-names (names ref face)
|
||||
(dolist (n names)
|
||||
(when (not (member n ref))
|
||||
(put-text-property 0 (length n) 'font-lock-face face n))))
|
||||
|
||||
(defun fuel-debug--uses-new-uses (file uses)
|
||||
(pop-to-buffer (find-file-noselect file))
|
||||
(goto-char (point-min))
|
||||
(if (re-search-forward "^USING: " nil t)
|
||||
(let ((begin (point))
|
||||
(end (or (and (re-search-forward "\\_<;\\_>") (point)) (point))))
|
||||
(kill-region begin end))
|
||||
(re-search-forward "^IN: " nil t)
|
||||
(beginning-of-line)
|
||||
(open-line 2)
|
||||
(insert "USING: "))
|
||||
(let ((start (point)))
|
||||
(insert (mapconcat 'substring-no-properties uses " ") " ;")
|
||||
(fill-region start (point) nil)))
|
||||
|
||||
(defun fuel-debug--uses-filter (restarts)
|
||||
(let ((result) (i 1) (rn 0))
|
||||
(dolist (r restarts (reverse result))
|
||||
(setq rn (1+ rn))
|
||||
(when (string-match "Use the .+ vocabulary\\|Defer" r)
|
||||
(push (list i rn r) result)
|
||||
(setq i (1+ i))))))
|
||||
|
||||
|
||||
;;; Retrieving USINGs:
|
||||
|
||||
(fuel-popup--define fuel-debug--uses-buffer
|
||||
"*fuel uses*" 'fuel-debug-uses-mode)
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-debug--uses nil))
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-debug--uses-file nil))
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-debug--uses-restarts nil))
|
||||
|
||||
(defsubst fuel-debug--uses-insert-title ()
|
||||
(insert "Infering USING: stanza for " fuel-debug--uses-file ".\n\n"))
|
||||
|
||||
(defun fuel-debug--uses-prepare (file)
|
||||
(fuel--with-popup (fuel-debug--uses-buffer)
|
||||
(setq fuel-debug--uses-file file
|
||||
fuel-debug--uses nil
|
||||
fuel-debug--uses-restarts nil)
|
||||
(erase-buffer)
|
||||
(fuel-debug--uses-insert-title)))
|
||||
|
||||
(defun fuel-debug--uses-clean ()
|
||||
(setq fuel-debug--uses-file nil
|
||||
fuel-debug--uses nil
|
||||
fuel-debug--uses-restarts nil))
|
||||
|
||||
(defun fuel-debug--uses-for-file (file)
|
||||
(let* ((lines (fuel-debug--file-lines file))
|
||||
(cmd `(:fuel ((V{ ,@lines } fuel-get-uses)) t t)))
|
||||
(fuel-debug--uses-prepare file)
|
||||
(fuel--with-popup (fuel-debug--uses-buffer)
|
||||
(insert "Asking Factor. Please, wait ...\n")
|
||||
(fuel-eval--send cmd 'fuel-debug--uses-cont))
|
||||
(fuel-popup--display (fuel-debug--uses-buffer))))
|
||||
|
||||
(defun fuel-debug--uses-cont (retort)
|
||||
(let ((uses (fuel-eval--retort-result retort))
|
||||
(err (fuel-eval--retort-error retort)))
|
||||
(if uses (fuel-debug--uses-display uses)
|
||||
(fuel-debug--uses-display-err retort))))
|
||||
|
||||
(defun fuel-debug--insert-vlist (title vlist)
|
||||
(goto-char (point-max))
|
||||
(insert title "\n\n ")
|
||||
(let ((i 0) (step 5))
|
||||
(dolist (v vlist)
|
||||
(setq i (1+ i))
|
||||
(insert v)
|
||||
(insert (if (zerop (mod i step)) "\n " " ")))
|
||||
(unless (zerop (mod i step)) (newline))
|
||||
(newline)))
|
||||
|
||||
(defun fuel-debug--uses-display (uses)
|
||||
(let* ((inhibit-read-only t)
|
||||
(old (with-current-buffer (find-file-noselect fuel-debug--uses-file)
|
||||
(fuel-syntax--usings)))
|
||||
(old (sort old 'string<))
|
||||
(new (sort uses 'string<)))
|
||||
(erase-buffer)
|
||||
(fuel-debug--uses-insert-title)
|
||||
(if (equalp old new)
|
||||
(progn
|
||||
(insert "Current USING: is already fine!. Type 'q' to bury buffer.\n")
|
||||
(fuel-debug--uses-clean))
|
||||
(fuel-debug--highlight-names old new 'fuel-font-lock-debug-unneeded-vocab)
|
||||
(fuel-debug--highlight-names new old 'fuel-font-lock-debug-missing-vocab)
|
||||
(fuel-debug--insert-vlist "Current vocabulary list:" old)
|
||||
(newline)
|
||||
(fuel-debug--insert-vlist "Correct vocabulary list:" new)
|
||||
(setq fuel-debug--uses new)
|
||||
(insert "\nType 'y' to update your USING: to the new one.\n"))))
|
||||
|
||||
(defun fuel-debug--uses-display-err (retort)
|
||||
(let* ((inhibit-read-only t)
|
||||
(err (fuel-eval--retort-error retort))
|
||||
(restarts (fuel-debug--uses-filter (fuel-eval--error-restarts err)))
|
||||
(unique (= 1 (length restarts))))
|
||||
(erase-buffer)
|
||||
(fuel-debug--uses-insert-title)
|
||||
(insert (fuel-eval--retort-output retort))
|
||||
(newline)
|
||||
(if (not restarts)
|
||||
(insert "\nSorry, couldn't infer the vocabulary list.\n")
|
||||
(setq fuel-debug--uses-restarts restarts)
|
||||
(if unique (fuel-debug--uses-restart 1)
|
||||
(insert "\nPlease, type the number of the desired vocabulary:\n\n")
|
||||
(dolist (r restarts)
|
||||
(insert (format " :%s %s\n" (first r) (third r))))))))
|
||||
|
||||
(defun fuel-debug--uses-update-usings ()
|
||||
(interactive)
|
||||
(let ((inhibit-read-only t))
|
||||
(when (and fuel-debug--uses-file fuel-debug--uses)
|
||||
(fuel-debug--uses-new-uses fuel-debug--uses-file fuel-debug--uses)
|
||||
(message "USING: updated!")
|
||||
(with-current-buffer (fuel-debug--uses-buffer)
|
||||
(insert "\nDone!")
|
||||
(fuel-debug--uses-clean)
|
||||
(bury-buffer)))))
|
||||
|
||||
(defun fuel-debug--uses-restart (n)
|
||||
(when (and (> n 0) (<= n (length fuel-debug--uses-restarts)))
|
||||
(let* ((inhibit-read-only t)
|
||||
(restart (format ":%s" (cadr (nth (1- n) fuel-debug--uses-restarts))))
|
||||
(cmd `(:fuel ([ (:factor ,restart) ] fuel-with-autouse) t t)))
|
||||
(setq fuel-debug--uses-restarts nil)
|
||||
(insert "\nAsking Factor. Please, wait ...\n")
|
||||
(fuel-eval--send cmd 'fuel-debug--uses-cont))))
|
||||
|
||||
|
||||
;;; Fuel uses mode:
|
||||
|
||||
(defvar fuel-debug-uses-mode-map
|
||||
(let ((map (make-keymap)))
|
||||
(suppress-keymap map)
|
||||
(dotimes (n 9)
|
||||
(define-key map (vector (+ ?1 n))
|
||||
`(lambda () (interactive) (fuel-debug--uses-restart ,(1+ n)))))
|
||||
(define-key map "y" 'fuel-debug--uses-update-usings)
|
||||
(define-key map "\C-c\C-c" 'fuel-debug--uses-update-usings)
|
||||
map))
|
||||
|
||||
(defconst fuel-debug--uses-header-regex
|
||||
(format "^%s.*$" (regexp-opt '("Infering USING: stanza for "
|
||||
"Current USING: is already fine!"
|
||||
"Current vocabulary list:"
|
||||
"Correct vocabulary list:"
|
||||
"Sorry, couldn't infer the vocabulary list."
|
||||
"Done!"))))
|
||||
|
||||
(defconst fuel-debug--uses-prompt-regex
|
||||
(format "^%s" (regexp-opt '("Asking Factor. Please, wait ..."
|
||||
"Please, type the number of the desired vocabulary:"
|
||||
"Type 'y' to update your USING: to the new one."))))
|
||||
|
||||
(defconst fuel-debug--uses-font-lock-keywords
|
||||
`((,fuel-debug--uses-header-regex . 'fuel-font-lock-debug-uses-header)
|
||||
(,fuel-debug--uses-prompt-regex . 'fuel-font-lock-debug-uses-prompt)
|
||||
(,fuel-debug--restart-regex (1 'fuel-font-lock-debug-restart-number)
|
||||
(2 'fuel-font-lock-debug-restart-name))))
|
||||
|
||||
(defun fuel-debug-uses-mode ()
|
||||
"A major mode for displaying Factor's USING: inference results."
|
||||
(interactive)
|
||||
(kill-all-local-variables)
|
||||
(buffer-disable-undo)
|
||||
(setq major-mode 'fuel-debug-uses-mode)
|
||||
(setq mode-name "Fuel Uses:")
|
||||
(set (make-local-variable 'font-lock-defaults)
|
||||
'(fuel-debug--uses-font-lock-keywords t nil nil nil))
|
||||
(use-local-map fuel-debug-uses-mode-map))
|
||||
|
||||
|
||||
(provide 'fuel-debug-uses)
|
||||
;;; fuel-debug-uses.el ends here
|
||||
|
|
@ -92,7 +92,14 @@
|
|||
(make-variable-buffer-local
|
||||
(defvar fuel-debug--file nil))
|
||||
|
||||
(defun fuel-debug--display-retort (ret &optional success-msg no-pop file)
|
||||
(defun fuel-debug--prepare-compilation (file msg)
|
||||
(let ((inhibit-read-only t))
|
||||
(with-current-buffer (fuel-debug--buffer)
|
||||
(erase-buffer)
|
||||
(insert msg)
|
||||
(setq fuel-debug--file file))))
|
||||
|
||||
(defun fuel-debug--display-retort (ret &optional success-msg no-pop)
|
||||
(let ((err (fuel-eval--retort-error ret))
|
||||
(inhibit-read-only t))
|
||||
(with-current-buffer (fuel-debug--buffer)
|
||||
|
|
@ -107,12 +114,11 @@
|
|||
(fuel-debug--display-restarts err)
|
||||
(delete-blank-lines)
|
||||
(newline))
|
||||
(let ((hstr (fuel-debug--help-string err file)))
|
||||
(let ((hstr (fuel-debug--help-string err fuel-debug--file)))
|
||||
(if fuel-debug-show-short-help
|
||||
(insert "-----------\n" hstr "\n")
|
||||
(message "%s" hstr)))
|
||||
(setq fuel-debug--last-ret ret)
|
||||
(setq fuel-debug--file file)
|
||||
(goto-char (point-max))
|
||||
(font-lock-fontify-buffer)
|
||||
(when (and err (not no-pop)) (fuel-popup--display))
|
||||
|
|
@ -219,11 +225,8 @@
|
|||
(unless (re-search-forward (format "^%s" info) nil t)
|
||||
(error "%s information not available" info))
|
||||
(message "Retrieving %s info ..." info)
|
||||
(unless (fuel-debug--display-retort (fuel-eval--send/wait
|
||||
`(:fuel ((:factor ,info))))
|
||||
""
|
||||
nil
|
||||
(fuel-debug--buffer-file))
|
||||
(unless (fuel-debug--display-retort
|
||||
(fuel-eval--send/wait `(:fuel ((:factor ,info)))) "")
|
||||
(error "Sorry, no %s info available" info))))
|
||||
|
||||
|
||||
|
|
@ -236,7 +239,6 @@
|
|||
(define-key map "\C-c\C-c" 'fuel-debug-goto-error)
|
||||
(define-key map "n" 'next-line)
|
||||
(define-key map "p" 'previous-line)
|
||||
(define-key map "q" 'bury-buffer)
|
||||
(dotimes (n 9)
|
||||
(define-key map (vector (+ ?1 n))
|
||||
`(lambda () (interactive) (fuel-debug-exec-restart ,(1+ n) t))))
|
||||
|
|
@ -252,15 +254,15 @@ invoking restarts as needed.
|
|||
(interactive)
|
||||
(kill-all-local-variables)
|
||||
(buffer-disable-undo)
|
||||
(setq major-mode 'factor-mode)
|
||||
(setq major-mode 'fuel-debug-mode)
|
||||
(setq mode-name "Fuel Debug")
|
||||
(use-local-map fuel-debug-mode-map)
|
||||
(fuel-debug--font-lock-setup)
|
||||
(setq fuel-debug--file nil)
|
||||
(setq fuel-debug--last-ret nil)
|
||||
(setq buffer-read-only t)
|
||||
(run-hooks 'fuel-debug-mode-hook))
|
||||
|
||||
|
||||
|
||||
(provide 'fuel-debug)
|
||||
;;; fuel-debug.el ends here
|
||||
|
|
|
|||
|
|
@ -130,14 +130,15 @@
|
|||
|
||||
(defsubst fuel-eval--error-name (err) (car err))
|
||||
|
||||
(defsubst fuel-eval--error-restarts (err)
|
||||
(cdr (assoc :restarts (fuel-eval--error-name-p err 'condition))))
|
||||
|
||||
(defun fuel-eval--error-name-p (err name)
|
||||
(unless (null err)
|
||||
(or (and (eq (fuel-eval--error-name err) name) err)
|
||||
(assoc name err))))
|
||||
|
||||
(defsubst fuel-eval--error-restarts (err)
|
||||
(cdr (assoc :restarts (or (fuel-eval--error-name-p err 'condition)
|
||||
(fuel-eval--error-name-p err 'lexer-error)))))
|
||||
|
||||
(defsubst fuel-eval--error-file (err)
|
||||
(nth 1 (fuel-eval--error-name-p err 'source-file-error)))
|
||||
|
||||
|
|
|
|||
|
|
@ -68,16 +68,11 @@
|
|||
|
||||
;;; Font lock:
|
||||
|
||||
(defconst fuel-font-lock--parsing-lock-keywords
|
||||
(cons '("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
|
||||
(mapcar (lambda (w) `(,(format "\\(^\\| \\)\\(%s\\)\\($\\| \\)" w)
|
||||
2 'factor-font-lock-parsing-word))
|
||||
fuel-syntax--parsing-words)))
|
||||
|
||||
(defconst fuel-font-lock--font-lock-keywords
|
||||
`(,@fuel-font-lock--parsing-lock-keywords
|
||||
`((,fuel-syntax--parsing-words-regex . 'factor-font-lock-parsing-word)
|
||||
(,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word)
|
||||
("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
|
||||
(,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
|
||||
(,fuel-syntax--parsing-words-ext-regex . 'factor-font-lock-parsing-word)
|
||||
(,fuel-syntax--declaration-words-regex . 'factor-font-lock-declaration)
|
||||
(,fuel-syntax--word-definition-regex 2 'factor-font-lock-word)
|
||||
(,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name)
|
||||
|
|
|
|||
|
|
@ -105,6 +105,7 @@ buffer."
|
|||
|
||||
(defun fuel-listener-nuke ()
|
||||
(interactive)
|
||||
(comint-redirect-cleanup)
|
||||
(fuel-con--setup-connection fuel-listener--buffer))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@
|
|||
(require 'fuel-listener)
|
||||
(require 'fuel-completion)
|
||||
(require 'fuel-debug)
|
||||
(require 'fuel-debug-uses)
|
||||
(require 'fuel-eval)
|
||||
(require 'fuel-help)
|
||||
(require 'fuel-xref)
|
||||
|
|
@ -68,15 +69,14 @@ With prefix argument, ask for the file to run."
|
|||
(buffer (cdr f/b)))
|
||||
(when buffer
|
||||
(with-current-buffer buffer
|
||||
(message "Compiling %s ..." file)
|
||||
(fuel-eval--send `(:fuel (,file fuel-run-file))
|
||||
`(lambda (r) (fuel--run-file-cont r ,file)))))))
|
||||
(let ((msg (format "Compiling %s ..." file)))
|
||||
(fuel-debug--prepare-compilation file msg)
|
||||
(message msg)
|
||||
(fuel-eval--send `(:fuel (,file fuel-run-file))
|
||||
`(lambda (r) (fuel--run-file-cont r ,file))))))))
|
||||
|
||||
(defun fuel--run-file-cont (ret file)
|
||||
(if (fuel-debug--display-retort ret
|
||||
(format "%s successfully compiled" file)
|
||||
nil
|
||||
file)
|
||||
(if (fuel-debug--display-retort ret (format "%s successfully compiled" file))
|
||||
(message "Compiling %s ... OK!" file)
|
||||
(message "")))
|
||||
|
||||
|
|
@ -86,17 +86,20 @@ With prefix argument, ask for the file to run."
|
|||
Unless called with a prefix, switches to the compilation results
|
||||
buffer in case of errors."
|
||||
(interactive "r\nP")
|
||||
(let* ((lines (split-string (buffer-substring-no-properties begin end)
|
||||
"[\f\n\r\v]+" t))
|
||||
(let* ((rstr (buffer-substring begin end))
|
||||
(lines (split-string (substring-no-properties rstr)
|
||||
"[\f\n\r\v]+"
|
||||
t))
|
||||
(cmd `(:fuel (,(mapcar (lambda (l) `(:factor ,l)) lines))))
|
||||
(cv (fuel-syntax--current-vocab)))
|
||||
(fuel-debug--prepare-compilation (buffer-file-name)
|
||||
(format "Evaluating:\n\n%s" rstr))
|
||||
(fuel-debug--display-retort
|
||||
(fuel-eval--send/wait cmd 10000)
|
||||
(format "%s%s"
|
||||
(if cv (format "IN: %s " cv) "")
|
||||
(fuel--shorten-region begin end 70))
|
||||
arg
|
||||
(buffer-file-name))))
|
||||
arg)))
|
||||
|
||||
(defun fuel-eval-extended-region (begin end &optional arg)
|
||||
"Sends region, extended outwards to nearest definition,
|
||||
|
|
@ -120,6 +123,14 @@ buffer in case of errors."
|
|||
(unless (< begin end) (error "No evaluable definition around point"))
|
||||
(fuel-eval-region begin end arg))))
|
||||
|
||||
(defun fuel-update-usings (&optional arg)
|
||||
"Asks factor for the vocabularies needed by this file,
|
||||
optionally updating the its USING: line.
|
||||
With prefix argument, ask for the file name."
|
||||
(interactive "P")
|
||||
(let ((file (car (fuel-mode--read-file arg))))
|
||||
(when file (fuel-debug--uses-for-file file))))
|
||||
|
||||
(defun fuel--try-edit (ret)
|
||||
(let* ((err (fuel-eval--retort-error ret))
|
||||
(loc (fuel-eval--retort-result ret)))
|
||||
|
|
@ -270,6 +281,7 @@ interacting with a factor listener is at your disposal.
|
|||
(fuel-mode--key ?e ?e 'fuel-eval-extended-region)
|
||||
(fuel-mode--key ?e ?l 'fuel-run-file)
|
||||
(fuel-mode--key ?e ?r 'fuel-eval-region)
|
||||
(fuel-mode--key ?e ?u 'fuel-update-usings)
|
||||
(fuel-mode--key ?e ?v 'fuel-edit-vocabulary)
|
||||
(fuel-mode--key ?e ?w 'fuel-edit-word)
|
||||
(fuel-mode--key ?e ?x 'fuel-eval-definition)
|
||||
|
|
|
|||
|
|
@ -44,7 +44,8 @@
|
|||
(define-minor-mode fuel-popup-mode
|
||||
"Mode for displaying read only stuff"
|
||||
nil nil
|
||||
'(("q" . fuel-popup--quit)))
|
||||
'(("q" . fuel-popup--quit))
|
||||
(setq buffer-read-only t))
|
||||
|
||||
(defmacro fuel-popup--define (fun name mode)
|
||||
`(defun ,fun ()
|
||||
|
|
@ -55,6 +56,14 @@
|
|||
(current-buffer)))))
|
||||
|
||||
(put 'fuel-popup--define 'lisp-indent-function 1)
|
||||
|
||||
(defmacro fuel--with-popup (buffer &rest body)
|
||||
`(with-current-buffer ,buffer
|
||||
(let ((inhibit-read-only t))
|
||||
,@body)))
|
||||
|
||||
(put 'fuel--with-popup 'lisp-indent-function 1)
|
||||
|
||||
|
||||
(provide 'fuel-popup)
|
||||
;;; fuel-popup.el ends here
|
||||
|
|
|
|||
|
|
@ -43,20 +43,26 @@
|
|||
;;; Regexps galore:
|
||||
|
||||
(defconst fuel-syntax--parsing-words
|
||||
'("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
|
||||
"BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
|
||||
'(":" "::" ";" "<<" "<PRIVATE" ">>"
|
||||
"B" "BIN:" "C:" "C-STRUCT:" "C-UNION:" "CHAR:"
|
||||
"DEFER:" "ERROR:" "EXCLUDE:" "FORGET:"
|
||||
"GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{"
|
||||
"GENERIC#" "GENERIC:" "HEX:" "HOOK:"
|
||||
"IN:" "INSTANCE:" "INTERSECTION:"
|
||||
"M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "METHOD:" "MIXIN:"
|
||||
"OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
|
||||
"REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
|
||||
"TUPLE:" "T{" "t\\??" "TYPEDEF:"
|
||||
"UNION:" "USE:" "USING:" "V{" "VARS:" "W{"))
|
||||
"TUPLE:" "t" "t?" "TYPEDEF:"
|
||||
"UNION:" "USE:" "USING:" "VARS:"
|
||||
"call-next-method" "delimiter" "f" "initial:" "read-only"))
|
||||
|
||||
(defconst fuel-syntax--parsing-words-ext-regex
|
||||
(regexp-opt '("B" "call-next-method" "delimiter" "f" "initial:" "read-only")
|
||||
'words))
|
||||
(defconst fuel-syntax--bracers
|
||||
'("B" "BV" "C" "CS" "H" "T" "V" "W"))
|
||||
|
||||
(defconst fuel-syntax--parsing-words-regex
|
||||
(regexp-opt fuel-syntax--parsing-words 'words))
|
||||
|
||||
(defconst fuel-syntax--brace-words-regex
|
||||
(format "%s{" (regexp-opt fuel-syntax--bracers t)))
|
||||
|
||||
(defconst fuel-syntax--declaration-words
|
||||
'("flushable" "foldable" "inline" "parsing" "recursive"))
|
||||
|
|
@ -132,43 +138,40 @@
|
|||
|
||||
;;; Factor syntax table
|
||||
|
||||
(defvar fuel-syntax--syntax-table
|
||||
(setq fuel-syntax--syntax-table
|
||||
(let ((table (make-syntax-table)))
|
||||
;; Default is word constituent
|
||||
(dotimes (i 256)
|
||||
(modify-syntax-entry i "w" table))
|
||||
|
||||
;; Whitespace
|
||||
(modify-syntax-entry ?\t " " table)
|
||||
;; Whitespace (TAB is not whitespace)
|
||||
(modify-syntax-entry ?\f " " table)
|
||||
(modify-syntax-entry ?\r " " table)
|
||||
(modify-syntax-entry ?\ " " table)
|
||||
(modify-syntax-entry ?\n " " table)
|
||||
|
||||
;; Parenthesis
|
||||
(modify-syntax-entry ?\[ "(]" table)
|
||||
(modify-syntax-entry ?\] ")[" table)
|
||||
(modify-syntax-entry ?{ "(}" table)
|
||||
(modify-syntax-entry ?} "){" table)
|
||||
|
||||
(modify-syntax-entry ?\( "()" table)
|
||||
(modify-syntax-entry ?\) ")(" table)
|
||||
|
||||
;; Strings
|
||||
(modify-syntax-entry ?\" "\"" table)
|
||||
(modify-syntax-entry ?\\ "/" table)
|
||||
|
||||
table))
|
||||
|
||||
(defconst fuel-syntax--syntactic-keywords
|
||||
`(("\\(#!\\) .*\\(\n\\)" (1 "<") (2 ">"))
|
||||
("\\( \\|^\\)\\(!\\) .*\\(\n\\)" (2 "<") (3 ">"))
|
||||
("\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
|
||||
`(("\\_<\\(#?!\\) .*\\(\n\\)" (1 "<") (2 ">"))
|
||||
("\\_<\\(#?!\\)\\(\n\\)" (1 "<") (2 ">"))
|
||||
("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
|
||||
("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]"))
|
||||
("\\(\\[\\)\\(|\\) +[^|]* \\(|\\)" (1 "(]") (2 "(|") (3 ")|"))
|
||||
(" \\(|\\) " (1 "(|"))
|
||||
(" \\(|\\)$" (1 ")"))
|
||||
("\\([[({]\\)\\([^ \"\n]\\)" (1 "_") (2 "_"))
|
||||
("\\([^ \"\n]\\)\\([])}]\\)" (1 "_") (2 "_"))))
|
||||
("CHAR: \\(\"\\)\\( \\|$\\)" (1 "w"))
|
||||
(,(format "\\_<%s\\({\\)\\_>" (regexp-opt fuel-syntax--bracers)) (1 "(}"))
|
||||
("\\_<\\({\\)\\_>" (1 "(}"))
|
||||
("\\_<\\(}\\)\\_>" (1 "){"))
|
||||
("\\_<\\((\\)\\_>" (1 "()"))
|
||||
("\\_<\\()\\)\\_>" (1 ")("))
|
||||
("\\_<\\(\\[\\)\\_>" (1 "(]"))
|
||||
("\\_<\\(\\]\\)\\_>" (1 ")["))))
|
||||
|
||||
|
||||
;;; Source code analysis:
|
||||
|
|
@ -315,9 +318,7 @@
|
|||
|
||||
(defun fuel-syntax--find-usings ()
|
||||
(save-excursion
|
||||
(let ((usings)
|
||||
(in (fuel-syntax--current-vocab)))
|
||||
(when in (setq usings (list in)))
|
||||
(let ((usings))
|
||||
(goto-char (point-max))
|
||||
(while (re-search-backward fuel-syntax--using-lines-regex nil t)
|
||||
(dolist (u (split-string (match-string-no-properties 1) nil t))
|
||||
|
|
|
|||
|
|
@ -1,39 +0,0 @@
|
|||
|
||||
USING: kernel namespaces sequences
|
||||
io io.files io.launcher io.encodings.ascii
|
||||
bake builder.util
|
||||
accessors vars
|
||||
math.parser ;
|
||||
|
||||
IN: size-of
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: headers
|
||||
|
||||
: include-headers ( -- seq )
|
||||
headers> [ `{ "#include <" , ">" } to-string ] map ;
|
||||
|
||||
: size-of-c-program ( type -- lines )
|
||||
`{
|
||||
"#include <stdio.h>"
|
||||
include-headers
|
||||
{ "main() { printf( \"%i\" , sizeof( " , " ) ) ; }" }
|
||||
}
|
||||
to-strings ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: c-file ( -- path ) "size-of.c" temp-file ;
|
||||
|
||||
: exe ( -- path ) "size-of" temp-file ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: size-of ( type -- n )
|
||||
size-of-c-program c-file ascii set-file-lines
|
||||
|
||||
{ "gcc" c-file "-o" exe } to-strings
|
||||
[ "Error compiling generated C program" print ] run-or-bail
|
||||
|
||||
exe ascii <process-reader> contents string>number ;
|
||||
Loading…
Reference in New Issue