1 ! Copyright (C) 2008 Jeff Bigot
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
44 ! -------------------------------------------------------------
\r
46 VALUE: remove-hidden-solids?
\r
47 VALUE: VERY-SMALL-NUM
\r
49 VALUE: MAX-FACE-PER-CORNER
\r
51 t to: remove-hidden-solids?
\r
52 0.0000001 to: VERY-SMALL-NUM
\r
53 0.0000001 to: ZERO-VALUE
\r
54 4 to: MAX-FACE-PER-CORNER
\r
55 ! -------------------------------------------------------------
\r
56 ! sequence complement
\r
58 : with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline
\r
60 : dimension ( array -- x ) length 1- ; inline
\r
61 : last ( seq -- x ) [ dimension ] [ nth ] bi ; inline
\r
62 : change-last ( seq quot -- )
\r
63 [ [ dimension ] keep ] dip change-nth ;
\r
65 ! -------------------------------------------------------------
\r
67 ! -------------------------------------------------------------
\r
69 TUPLE: light name { direction array } color ;
\r
70 : <light> ( -- tuple ) light new ;
\r
72 ! -------------------------------------------------------------
\r
73 ! halfspace manipulation
\r
74 ! -------------------------------------------------------------
\r
76 : constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;
\r
77 : translate ( u v -- w ) dupd v* sum constant+ ;
\r
79 : transform ( u matrix -- w )
\r
80 [ swap m.v ] 2keep ! compute new normal vector
\r
82 [ [ abs ZERO-VALUE > ] find ] keep
\r
83 ! find a point on the frontier
\r
84 ! be sure it's not null vector
\r
86 swap /f neg swap ! intercept value
\r
90 [ * ] with map ! apply intercep value
\r
93 suffix ! add value as constant at the end of equation
\r
96 : position-point ( halfspace v -- x )
\r
97 -1 suffix v* sum ; inline
\r
98 : point-inside-halfspace? ( halfspace v -- ? )
\r
99 position-point VERY-SMALL-NUM > ;
\r
100 : point-inside-or-on-halfspace? ( halfspace v -- ? )
\r
101 position-point VERY-SMALL-NUM neg > ;
\r
102 : project-vector ( seq -- seq )
\r
103 pv> [ head ] [ 1+ tail ] 2bi append ;
\r
104 : get-intersection ( matrice -- seq )
\r
105 [ 1 tail* ] map flip first ;
\r
107 : islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;
\r
109 : compare-nleft-to-identity-matrix ( seq n -- ? )
\r
110 [ [ head ] curry map ] keep identity-matrix m-
\r
112 [ abs ZERO-VALUE < ] all?
\r
115 : valid-solution? ( matrice n -- ? )
\r
117 [ compare-nleft-to-identity-matrix ]
\r
118 [ 2drop f ] if ; inline
\r
120 : intersect-hyperplanes ( matrice -- seq )
\r
121 [ solution dup ] [ first dimension ] bi
\r
122 valid-solution? [ get-intersection ] [ drop f ] if ;
\r
124 ! -------------------------------------------------------------
\r
126 ! -------------------------------------------------------------
\r
128 TUPLE: face { halfspace array }
\r
129 touching-corners adjacent-faces ;
\r
130 : <face> ( v -- tuple ) face new swap >>halfspace ;
\r
131 : flip-face ( face -- face ) [ vneg ] change-halfspace ;
\r
132 : erase-face-touching-corners ( face -- face )
\r
133 f >>touching-corners ;
\r
134 : erase-face-adjacent-faces ( face -- face )
\r
135 f >>adjacent-faces ;
\r
136 : faces-intersection ( faces -- v )
\r
137 [ halfspace>> ] map intersect-hyperplanes ;
\r
138 : face-translate ( face v -- face )
\r
139 [ translate ] curry change-halfspace ; inline
\r
140 : face-transform ( face m -- face )
\r
141 [ transform ] curry change-halfspace ; inline
\r
142 : face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;
\r
143 : backface? ( face -- face ? ) dup face-orientation 0 <= ;
\r
144 : pv-factor ( face -- f face )
\r
145 halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline
\r
146 : suffix-touching-corner ( face corner -- face )
\r
147 [ suffix ] curry change-touching-corners ; inline
\r
148 : real-face? ( face -- ? )
\r
149 [ touching-corners>> length ]
\r
150 [ halfspace>> dimension ] bi >= ;
\r
152 : (add-to-adjacent-faces) ( face face -- face )
\r
153 over adjacent-faces>> 2dup member?
\r
154 [ 2drop ] [ swap suffix >>adjacent-faces ] if ;
\r
156 : add-to-adjacent-faces ( face face -- face )
\r
157 2dup = [ drop ] [ (add-to-adjacent-faces) ] if ;
\r
159 : update-adjacent-faces ( faces corner -- )
\r
160 '[ [ _ suffix-touching-corner drop ] each ] keep
\r
162 [ first ] keep second
\r
163 [ add-to-adjacent-faces drop ] 2keep
\r
164 swap add-to-adjacent-faces drop
\r
167 : face-project-dim ( face -- x ) halfspace>> length 2 - ;
\r
169 : apply-light ( color light normal -- u )
\r
170 over direction>> v.
\r
173 [ color>> swap ] dip
\r
174 [ * ] curry map v+
\r
181 : enlight-projection ( array face -- color )
\r
182 ! array = lights + ambient color
\r
183 [ [ third ] [ second ] [ first ] tri ]
\r
184 [ halfspace>> project-vector normalize ] bi*
\r
185 [ apply-light ] curry each
\r
189 : (intersection-into-face) ( face-init face-adja quot -- face )
\r
191 [ [ pv-factor ] bi@
\r
196 [ touching-corners>> ] bi@
\r
197 [ swap [ = ] curry find nip f = ] curry find nip
\r
202 point-inside-halfspace? [ vneg ] unless
\r
207 : intersection-into-face ( face-init face-adja -- face )
\r
208 [ [ project-vector ] bi@ ] (intersection-into-face) ;
\r
210 : intersection-into-silhouette-face ( face-init face-adja -- face )
\r
211 [ ] (intersection-into-face) ;
\r
213 : intersections-into-faces ( face -- faces )
\r
215 adjacent-faces>> [ intersection-into-face ] with map
\r
218 : (face-silhouette) ( face -- faces )
\r
219 clone dup adjacent-faces>>
\r
221 [ intersection-into-silhouette-face ] [ 2drop f ] if
\r
226 : face-silhouette ( face -- faces )
\r
227 backface? [ drop f ] [ (face-silhouette) ] if ;
\r
229 ! --------------------------------
\r
231 ! -------------------------------------------------------------
\r
232 TUPLE: solid dimension silhouettes
\r
233 faces corners adjacencies-valid color name ;
\r
235 : <solid> ( -- tuple ) solid new ;
\r
237 : suffix-silhouettes ( solid silhouette -- solid )
\r
238 [ suffix ] curry change-silhouettes ;
\r
240 : suffix-face ( solid face -- solid )
\r
241 [ suffix ] curry change-faces ;
\r
242 : suffix-corner ( solid corner -- solid )
\r
243 [ suffix ] curry change-corners ;
\r
244 : erase-solid-corners ( solid -- solid ) f >>corners ;
\r
246 : erase-silhouettes ( solid -- solid )
\r
247 dup dimension>> f <array> >>silhouettes ;
\r
248 : filter-real-faces ( solid -- solid )
\r
249 [ [ real-face? ] filter ] change-faces ;
\r
250 : initiate-solid-from-face ( face -- solid )
\r
251 face-project-dim <solid> swap >>dimension ;
\r
253 : erase-old-adjacencies ( solid -- solid )
\r
254 erase-solid-corners
\r
255 [ dup [ erase-face-touching-corners
\r
256 erase-face-adjacent-faces drop ] each ]
\r
259 : point-inside-or-on-face? ( face v -- ? )
\r
260 [ halfspace>> ] dip point-inside-or-on-halfspace? ;
\r
262 : point-inside-face? ( face v -- ? )
\r
263 [ halfspace>> ] dip point-inside-halfspace? ;
\r
265 : point-inside-solid? ( solid point -- ? )
\r
266 [ faces>> ] dip [ point-inside-face? ] curry all? ; inline
\r
268 : point-inside-or-on-solid? ( solid point -- ? )
\r
270 [ point-inside-or-on-face? ] curry all? ; inline
\r
272 : unvalid-adjacencies ( solid -- solid )
\r
273 erase-old-adjacencies f >>adjacencies-valid
\r
274 erase-silhouettes ;
\r
276 : add-face ( solid face -- solid )
\r
277 suffix-face unvalid-adjacencies ;
\r
279 : cut-solid ( solid halfspace -- solid ) <face> add-face ;
\r
281 : slice-solid ( solid face -- solid1 solid2 )
\r
282 [ [ clone ] bi@ flip-face add-face
\r
283 [ "/outer/" append ] change-name ] 2keep
\r
284 add-face [ "/inner/" append ] change-name ;
\r
289 : add-silhouette ( solid -- solid )
\r
291 ! find-adjacencies
\r
293 [ face-silhouette append ] reduce
\r
297 over dimension>> >>dimension
\r
298 over name>> " silhouette " append
\r
299 pv> number>string append
\r
301 ! ensure-adjacencies
\r
302 suffix-silhouettes ; inline
\r
304 : find-silhouettes ( solid -- solid )
\r
306 dup dimension>> [ [ add-silhouette ] with-pv ] each ;
\r
308 : ensure-silhouettes ( solid -- solid )
\r
309 dup silhouettes>> [ f = ] all?
\r
310 [ find-silhouettes ] when ;
\r
314 : corner-added? ( solid corner -- ? )
\r
315 ! add corner to solid if it is inside solid
\r
317 [ point-inside-or-on-solid? ]
\r
318 [ swap corners>> member? not ]
\r
320 [ suffix-corner drop t ] [ 2drop f ] if ;
\r
322 : process-corner ( solid faces corner -- )
\r
324 [ corner-added? ] keep swap ! test if corner is inside solid
\r
325 [ update-adjacent-faces ]
\r
329 : compute-intersection ( solid faces -- )
\r
330 dup faces-intersection
\r
331 dup f = [ 3drop ] [ process-corner ] if ;
\r
333 : test-faces-combinaisons ( solid n -- )
\r
334 [ dup faces>> ] dip among
\r
335 [ compute-intersection ] with each ;
\r
337 : compute-adjacencies ( solid -- solid )
\r
338 dup dimension>> [ >= ] curry
\r
339 [ keep swap ] curry MAX-FACE-PER-CORNER swap
\r
340 [ [ test-faces-combinaisons ] 2keep 1- ] while drop ;
\r
342 : find-adjacencies ( solid -- solid )
\r
343 erase-old-adjacencies
\r
344 compute-adjacencies
\r
346 t >>adjacencies-valid ;
\r
348 : ensure-adjacencies ( solid -- solid )
\r
349 dup adjacencies-valid>>
\r
350 [ find-adjacencies ] unless
\r
354 : (non-empty-solid?) ( solid -- ? )
\r
355 [ dimension>> ] [ corners>> length ] bi < ;
\r
356 : non-empty-solid? ( solid -- ? )
\r
357 ensure-adjacencies (non-empty-solid?) ;
\r
359 : compare-corners-roughly ( corner corner -- ? )
\r
361 ! : remove-inner-faces ( -- ) ;
\r
362 : face-project ( array face -- seq )
\r
365 [ [ enlight-projection ]
\r
366 [ initiate-solid-from-face ]
\r
367 [ intersections-into-faces ] tri
\r
372 : solid-project ( lights ambient solid -- solids )
\r
374 [ color>> ] [ faces>> ] bi [ 3array ] dip
\r
375 [ face-project ] with map
\r
377 [ ensure-adjacencies ] map
\r
380 : (solid-move) ( solid v move -- solid )
\r
381 curry [ map ] curry
\r
382 [ dup faces>> ] dip call drop
\r
383 unvalid-adjacencies ; inline
\r
385 : solid-translate ( solid v -- solid )
\r
386 [ face-translate ] (solid-move) ;
\r
387 : solid-transform ( solid m -- solid )
\r
388 [ face-transform ] (solid-move) ;
\r
390 : find-corner-in-silhouette ( s1 s2 -- elt bool )
\r
391 pv> swap silhouettes>> nth
\r
393 [ point-inside-solid? ] with find swap ;
\r
395 : valid-face-for-order ( solid point -- face )
\r
396 [ point-inside-face? not ]
\r
397 [ drop face-orientation 0 = not ] 2bi and ;
\r
399 : check-orientation ( s1 s2 pt -- int )
\r
400 [ nip faces>> ] dip
\r
401 [ valid-face-for-order ] curry find swap
\r
402 [ face-orientation ] [ drop f ] if ;
\r
404 : (order-solid) ( s1 s2 -- int )
\r
405 2dup find-corner-in-silhouette
\r
406 [ check-orientation ] [ 3drop f ] if ;
\r
408 : order-solid ( solid solid -- i )
\r
411 [ swap (order-solid)
\r
415 : subtract ( solid1 solid2 -- solids )
\r
416 faces>> swap clone ensure-adjacencies ensure-silhouettes
\r
417 [ swap slice-solid drop ] curry map
\r
418 [ non-empty-solid? ] filter
\r
419 [ ensure-adjacencies ] map
\r
422 ! -------------------------------------------------------------
\r
424 ! -------------------------------------------------------------
\r
425 TUPLE: space name dimension solids ambient-color lights ;
\r
426 : <space> ( -- space ) space new ;
\r
427 : suffix-solids ( space solid -- space )
\r
428 [ suffix ] curry change-solids ; inline
\r
429 : suffix-lights ( space light -- space )
\r
430 [ suffix ] curry change-lights ; inline
\r
431 : clear-space-solids ( space -- space ) f >>solids ;
\r
433 : space-ensure-solids ( space -- space )
\r
434 [ [ ensure-adjacencies ] map ] change-solids ;
\r
435 : eliminate-empty-solids ( space -- space )
\r
436 [ [ non-empty-solid? ] filter ] change-solids ;
\r
438 : projected-space ( space solids -- space )
\r
439 swap dimension>> 1- <space>
\r
440 swap >>dimension swap >>solids ;
\r
442 : get-silhouette ( solid -- silhouette )
\r
443 silhouettes>> pv> swap nth ;
\r
444 : solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;
\r
446 : space-apply ( space m quot -- space )
\r
447 curry [ map ] curry [ dup solids>> ] dip
\r
448 [ call ] [ drop ] recover drop ;
\r
449 : space-transform ( space m -- space )
\r
450 [ solid-transform ] space-apply ;
\r
451 : space-translate ( space v -- space )
\r
452 [ solid-translate ] space-apply ;
\r
454 : describe-space ( space -- )
\r
456 [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;
\r
458 : clip-solid ( solid solid -- solids )
\r
461 [ order-solid -1 = ] 2tri
\r
463 [ get-silhouette subtract ]
\r
469 : (solids-silhouette-subtract) ( solids solid -- solids )
\r
470 [ clip-solid append ] curry { } -rot each ; inline
\r
472 : solids-silhouette-subtract ( solids i solid -- solids )
\r
473 ! solids is an array of 1 solid arrays
\r
474 [ (solids-silhouette-subtract) ] curry map-but
\r
477 : remove-hidden-solids ( space -- space )
\r
478 ! We must include each solid in a sequence because
\r
479 ! during substration
\r
480 ! a solid can be divided in more than on solid
\r
482 [ [ 1array ] map ]
\r
486 [ solids-silhouette-subtract ] 2each
\r
487 { } [ append ] reduce
\r
489 eliminate-empty-solids ! TODO include into change-solids
\r
492 : space-project ( space i -- space )
\r
495 remove-hidden-solids? [ remove-hidden-solids ] when
\r
499 [ ambient-color>> ] tri
\r
500 [ rot solid-project ] 2curry
\r
502 [ append ] { } -rot each
\r
503 ! TODO project lights
\r
505 ! remove-inner-faces
\r
507 eliminate-empty-solids
\r
509 ] [ 3drop <space> ] recover
\r
512 : middle-of-space ( space -- point )
\r
513 solids>> [ corners>> ] map concat
\r
514 [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n
\r
517 ! -------------------------------------------------------------
\r
519 ! -------------------------------------------------------------
\r
521 : face-reference ( face -- halfspace point vect )
\r
523 [ touching-corners>> first ]
\r
524 [ touching-corners>> second ] tri
\r
528 : theta ( v halfspace point vect -- v x )
\r
529 [ [ over ] dip v- ] dip
\r
530 [ cross dup norm >float ]
\r
538 : ordered-face-points ( face -- corners )
\r
539 [ touching-corners>> 1 head ]
\r
540 [ touching-corners>> 1 tail ]
\r
541 [ face-reference [ theta ] 3curry ] tri
\r
542 { } map>assoc sort-values keys
\r
546 : point->GL ( point -- ) gl-vertex ;
\r
547 : points->GL ( array -- ) do-cycle [ point->GL ] each ;
\r
549 : face->GL ( face color -- )
\r
550 [ ordered-face-points ] dip
\r
551 [ first3 1.0 glColor4d GL_POLYGON
\r
552 [ [ point->GL ] each ] do-state ] curry
\r
553 [ 0 0 0 1 glColor4d GL_LINE_LOOP
\r
554 [ [ point->GL ] each ] do-state ]
\r
558 : solid->GL ( solid -- )
\r
561 [ face->GL ] curry each ; inline
\r
563 : space->GL ( space -- )
\r
565 [ solid->GL ] each ;
\r