-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors\r
-arrays \r
-assocs\r
-combinators\r
-kernel \r
-fry\r
-math \r
-math.constants\r
-math.functions\r
-math.libm\r
-math.order\r
-math.vectors \r
-math.matrices \r
-math.parser\r
-namespaces\r
-prettyprint\r
-sequences\r
-sequences.deep\r
-sets\r
-slots\r
-sorting\r
-tools.time\r
-vars\r
-continuations\r
-words\r
-opengl\r
-opengl.gl\r
-colors\r
-adsoda.solution2\r
-adsoda.combinators\r
-opengl.demo-support\r
-values\r
-tools.walker\r
-;\r
-\r
-IN: adsoda\r
-\r
-DEFER: combinations\r
-VAR: pv\r
-\r
-\r
-! -------------------------------------------------------------\r
-! global values\r
-VALUE: remove-hidden-solids?\r
-VALUE: VERY-SMALL-NUM\r
-VALUE: ZERO-VALUE\r
-VALUE: MAX-FACE-PER-CORNER\r
-\r
-t \ remove-hidden-solids? set-value\r
-0.0000001 \ VERY-SMALL-NUM set-value\r
-0.0000001 \ ZERO-VALUE set-value\r
-4 \ MAX-FACE-PER-CORNER set-value\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
-: change-last ( seq quot -- ) \r
- [ [ dimension ] keep ] dip change-nth ; inline\r
-\r
-! -------------------------------------------------------------\r
-! light\r
-! -------------------------------------------------------------\r
-\r
-TUPLE: light name { direction array } color ;\r
-: <light> ( -- tuple ) light new ;\r
-\r
-! -------------------------------------------------------------\r
-! halfspace manipulation\r
-! -------------------------------------------------------------\r
-\r
-: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;\r
-: translate ( u v -- w ) dupd v* sum constant+ ; \r
-\r
-: transform ( u matrix -- w )\r
- [ swap m.v ] 2keep ! compute new normal vector \r
- [\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
- ] dip \r
- flip \r
- nth\r
- [ * ] with map ! apply intercep value\r
- over v*\r
- sum neg\r
- suffix ! add value as constant at the end of equation\r
-;\r
-\r
-: position-point ( halfspace v -- x ) \r
- -1 suffix v* sum ; inline\r
-: point-inside-halfspace? ( halfspace v -- ? ) \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 ) \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
-: compare-nleft-to-identity-matrix ( seq n -- ? ) \r
- [ [ head ] curry map ] keep identity-matrix m- \r
- flatten\r
- [ abs ZERO-VALUE < ] all?\r
-;\r
-\r
-: valid-solution? ( matrice n -- ? )\r
- islenght=?\r
- [ compare-nleft-to-identity-matrix ] \r
- [ 2drop f ] if ; inline\r
-\r
-: intersect-hyperplanes ( matrice -- seq )\r
- [ solution dup ] [ first dimension ] bi\r
- valid-solution? [ get-intersection ] [ drop f ] if ;\r
-\r
-! -------------------------------------------------------------\r
-! faces\r
-! -------------------------------------------------------------\r
-\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 ) \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
-: 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 ] \r
- [ halfspace>> dimension ] bi >= ;\r
-\r
-: (add-to-adjacent-faces) ( face face -- face )\r
- over adjacent-faces>> 2dup member?\r
- [ 2drop ] [ swap suffix >>adjacent-faces ] if ;\r
-\r
-: add-to-adjacent-faces ( face face -- face )\r
- 2dup = [ drop ] [ (add-to-adjacent-faces) ] if ;\r
-\r
-: update-adjacent-faces ( faces corner -- )\r
- '[ [ _ suffix-touching-corner drop ] each ] keep \r
- 2 among [ \r
- [ first ] keep second \r
- [ add-to-adjacent-faces drop ] 2keep \r
- swap add-to-adjacent-faces drop \r
- ] each ; inline\r
-\r
-: face-project-dim ( face -- x ) halfspace>> length 2 - ;\r
-\r
-: apply-light ( color light normal -- u )\r
- over direction>> v. \r
- neg dup 0 > \r
- [ \r
- [ color>> swap ] dip \r
- [ * ] curry map v+ \r
- [ 1 min ] map \r
- ] \r
- [ 2drop ] \r
- if\r
-;\r
-\r
-: enlight-projection ( array face -- color )\r
- ! array = lights + ambient color\r
- [ [ third ] [ second ] [ first ] tri ]\r
- [ halfspace>> project-vector normalize ] bi*\r
- [ apply-light ] curry each\r
- v*\r
-;\r
-\r
-: (intersection-into-face) ( face-init face-adja quot -- face )\r
- [\r
- [ [ pv-factor ] bi@ \r
- roll \r
- [ map ] 2bi@\r
- v-\r
- ] 2keep\r
- [ touching-corners>> ] bi@\r
- [ swap [ = ] curry find nip f = ] curry find nip\r
- ] dip over\r
- [\r
- call\r
- dupd\r
- point-inside-halfspace? [ vneg ] unless \r
- <face> \r
- ] [ 3drop f ] if \r
- ; inline\r
-\r
-: intersection-into-face ( face-init face-adja -- face )\r
- [ [ project-vector ] bi@ ] (intersection-into-face) ;\r
-\r
-: intersection-into-silhouette-face ( face-init face-adja -- face )\r
- [ ] (intersection-into-face) ;\r
-\r
-: intersections-into-faces ( face -- faces )\r
- clone dup \r
- adjacent-faces>> [ intersection-into-face ] with map \r
- sift ;\r
-\r
-: (face-silhouette) ( face -- faces )\r
- clone dup adjacent-faces>>\r
- [ backface?\r
- [ intersection-into-silhouette-face ] [ 2drop f ] if \r
- ] with map \r
- sift\r
-; inline\r
-\r
-: face-silhouette ( face -- faces ) \r
- backface? [ drop f ] [ (face-silhouette) ] if ;\r
-\r
-! --------------------------------\r
-! solid\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 ) \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 ) \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 \r
- erase-face-adjacent-faces drop ] each ]\r
- change-faces ;\r
-\r
-: point-inside-or-on-face? ( face v -- ? ) \r
- [ halfspace>> ] dip point-inside-or-on-halfspace? ;\r
-\r
-: point-inside-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
-\r
-: point-inside-or-on-solid? ( solid point -- ? )\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 \r
- erase-silhouettes ;\r
-\r
-: add-face ( solid face -- solid ) \r
- suffix-face unvalid-adjacencies ; \r
-\r
-: cut-solid ( solid halfspace -- solid ) <face> add-face ; \r
-\r
-: slice-solid ( solid face -- solid1 solid2 )\r
- [ [ clone ] bi@ flip-face add-face \r
- [ "/outer/" append ] change-name ] 2keep\r
- add-face [ "/inner/" append ] change-name ;\r
-\r
-! -------------\r
-\r
-\r
-: add-silhouette ( solid -- solid )\r
- dup \r
- ! find-adjacencies \r
- faces>> { } \r
- [ face-silhouette append ] reduce\r
- sift\r
- <solid> \r
- swap >>faces\r
- over dimension>> >>dimension \r
- over name>> " silhouette " append \r
- pv> number>string append \r
- >>name\r
- ! ensure-adjacencies\r
- suffix-silhouettes ; inline\r
-\r
-: find-silhouettes ( solid -- solid )\r
- { } >>silhouettes \r
- dup dimension>> [ [ add-silhouette ] with-pv ] each ;\r
-\r
-: ensure-silhouettes ( solid -- solid )\r
- dup silhouettes>> [ f = ] all?\r
- [ find-silhouettes ] when ; \r
-\r
-! ------------\r
-\r
-: corner-added? ( solid corner -- ? ) \r
- ! add corner to solid if it is inside solid\r
- [ ] \r
- [ point-inside-or-on-solid? ] \r
- [ swap corners>> member? not ] \r
- 2tri and\r
- [ suffix-corner drop t ] [ 2drop f ] if ;\r
-\r
-: process-corner ( solid faces corner -- )\r
- swapd \r
- [ corner-added? ] keep swap ! test if corner is inside solid\r
- [ update-adjacent-faces ] \r
- [ 2drop ]\r
- if ;\r
-\r
-: compute-intersection ( solid faces -- )\r
- dup faces-intersection\r
- dup f = [ 3drop ] [ process-corner ] if ;\r
-\r
-: test-faces-combinaisons ( solid n -- )\r
- [ dup faces>> ] dip among \r
- [ compute-intersection ] with each ;\r
-\r
-: compute-adjacencies ( solid -- solid )\r
- dup dimension>> [ >= ] curry \r
- [ keep swap ] curry MAX-FACE-PER-CORNER swap\r
- [ [ test-faces-combinaisons ] 2keep 1 - ] while drop ;\r
-\r
-: find-adjacencies ( solid -- solid ) \r
- erase-old-adjacencies \r
- compute-adjacencies\r
- filter-real-faces \r
- t >>adjacencies-valid ;\r
-\r
-: ensure-adjacencies ( solid -- solid ) \r
- dup adjacencies-valid>> \r
- [ find-adjacencies ] unless \r
- ensure-silhouettes\r
- ;\r
-\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
-! : remove-inner-faces ( -- ) ;\r
-: face-project ( array face -- seq )\r
- backface? \r
- [ 2drop f ]\r
- [ [ enlight-projection ] \r
- [ initiate-solid-from-face ]\r
- [ intersections-into-faces ] tri\r
- >>faces\r
- swap >>color \r
- ] if ;\r
-\r
-: solid-project ( lights ambient solid -- solids )\r
- ensure-adjacencies\r
- [ color>> ] [ faces>> ] bi [ 3array ] dip\r
- [ face-project ] with map \r
- sift\r
- [ ensure-adjacencies ] map\r
-;\r
-\r
-: (solid-move) ( solid v move -- solid ) \r
- curry [ map ] curry \r
- [ dup faces>> ] dip call drop \r
- unvalid-adjacencies ; inline\r
-\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
- swap corners>>\r
- [ point-inside-solid? ] with find swap ;\r
-\r
-: valid-face-for-order ( solid point -- face )\r
- [ point-inside-face? not ] \r
- [ drop face-orientation 0 = not ] 2bi and ;\r
-\r
-: check-orientation ( s1 s2 pt -- int )\r
- [ nip faces>> ] dip\r
- [ valid-face-for-order ] curry find swap\r
- [ face-orientation ] [ drop f ] if ;\r
-\r
-: (order-solid) ( s1 s2 -- int )\r
- 2dup find-corner-in-silhouette\r
- [ check-orientation ] [ 3drop f ] if ;\r
-\r
-: order-solid ( solid solid -- i ) \r
- 2dup (order-solid)\r
- [ 2nip ]\r
- [ swap (order-solid)\r
- [ neg ] [ f ] if*\r
- ] if* ;\r
-\r
-: subtract ( solid1 solid2 -- solids )\r
- faces>> swap clone ensure-adjacencies ensure-silhouettes \r
- [ swap slice-solid drop ] curry map\r
- [ non-empty-solid? ] filter\r
- [ ensure-adjacencies ] map\r
-; inline\r
-\r
-! -------------------------------------------------------------\r
-! space \r
-! -------------------------------------------------------------\r
-TUPLE: space name dimension solids ambient-color lights ;\r
-: <space> ( -- space ) space new ;\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
- [ [ ensure-adjacencies ] map ] change-solids ;\r
-: eliminate-empty-solids ( space -- space ) \r
- [ [ non-empty-solid? ] filter ] change-solids ;\r
-\r
-: projected-space ( space solids -- space ) \r
- swap dimension>> 1 - <space> \r
- swap >>dimension swap >>solids ;\r
-\r
-: get-silhouette ( solid -- silhouette ) \r
- silhouettes>> pv> swap nth ;\r
-: solid= ( solid solid -- ? ) [ corners>> ] same? ;\r
-\r
-: space-apply ( space m quot -- space ) \r
- curry [ map ] curry [ dup solids>> ] dip\r
- [ call ] [ 2drop ] recover drop ; inline\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>> \r
- [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;\r
-\r
-: clip-solid ( solid solid -- solids )\r
- [ ]\r
- [ solid= not ]\r
- [ order-solid -1 = ] 2tri \r
- and\r
- [ get-silhouette subtract ] \r
- [ drop 1array ] \r
- if \r
- \r
- ;\r
-\r
-: (solids-silhouette-subtract) ( solids solid -- solids ) \r
- [ clip-solid append ] curry { } -rot each ; inline\r
-\r
-: solids-silhouette-subtract ( solids i solid -- solids )\r
-! solids is an array of 1 solid arrays\r
- [ (solids-silhouette-subtract) ] curry map-but \r
-; inline \r
-\r
-: remove-hidden-solids ( space -- space ) \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
- [ length ] \r
- [ ] \r
- tri \r
- [ solids-silhouette-subtract ] 2each\r
- { } [ append ] reduce \r
- ] change-solids\r
- eliminate-empty-solids ! TODO include into change-solids\r
-;\r
-\r
-: space-project ( space i -- space )\r
- [\r
- [ clone \r
- remove-hidden-solids? [ remove-hidden-solids ] when\r
- dup \r
- [ solids>> ] \r
- [ lights>> ] \r
- [ ambient-color>> ] tri \r
- [ rot solid-project ] 2curry \r
- map \r
- [ append ] { } -rot each \r
- ! TODO project lights\r
- projected-space \r
- ! remove-inner-faces \r
- ! \r
- eliminate-empty-solids\r
- ] with-pv \r
- ] [ 3drop <space> ] recover\r
- ; inline\r
-\r
-: middle-of-space ( space -- point )\r
- solids>> [ corners>> ] map concat\r
- [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n\r
-;\r
-\r
-! -------------------------------------------------------------\r
-! 3D rendering\r
-! -------------------------------------------------------------\r
-\r
-: face-reference ( face -- halfspace point vect )\r
- [ halfspace>> ] \r
- [ touching-corners>> first ] \r
- [ touching-corners>> second ] tri \r
- over v-\r
-;\r
-\r
-: theta ( v halfspace point vect -- v x )\r
- [ [ over ] dip v- ] dip \r
- [ cross dup norm >float ]\r
- [ v. >float ] \r
- 2bi \r
- fatan2\r
- -rot v. \r
- 0 < [ neg ] when\r
-;\r
-\r
-: ordered-face-points ( face -- corners ) \r
- [ touching-corners>> 1 head ] \r
- [ touching-corners>> 1 tail ] \r
- [ face-reference [ theta ] 3curry ] tri\r
- { } map>assoc sort-values keys \r
- append\r
- ; inline\r
-\r
-: point->GL ( point -- ) gl-vertex ;\r
-: points->GL ( array -- ) do-cycle [ point->GL ] each ;\r
-\r
-: face->GL ( face color -- )\r
- [ ordered-face-points ] dip\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
-: solid->GL ( solid -- ) \r
- [ faces>> ] \r
- [ color>> ] bi\r
- [ face->GL ] curry each ; inline\r
-\r
-: space->GL ( space -- )\r
- solids>>\r
- [ solid->GL ] each ;\r
-\r
-\r
-\r
-\r
-\r
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors
+arrays
+assocs
+combinators
+kernel
+fry
+math
+math.constants
+math.functions
+math.libm
+math.order
+math.vectors
+math.matrices
+math.parser
+namespaces
+prettyprint
+sequences
+sequences.deep
+sets
+slots
+sorting
+tools.time
+vars
+continuations
+words
+opengl
+opengl.gl
+colors
+adsoda.solution2
+adsoda.combinators
+opengl.demo-support
+values
+tools.walker
+;
+
+IN: adsoda
+
+DEFER: combinations
+VAR: pv
+
+
+! -------------------------------------------------------------
+! global values
+VALUE: remove-hidden-solids?
+VALUE: VERY-SMALL-NUM
+VALUE: ZERO-VALUE
+VALUE: MAX-FACE-PER-CORNER
+
+t \ remove-hidden-solids? set-value
+0.0000001 \ VERY-SMALL-NUM set-value
+0.0000001 \ ZERO-VALUE set-value
+4 \ MAX-FACE-PER-CORNER set-value
+! -------------------------------------------------------------
+! sequence complement
+
+: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline
+
+: dimension ( array -- x ) length 1 - ; inline
+: change-last ( seq quot -- )
+ [ [ dimension ] keep ] dip change-nth ; inline
+
+! -------------------------------------------------------------
+! light
+! -------------------------------------------------------------
+
+TUPLE: light name { direction array } color ;
+: <light> ( -- tuple ) light new ;
+
+! -------------------------------------------------------------
+! halfspace manipulation
+! -------------------------------------------------------------
+
+: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;
+: translate ( u v -- w ) dupd v* sum constant+ ;
+
+: transform ( u matrix -- w )
+ [ swap m.v ] 2keep ! compute new normal vector
+ [
+ [ [ abs ZERO-VALUE > ] find ] keep
+ ! find a point on the frontier
+ ! be sure it's not null vector
+ last ! get constant
+ swap /f neg swap ! intercept value
+ ] dip
+ flip
+ nth
+ [ * ] with map ! apply intercep value
+ over v*
+ sum neg
+ suffix ! add value as constant at the end of equation
+;
+
+: position-point ( halfspace v -- x )
+ -1 suffix v* sum ; inline
+: point-inside-halfspace? ( halfspace v -- ? )
+ position-point VERY-SMALL-NUM > ;
+: point-inside-or-on-halfspace? ( halfspace v -- ? )
+ position-point VERY-SMALL-NUM neg > ;
+: project-vector ( seq -- seq )
+ pv> [ head ] [ 1 + tail ] 2bi append ;
+: get-intersection ( matrice -- seq )
+ [ 1 tail* ] map flip first ;
+
+: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;
+
+: compare-nleft-to-identity-matrix ( seq n -- ? )
+ [ [ head ] curry map ] keep identity-matrix m-
+ flatten
+ [ abs ZERO-VALUE < ] all?
+;
+
+: valid-solution? ( matrice n -- ? )
+ islenght=?
+ [ compare-nleft-to-identity-matrix ]
+ [ 2drop f ] if ; inline
+
+: intersect-hyperplanes ( matrice -- seq )
+ [ solution dup ] [ first dimension ] bi
+ valid-solution? [ get-intersection ] [ drop f ] if ;
+
+! -------------------------------------------------------------
+! faces
+! -------------------------------------------------------------
+
+TUPLE: face { halfspace array }
+ touching-corners adjacent-faces ;
+: <face> ( v -- tuple ) face new swap >>halfspace ;
+: flip-face ( face -- face ) [ vneg ] change-halfspace ;
+: erase-face-touching-corners ( face -- face )
+ f >>touching-corners ;
+: erase-face-adjacent-faces ( face -- face )
+ f >>adjacent-faces ;
+: faces-intersection ( faces -- v )
+ [ halfspace>> ] map intersect-hyperplanes ;
+: face-translate ( face v -- face )
+ [ translate ] curry change-halfspace ; inline
+: face-transform ( face m -- face )
+ [ transform ] curry change-halfspace ; inline
+: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;
+: backface? ( face -- face ? ) dup face-orientation 0 <= ;
+: pv-factor ( face -- f face )
+ halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline
+: suffix-touching-corner ( face corner -- face )
+ [ suffix ] curry change-touching-corners ; inline
+: real-face? ( face -- ? )
+ [ touching-corners>> length ]
+ [ halfspace>> dimension ] bi >= ;
+
+: (add-to-adjacent-faces) ( face face -- face )
+ over adjacent-faces>> 2dup member?
+ [ 2drop ] [ swap suffix >>adjacent-faces ] if ;
+
+: add-to-adjacent-faces ( face face -- face )
+ 2dup = [ drop ] [ (add-to-adjacent-faces) ] if ;
+
+: update-adjacent-faces ( faces corner -- )
+ '[ [ _ suffix-touching-corner drop ] each ] keep
+ 2 among [
+ [ first ] keep second
+ [ add-to-adjacent-faces drop ] 2keep
+ swap add-to-adjacent-faces drop
+ ] each ; inline
+
+: face-project-dim ( face -- x ) halfspace>> length 2 - ;
+
+: apply-light ( color light normal -- u )
+ over direction>> v.
+ neg dup 0 >
+ [
+ [ color>> swap ] dip
+ [ * ] curry map v+
+ [ 1 min ] map
+ ]
+ [ 2drop ]
+ if
+;
+
+: enlight-projection ( array face -- color )
+ ! array = lights + ambient color
+ [ [ third ] [ second ] [ first ] tri ]
+ [ halfspace>> project-vector normalize ] bi*
+ [ apply-light ] curry each
+ v*
+;
+
+: (intersection-into-face) ( face-init face-adja quot -- face )
+ [
+ [ [ pv-factor ] bi@
+ roll
+ [ map ] 2bi@
+ v-
+ ] 2keep
+ [ touching-corners>> ] bi@
+ [ swap [ = ] curry find nip f = ] curry find nip
+ ] dip over
+ [
+ call
+ dupd
+ point-inside-halfspace? [ vneg ] unless
+ <face>
+ ] [ 3drop f ] if
+ ; inline
+
+: intersection-into-face ( face-init face-adja -- face )
+ [ [ project-vector ] bi@ ] (intersection-into-face) ;
+
+: intersection-into-silhouette-face ( face-init face-adja -- face )
+ [ ] (intersection-into-face) ;
+
+: intersections-into-faces ( face -- faces )
+ clone dup
+ adjacent-faces>> [ intersection-into-face ] with map
+ sift ;
+
+: (face-silhouette) ( face -- faces )
+ clone dup adjacent-faces>>
+ [ backface?
+ [ intersection-into-silhouette-face ] [ 2drop f ] if
+ ] with map
+ sift
+; inline
+
+: face-silhouette ( face -- faces )
+ backface? [ drop f ] [ (face-silhouette) ] if ;
+
+! --------------------------------
+! solid
+! -------------------------------------------------------------
+TUPLE: solid dimension silhouettes
+ faces corners adjacencies-valid color name ;
+
+: <solid> ( -- tuple ) solid new ;
+
+: suffix-silhouettes ( solid silhouette -- solid )
+ [ suffix ] curry change-silhouettes ;
+
+: suffix-face ( solid face -- solid )
+ [ suffix ] curry change-faces ;
+: suffix-corner ( solid corner -- solid )
+ [ suffix ] curry change-corners ;
+: erase-solid-corners ( solid -- solid ) f >>corners ;
+
+: erase-silhouettes ( solid -- solid )
+ dup dimension>> f <array> >>silhouettes ;
+: filter-real-faces ( solid -- solid )
+ [ [ real-face? ] filter ] change-faces ;
+: initiate-solid-from-face ( face -- solid )
+ face-project-dim <solid> swap >>dimension ;
+
+: erase-old-adjacencies ( solid -- solid )
+ erase-solid-corners
+ [ dup [ erase-face-touching-corners
+ erase-face-adjacent-faces drop ] each ]
+ change-faces ;
+
+: point-inside-or-on-face? ( face v -- ? )
+ [ halfspace>> ] dip point-inside-or-on-halfspace? ;
+
+: point-inside-face? ( face v -- ? )
+ [ halfspace>> ] dip point-inside-halfspace? ;
+
+: point-inside-solid? ( solid point -- ? )
+ [ faces>> ] dip [ point-inside-face? ] curry all? ; inline
+
+: point-inside-or-on-solid? ( solid point -- ? )
+ [ faces>> ] dip
+ [ point-inside-or-on-face? ] curry all? ; inline
+
+: unvalid-adjacencies ( solid -- solid )
+ erase-old-adjacencies f >>adjacencies-valid
+ erase-silhouettes ;
+
+: add-face ( solid face -- solid )
+ suffix-face unvalid-adjacencies ;
+
+: cut-solid ( solid halfspace -- solid ) <face> add-face ;
+
+: slice-solid ( solid face -- solid1 solid2 )
+ [ [ clone ] bi@ flip-face add-face
+ [ "/outer/" append ] change-name ] 2keep
+ add-face [ "/inner/" append ] change-name ;
+
+! -------------
+
+
+: add-silhouette ( solid -- solid )
+ dup
+ ! find-adjacencies
+ faces>> { }
+ [ face-silhouette append ] reduce
+ sift
+ <solid>
+ swap >>faces
+ over dimension>> >>dimension
+ over name>> " silhouette " append
+ pv> number>string append
+ >>name
+ ! ensure-adjacencies
+ suffix-silhouettes ; inline
+
+: find-silhouettes ( solid -- solid )
+ { } >>silhouettes
+ dup dimension>> [ [ add-silhouette ] with-pv ] each ;
+
+: ensure-silhouettes ( solid -- solid )
+ dup silhouettes>> [ f = ] all?
+ [ find-silhouettes ] when ;
+
+! ------------
+
+: corner-added? ( solid corner -- ? )
+ ! add corner to solid if it is inside solid
+ [ ]
+ [ point-inside-or-on-solid? ]
+ [ swap corners>> member? not ]
+ 2tri and
+ [ suffix-corner drop t ] [ 2drop f ] if ;
+
+: process-corner ( solid faces corner -- )
+ swapd
+ [ corner-added? ] keep swap ! test if corner is inside solid
+ [ update-adjacent-faces ]
+ [ 2drop ]
+ if ;
+
+: compute-intersection ( solid faces -- )
+ dup faces-intersection
+ dup f = [ 3drop ] [ process-corner ] if ;
+
+: test-faces-combinaisons ( solid n -- )
+ [ dup faces>> ] dip among
+ [ compute-intersection ] with each ;
+
+: compute-adjacencies ( solid -- solid )
+ dup dimension>> [ >= ] curry
+ [ keep swap ] curry MAX-FACE-PER-CORNER swap
+ [ [ test-faces-combinaisons ] 2keep 1 - ] while drop ;
+
+: find-adjacencies ( solid -- solid )
+ erase-old-adjacencies
+ compute-adjacencies
+ filter-real-faces
+ t >>adjacencies-valid ;
+
+: ensure-adjacencies ( solid -- solid )
+ dup adjacencies-valid>>
+ [ find-adjacencies ] unless
+ ensure-silhouettes
+ ;
+
+: (non-empty-solid?) ( solid -- ? )
+ [ dimension>> ] [ corners>> length ] bi < ;
+: non-empty-solid? ( solid -- ? )
+ ensure-adjacencies (non-empty-solid?) ;
+
+: compare-corners-roughly ( corner corner -- ? )
+ 2drop t ;
+! : remove-inner-faces ( -- ) ;
+: face-project ( array face -- seq )
+ backface?
+ [ 2drop f ]
+ [ [ enlight-projection ]
+ [ initiate-solid-from-face ]
+ [ intersections-into-faces ] tri
+ >>faces
+ swap >>color
+ ] if ;
+
+: solid-project ( lights ambient solid -- solids )
+ ensure-adjacencies
+ [ color>> ] [ faces>> ] bi [ 3array ] dip
+ [ face-project ] with map
+ sift
+ [ ensure-adjacencies ] map
+;
+
+: (solid-move) ( solid v move -- solid )
+ curry [ map ] curry
+ [ dup faces>> ] dip call drop
+ unvalid-adjacencies ; inline
+
+: solid-translate ( solid v -- solid )
+ [ face-translate ] (solid-move) ;
+: solid-transform ( solid m -- solid )
+ [ face-transform ] (solid-move) ;
+
+: find-corner-in-silhouette ( s1 s2 -- elt bool )
+ pv> swap silhouettes>> nth
+ swap corners>>
+ [ point-inside-solid? ] with find swap ;
+
+: valid-face-for-order ( solid point -- face )
+ [ point-inside-face? not ]
+ [ drop face-orientation 0 = not ] 2bi and ;
+
+: check-orientation ( s1 s2 pt -- int )
+ [ nip faces>> ] dip
+ [ valid-face-for-order ] curry find swap
+ [ face-orientation ] [ drop f ] if ;
+
+: (order-solid) ( s1 s2 -- int )
+ 2dup find-corner-in-silhouette
+ [ check-orientation ] [ 3drop f ] if ;
+
+: order-solid ( solid solid -- i )
+ 2dup (order-solid)
+ [ 2nip ]
+ [ swap (order-solid)
+ [ neg ] [ f ] if*
+ ] if* ;
+
+: subtract ( solid1 solid2 -- solids )
+ faces>> swap clone ensure-adjacencies ensure-silhouettes
+ [ swap slice-solid drop ] curry map
+ [ non-empty-solid? ] filter
+ [ ensure-adjacencies ] map
+; inline
+
+! -------------------------------------------------------------
+! space
+! -------------------------------------------------------------
+TUPLE: space name dimension solids ambient-color lights ;
+: <space> ( -- space ) space new ;
+: suffix-solids ( space solid -- space )
+ [ suffix ] curry change-solids ; inline
+: suffix-lights ( space light -- space )
+ [ suffix ] curry change-lights ; inline
+: clear-space-solids ( space -- space ) f >>solids ;
+
+: space-ensure-solids ( space -- space )
+ [ [ ensure-adjacencies ] map ] change-solids ;
+: eliminate-empty-solids ( space -- space )
+ [ [ non-empty-solid? ] filter ] change-solids ;
+
+: projected-space ( space solids -- space )
+ swap dimension>> 1 - <space>
+ swap >>dimension swap >>solids ;
+
+: get-silhouette ( solid -- silhouette )
+ silhouettes>> pv> swap nth ;
+: solid= ( solid solid -- ? ) [ corners>> ] same? ;
+
+: space-apply ( space m quot -- space )
+ curry [ map ] curry [ dup solids>> ] dip
+ [ call ] [ 2drop ] recover drop ; inline
+: space-transform ( space m -- space )
+ [ solid-transform ] space-apply ;
+: space-translate ( space v -- space )
+ [ solid-translate ] space-apply ;
+
+: describe-space ( space -- )
+ solids>>
+ [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;
+
+: clip-solid ( solid solid -- solids )
+ [ ]
+ [ solid= not ]
+ [ order-solid -1 = ] 2tri
+ and
+ [ get-silhouette subtract ]
+ [ drop 1array ]
+ if
+
+ ;
+
+: (solids-silhouette-subtract) ( solids solid -- solids )
+ [ clip-solid append ] curry { } -rot each ; inline
+
+: solids-silhouette-subtract ( solids i solid -- solids )
+! solids is an array of 1 solid arrays
+ [ (solids-silhouette-subtract) ] curry map-but
+; inline
+
+: remove-hidden-solids ( space -- space )
+! We must include each solid in a sequence because
+! during substration
+! a solid can be divided in more than on solid
+ [
+ [ [ 1array ] map ]
+ [ length ]
+ [ ]
+ tri
+ [ solids-silhouette-subtract ] 2each
+ { } [ append ] reduce
+ ] change-solids
+ eliminate-empty-solids ! TODO include into change-solids
+;
+
+: space-project ( space i -- space )
+ [
+ [ clone
+ remove-hidden-solids? [ remove-hidden-solids ] when
+ dup
+ [ solids>> ]
+ [ lights>> ]
+ [ ambient-color>> ] tri
+ [ rot solid-project ] 2curry
+ map
+ [ append ] { } -rot each
+ ! TODO project lights
+ projected-space
+ ! remove-inner-faces
+ !
+ eliminate-empty-solids
+ ] with-pv
+ ] [ 3drop <space> ] recover
+ ; inline
+
+: middle-of-space ( space -- point )
+ solids>> [ corners>> ] map concat
+ [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n
+;
+
+! -------------------------------------------------------------
+! 3D rendering
+! -------------------------------------------------------------
+
+: face-reference ( face -- halfspace point vect )
+ [ halfspace>> ]
+ [ touching-corners>> first ]
+ [ touching-corners>> second ] tri
+ over v-
+;
+
+: theta ( v halfspace point vect -- v x )
+ [ [ over ] dip v- ] dip
+ [ cross dup norm >float ]
+ [ v. >float ]
+ 2bi
+ fatan2
+ -rot v.
+ 0 < [ neg ] when
+;
+
+: ordered-face-points ( face -- corners )
+ [ touching-corners>> 1 head ]
+ [ touching-corners>> 1 tail ]
+ [ face-reference [ theta ] 3curry ] tri
+ { } map>assoc sort-values keys
+ append
+ ; inline
+
+: point->GL ( point -- ) gl-vertex ;
+: points->GL ( array -- ) do-cycle [ point->GL ] each ;
+
+: face->GL ( face color -- )
+ [ ordered-face-points ] dip
+ [ first3 1.0 glColor4d GL_POLYGON
+ [ [ point->GL ] each ] do-state ] curry
+ [ 0 0 0 1 glColor4d GL_LINE_LOOP
+ [ [ point->GL ] each ] do-state ]
+ bi
+ ; inline
+
+: solid->GL ( solid -- )
+ [ faces>> ]
+ [ color>> ] bi
+ [ face->GL ] curry each ; inline
+
+: space->GL ( space -- )
+ solids>>
+ [ solid->GL ] each ;
+
+
+
+
+
projects / factor.git / blobdiff