VAR: pv\r
\r
\r
-! ---------------------------------------------------------------------\r
+! -------------------------------------------------------------\r
! global values\r
VALUE: remove-hidden-solids?\r
VALUE: VERY-SMALL-NUM\r
0.0000001 to: VERY-SMALL-NUM\r
0.0000001 to: ZERO-VALUE\r
4 to: MAX-FACE-PER-CORNER\r
-! ---------------------------------------------------------------------\r
+! -------------------------------------------------------------\r
! sequence complement\r
\r
: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
\r
: dimension ( array -- x ) length 1- ; inline \r
-: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline\r
-: change-last ( seq quot -- ) [ [ dimension ] keep ] dip change-nth ; \r
+: last ( seq -- x ) [ dimension ] [ nth ] bi ; inline\r
+: change-last ( seq quot -- ) \r
+ [ [ dimension ] keep ] dip change-nth ; \r
\r
-! --------------------------------------------------------------\r
+! -------------------------------------------------------------\r
! light\r
-! --------------------------------------------------------------\r
+! -------------------------------------------------------------\r
\r
TUPLE: light name { direction array } color ;\r
: <light> ( -- tuple ) light new ;\r
\r
-! -----------------------------------------------------------------------\r
+! -------------------------------------------------------------\r
! halfspace manipulation\r
-! -----------------------------------------------------------------------\r
+! -------------------------------------------------------------\r
\r
: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;\r
: translate ( u v -- w ) dupd v* sum constant+ ; \r
: transform ( u matrix -- w )\r
[ swap m.v ] 2keep ! compute new normal vector \r
[\r
- [ [ abs ZERO-VALUE > ] find ] keep ! find a point on the frontier\r
+ [ [ abs ZERO-VALUE > ] find ] keep \r
+ ! find a point on the frontier\r
! be sure it's not null vector\r
last ! get constant\r
swap /f neg swap ! intercept value\r
position-point VERY-SMALL-NUM > ; \r
: point-inside-or-on-halfspace? ( halfspace v -- ? ) \r
position-point VERY-SMALL-NUM neg > ;\r
-: project-vector ( seq -- seq ) pv> [ head ] [ 1+ tail ] 2bi append ; \r
-: get-intersection ( matrice -- seq ) [ 1 tail* ] map flip first ;\r
+: project-vector ( seq -- seq ) \r
+ pv> [ head ] [ 1+ tail ] 2bi append ; \r
+: get-intersection ( matrice -- seq ) \r
+ [ 1 tail* ] map flip first ;\r
\r
: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;\r
\r
[ solution dup ] [ first dimension ] bi\r
valid-solution? [ get-intersection ] [ drop f ] if ;\r
\r
-! --------------------------------------------------------------\r
+! -------------------------------------------------------------\r
! faces\r
-! --------------------------------------------------------------\r
+! -------------------------------------------------------------\r
\r
-TUPLE: face { halfspace array } touching-corners adjacent-faces ;\r
+TUPLE: face { halfspace array } \r
+ touching-corners adjacent-faces ;\r
: <face> ( v -- tuple ) face new swap >>halfspace ;\r
: flip-face ( face -- face ) [ vneg ] change-halfspace ;\r
-: erase-face-touching-corners ( face -- face ) f >>touching-corners ;\r
-: erase-face-adjacent-faces ( face -- face ) f >>adjacent-faces ;\r
+: erase-face-touching-corners ( face -- face ) \r
+ f >>touching-corners ;\r
+: erase-face-adjacent-faces ( face -- face ) \r
+ f >>adjacent-faces ;\r
: faces-intersection ( faces -- v ) \r
[ halfspace>> ] map intersect-hyperplanes ;\r
: face-translate ( face v -- face ) \r
[ translate ] curry change-halfspace ; inline\r
: face-transform ( face m -- face )\r
[ transform ] curry change-halfspace ; inline\r
-: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;\r
+: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;\r
: backface? ( face -- face ? ) dup face-orientation 0 <= ;\r
: pv-factor ( face -- f face ) \r
halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline\r
: suffix-touching-corner ( face corner -- face ) \r
[ suffix ] curry change-touching-corners ; inline\r
: real-face? ( face -- ? )\r
- [ touching-corners>> length ] [ halfspace>> dimension ] bi >= ;\r
+ [ touching-corners>> length ] \r
+ [ halfspace>> dimension ] bi >= ;\r
\r
: (add-to-adjacent-faces) ( face face -- face )\r
over adjacent-faces>> 2dup member?\r
[ ] (intersection-into-face) ;\r
\r
: intersections-into-faces ( face -- faces )\r
- clone dup adjacent-faces>> [ intersection-into-face ] with map \r
+ clone dup \r
+ adjacent-faces>> [ intersection-into-face ] with map \r
[ ] filter ;\r
\r
: (face-silhouette) ( face -- faces )\r
\r
! --------------------------------\r
! solid\r
-! --------------------------------------------------------------\r
-TUPLE: solid dimension silhouettes faces corners adjacencies-valid color name ;\r
+! -------------------------------------------------------------\r
+TUPLE: solid dimension silhouettes \r
+ faces corners adjacencies-valid color name ;\r
\r
: <solid> ( -- tuple ) solid new ;\r
\r
: suffix-silhouettes ( solid silhouette -- solid ) \r
[ suffix ] curry change-silhouettes ;\r
\r
-: suffix-face ( solid face -- solid ) [ suffix ] curry change-faces ;\r
-\r
-: suffix-corner ( solid corner -- solid ) [ suffix ] curry change-corners ; \r
-\r
+: suffix-face ( solid face -- solid ) \r
+ [ suffix ] curry change-faces ;\r
+: suffix-corner ( solid corner -- solid ) \r
+ [ suffix ] curry change-corners ; \r
: erase-solid-corners ( solid -- solid ) f >>corners ;\r
\r
-: erase-silhouettes ( solid -- solid ) dup dimension>> f <array> >>silhouettes ;\r
-\r
-: filter-real-faces ( solid -- solid ) [ [ real-face? ] filter ] change-faces ;\r
-\r
+: erase-silhouettes ( solid -- solid ) \r
+ dup dimension>> f <array> >>silhouettes ;\r
+: filter-real-faces ( solid -- solid ) \r
+ [ [ real-face? ] filter ] change-faces ;\r
: initiate-solid-from-face ( face -- solid ) \r
face-project-dim <solid> swap >>dimension ;\r
\r
: erase-old-adjacencies ( solid -- solid )\r
erase-solid-corners\r
- [ dup [ erase-face-touching-corners erase-face-adjacent-faces drop ] each ]\r
+ [ dup [ erase-face-touching-corners \r
+ erase-face-adjacent-faces drop ] each ]\r
change-faces ;\r
\r
: point-inside-or-on-face? ( face v -- ? ) \r
[ halfspace>> ] dip point-inside-halfspace? ;\r
\r
: point-inside-solid? ( solid point -- ? )\r
- [ faces>> ] dip [ point-inside-face? ] curry all? ; inline\r
+ [ faces>> ] dip [ point-inside-face? ] curry all? ; inline\r
\r
: point-inside-or-on-solid? ( solid point -- ? )\r
- [ faces>> ] dip [ point-inside-or-on-face? ] curry all? ; inline\r
+ [ faces>> ] dip \r
+ [ point-inside-or-on-face? ] curry all? ; inline\r
\r
: unvalid-adjacencies ( solid -- solid ) \r
- erase-old-adjacencies f >>adjacencies-valid erase-silhouettes ;\r
+ erase-old-adjacencies f >>adjacencies-valid \r
+ erase-silhouettes ;\r
\r
: add-face ( solid face -- solid ) \r
suffix-face unvalid-adjacencies ; \r
ensure-silhouettes\r
;\r
\r
-: (non-empty-solid?) ( solid -- ? ) [ dimension>> ] [ corners>> length ] bi < ;\r
-: non-empty-solid? ( solid -- ? ) ensure-adjacencies (non-empty-solid?) ;\r
+: (non-empty-solid?) ( solid -- ? ) \r
+ [ dimension>> ] [ corners>> length ] bi < ;\r
+: non-empty-solid? ( solid -- ? ) \r
+ ensure-adjacencies (non-empty-solid?) ;\r
\r
: compare-corners-roughly ( corner corner -- ? )\r
2drop t ;\r
[ dup faces>> ] dip call drop \r
unvalid-adjacencies ; inline\r
\r
-: solid-translate ( solid v -- solid ) [ face-translate ] (solid-move) ; \r
-: solid-transform ( solid m -- solid ) [ face-transform ] (solid-move) ; \r
+: solid-translate ( solid v -- solid ) \r
+ [ face-translate ] (solid-move) ; \r
+: solid-transform ( solid m -- solid ) \r
+ [ face-transform ] (solid-move) ; \r
\r
: find-corner-in-silhouette ( s1 s2 -- elt bool )\r
pv> swap silhouettes>> nth \r
[ ensure-adjacencies ] map\r
; inline\r
\r
-! --------------------------------------------------------------\r
+! -------------------------------------------------------------\r
! space \r
-! --------------------------------------------------------------\r
+! -------------------------------------------------------------\r
TUPLE: space name dimension solids ambient-color lights ;\r
: <space> ( -- space ) space new ;\r
-: suffix-solids ( space solid -- space ) [ suffix ] curry change-solids ; inline\r
-: suffix-lights ( space light -- space ) [ suffix ] curry change-lights ; inline\r
+: suffix-solids ( space solid -- space ) \r
+ [ suffix ] curry change-solids ; inline\r
+: suffix-lights ( space light -- space ) \r
+ [ suffix ] curry change-lights ; inline\r
: clear-space-solids ( space -- space ) f >>solids ;\r
\r
: space-ensure-solids ( space -- space ) \r
[ [ non-empty-solid? ] filter ] change-solids ;\r
\r
: projected-space ( space solids -- space ) \r
- swap dimension>> 1- <space> swap >>dimension swap >>solids ;\r
+ swap dimension>> 1- <space> \r
+ swap >>dimension swap >>solids ;\r
\r
-: get-silhouette ( solid -- silhouette ) silhouettes>> pv> swap nth ;\r
-: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;\r
+: get-silhouette ( solid -- silhouette ) \r
+ silhouettes>> pv> swap nth ;\r
+: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;\r
\r
: space-apply ( space m quot -- space ) \r
curry [ map ] curry [ dup solids>> ] dip\r
[ call ] [ drop ] recover drop ;\r
-: space-transform ( space m -- space ) [ solid-transform ] space-apply ;\r
-: space-translate ( space v -- space ) [ solid-translate ] space-apply ; \r
+: space-transform ( space m -- space ) \r
+ [ solid-transform ] space-apply ;\r
+: space-translate ( space v -- space ) \r
+ [ solid-translate ] space-apply ; \r
\r
: describe-space ( space -- ) \r
- solids>> [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;\r
+ solids>> \r
+ [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;\r
\r
: clip-solid ( solid solid -- solids )\r
[ ]\r
; inline \r
\r
: remove-hidden-solids ( space -- space ) \r
-! We must include each solid in a sequence because during substration \r
+! We must include each solid in a sequence because \r
+! during substration \r
! a solid can be divided in more than on solid\r
[ \r
[ [ 1array ] map ] \r
[ [ ] [ v+ ] map-reduce ] [ length ] bi v/n\r
;\r
\r
-! --------------------------------------------------------------\r
+! -------------------------------------------------------------\r
! 3D rendering\r
-! --------------------------------------------------------------\r
+! -------------------------------------------------------------\r
\r
: face-reference ( face -- halfspace point vect )\r
[ halfspace>> ] \r
\r
: face->GL ( face color -- )\r
[ ordered-face-points ] dip\r
- [ first3 1.0 glColor4d GL_POLYGON [ [ point->GL ] each ] do-state ] curry\r
- [ 0 0 0 1 glColor4d GL_LINE_LOOP [ [ point->GL ] each ] do-state ]\r
+ [ first3 1.0 glColor4d GL_POLYGON \r
+ [ [ point->GL ] each ] do-state ] curry\r
+ [ 0 0 0 1 glColor4d GL_LINE_LOOP \r
+ [ [ point->GL ] each ] do-state ]\r
bi\r
; inline\r
\r
projects / factor.git / blobdiff