/unmaintained/adsoda/adsoda.factor

  1! Copyright (C) 2008 Jeff Bigot
  2! See http://factorcode.org/license.txt for BSD license.
  3USING: accessors
  4arrays 
  5assocs
  6combinators
  7kernel 
  8fry
  9math 
 10math.constants
 11math.functions
 12math.libm
 13math.order
 14math.vectors 
 15math.matrices 
 16math.parser
 17namespaces
 18prettyprint
 19sequences
 20sequences.deep
 21sets
 22slots
 23sorting
 24tools.time
 25vars
 26continuations
 27words
 28opengl
 29opengl.gl
 30colors
 31adsoda.solution2
 32adsoda.combinators
 33opengl.demo-support
 34values
 35tools.walker
 36;
 37
 38IN: adsoda
 39
 40DEFER: combinations
 41VAR: pv
 42
 43
 44! -------------------------------------------------------------
 45! global values
 46VALUE: remove-hidden-solids?
 47VALUE: VERY-SMALL-NUM
 48VALUE: ZERO-VALUE
 49VALUE: MAX-FACE-PER-CORNER
 50
 51t \ remove-hidden-solids? set-value
 520.0000001 \ VERY-SMALL-NUM set-value
 530.0000001 \ ZERO-VALUE set-value
 544 \ MAX-FACE-PER-CORNER set-value
 55! -------------------------------------------------------------
 56! sequence complement
 57
 58: with-pv ( i quot -- ) [ swap >pv call ] with-scope  ; inline
 59
 60: dimension ( array -- x )      length 1 - ; inline 
 61: change-last ( seq quot -- ) 
 62    [ [ dimension ] keep ] dip change-nth  ; inline
 63
 64! -------------------------------------------------------------
 65! light
 66! -------------------------------------------------------------
 67
 68TUPLE: light name { direction array } color ;
 69: <light> ( -- tuple ) light new ;
 70
 71! -------------------------------------------------------------
 72! halfspace manipulation
 73! -------------------------------------------------------------
 74
 75: constant+ ( v x -- w )  '[ [ _ + ] change-last ] keep ;
 76: translate ( u v -- w )   dupd     v* sum     constant+ ; 
 77
 78: transform ( u matrix -- w )
 79    [ swap m.v ] 2keep ! compute new normal vector    
 80    [
 81        [ [ abs ZERO-VALUE > ] find ] keep 
 82        ! find a point on the frontier
 83        ! be sure it's not null vector
 84        last ! get constant
 85        swap /f neg swap ! intercept value
 86    ] dip  
 87    flip 
 88    nth
 89    [ * ] with map ! apply intercep value
 90    over v*
 91    sum  neg
 92    suffix ! add value as constant at the end of equation
 93;
 94
 95: position-point ( halfspace v -- x ) 
 96    -1 suffix v* sum  ; inline
 97: point-inside-halfspace? ( halfspace v -- ? )       
 98    position-point VERY-SMALL-NUM  > ; 
 99: point-inside-or-on-halfspace? ( halfspace v -- ? ) 
100    position-point VERY-SMALL-NUM neg > ;
101: project-vector (  seq -- seq )     
102    pv> [ head ] [ 1 +  tail ] 2bi append ; 
103: get-intersection ( matrice -- seq )     
104    [ 1 tail* ] map     flip first ;
105
106: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi*  ;
107
108: compare-nleft-to-identity-matrix ( seq n -- ? ) 
109    [ [ head ] curry map ] keep  identity-matrix m- 
110    flatten
111    [ abs ZERO-VALUE < ] all?
112;
113
114: valid-solution? ( matrice n -- ? )
115    islenght=?
116    [ compare-nleft-to-identity-matrix ]  
117    [ 2drop f ] if ; inline
118
119: intersect-hyperplanes ( matrice -- seq )
120    [ solution dup ] [ first dimension ] bi
121    valid-solution?     [ get-intersection ] [ drop f ] if ;
122
123! -------------------------------------------------------------
124! faces
125! -------------------------------------------------------------
126
127TUPLE: face { halfspace array } 
128    touching-corners adjacent-faces ;
129: <face> ( v -- tuple )       face new swap >>halfspace ;
130: flip-face ( face -- face ) [ vneg ] change-halfspace ;
131: erase-face-touching-corners ( face -- face ) 
132    f >>touching-corners ;
133: erase-face-adjacent-faces ( face -- face )   
134    f >>adjacent-faces ;
135: faces-intersection ( faces -- v )  
136    [ halfspace>> ] map intersect-hyperplanes ;
137: face-translate ( face v -- face ) 
138    [ translate ] curry change-halfspace ; inline
139: face-transform ( face m -- face )
140    [ transform ] curry change-halfspace ; inline
141: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;
142: backface? ( face -- face ? )      dup face-orientation 0 <= ;
143: pv-factor ( face -- f face )     
144    halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline
145: suffix-touching-corner ( face corner -- face ) 
146    [ suffix ] curry   change-touching-corners ; inline
147: real-face? ( face -- ? )
148    [ touching-corners>> length ] 
149    [ halfspace>> dimension ] bi >= ;
150
151: (add-to-adjacent-faces) ( face face -- face )
152    over adjacent-faces>> 2dup member?
153    [ 2drop ] [ swap suffix >>adjacent-faces ] if ;
154
155: add-to-adjacent-faces ( face face -- face )
156    2dup =   [ drop ] [ (add-to-adjacent-faces) ] if ;
157
158: update-adjacent-faces ( faces corner -- )
159   '[ [ _ suffix-touching-corner drop ] each ] keep 
160    2 among [ 
161        [ first ] keep second  
162        [ add-to-adjacent-faces drop ] 2keep 
163        swap add-to-adjacent-faces drop  
164    ] each ; inline
165
166: face-project-dim ( face -- x )  halfspace>> length 2 -  ;
167
168: apply-light ( color light normal -- u )
169    over direction>>  v. 
170    neg dup 0 > 
171    [ 
172        [ color>> swap ] dip 
173        [ * ] curry map v+ 
174        [ 1 min ] map 
175    ] 
176    [ 2drop ] 
177    if
178;
179
180: enlight-projection ( array face -- color )
181    ! array = lights + ambient color
182    [ [ third ] [ second ] [ first ] tri ]
183    [ halfspace>> project-vector normalize ] bi*
184    [ apply-light ] curry each
185    v*
186;
187
188: (intersection-into-face) ( face-init face-adja quot -- face )
189    [
190    [  [ pv-factor ] bi@ 
191        roll 
192        [ map ] 2bi@
193        v-
194    ] 2keep
195    [ touching-corners>> ] bi@
196    [ swap  [ = ] curry find  nip f = ] curry find nip
197    ] dip  over
198     [
199        call
200        dupd
201        point-inside-halfspace? [ vneg ] unless 
202        <face> 
203     ] [ 3drop f ] if 
204    ; inline
205
206: intersection-into-face ( face-init face-adja -- face )
207    [ [ project-vector ] bi@ ]     (intersection-into-face) ;
208
209: intersection-into-silhouette-face ( face-init face-adja -- face )
210    [ ] (intersection-into-face) ;
211
212: intersections-into-faces ( face -- faces )
213    clone dup  
214    adjacent-faces>> [ intersection-into-face ] with map 
215    [ ] filter ;
216
217: (face-silhouette) ( face -- faces )
218    clone dup adjacent-faces>>
219    [   backface?
220        [ intersection-into-silhouette-face ] [ 2drop f ]  if  
221    ] with map 
222    [ ] filter
223; inline
224
225: face-silhouette ( face -- faces )     
226    backface? [ drop f ] [ (face-silhouette) ] if ;
227
228! --------------------------------
229! solid
230! -------------------------------------------------------------
231TUPLE: solid dimension silhouettes 
232    faces corners adjacencies-valid color name ;
233
234: <solid> ( -- tuple ) solid new ;
235
236: suffix-silhouettes ( solid silhouette -- solid )  
237    [ suffix ] curry change-silhouettes ;
238
239: suffix-face ( solid face -- solid )     
240    [ suffix ] curry change-faces ;
241: suffix-corner ( solid corner -- solid ) 
242    [ suffix ] curry change-corners ; 
243: erase-solid-corners ( solid -- solid )  f >>corners ;
244
245: erase-silhouettes ( solid -- solid ) 
246    dup dimension>> f <array> >>silhouettes ;
247: filter-real-faces ( solid -- solid ) 
248    [ [ real-face? ] filter ] change-faces ;
249: initiate-solid-from-face ( face -- solid ) 
250    face-project-dim  <solid> swap >>dimension ;
251
252: erase-old-adjacencies ( solid -- solid )
253    erase-solid-corners
254    [ dup [ erase-face-touching-corners 
255        erase-face-adjacent-faces drop ] each ]
256    change-faces ;
257
258: point-inside-or-on-face? ( face v -- ? ) 
259    [ halfspace>> ] dip point-inside-or-on-halfspace?  ;
260
261: point-inside-face? ( face v -- ? ) 
262    [ halfspace>> ] dip  point-inside-halfspace? ;
263
264: point-inside-solid? ( solid point -- ? )
265    [ faces>> ] dip [ point-inside-face? ] curry all? ; inline
266
267: point-inside-or-on-solid? ( solid point -- ? )
268    [ faces>> ] dip 
269    [ point-inside-or-on-face? ] curry  all?   ; inline
270
271: unvalid-adjacencies ( solid -- solid )  
272    erase-old-adjacencies f >>adjacencies-valid 
273    erase-silhouettes ;
274
275: add-face ( solid face -- solid ) 
276    suffix-face unvalid-adjacencies ; 
277
278: cut-solid ( solid halfspace -- solid )    <face> add-face ; 
279
280: slice-solid ( solid face  -- solid1 solid2 )
281    [ [ clone ] bi@ flip-face add-face 
282    [ "/outer/" append ] change-name  ] 2keep
283    add-face [ "/inner/" append ] change-name ;
284
285! -------------
286
287
288: add-silhouette ( solid  -- solid )
289   dup 
290   ! find-adjacencies 
291   faces>> { } 
292   [ face-silhouette append ] reduce
293   [ ] filter 
294   <solid> 
295        swap >>faces
296        over dimension>> >>dimension 
297        over name>> " silhouette " append 
298                 pv> number>string append 
299        >>name
300     !   ensure-adjacencies
301   suffix-silhouettes ; inline
302
303: find-silhouettes ( solid -- solid )
304    { } >>silhouettes 
305    dup dimension>> [ [ add-silhouette ] with-pv ] each ;
306
307: ensure-silhouettes ( solid  -- solid )
308    dup  silhouettes>>  [ f = ] all?
309    [ find-silhouettes  ]  when ; 
310
311! ------------
312
313: corner-added? ( solid corner -- ? ) 
314    ! add corner to solid if it is inside solid
315    [ ] 
316    [ point-inside-or-on-solid? ] 
317    [ swap corners>> member? not ] 
318    2tri and
319    [ suffix-corner drop t ] [ 2drop f ] if ;
320
321: process-corner ( solid faces corner -- )
322    swapd 
323    [ corner-added? ] keep swap ! test if corner is inside solid
324    [ update-adjacent-faces ] 
325    [ 2drop ]
326    if ;
327
328: compute-intersection ( solid faces -- )
329    dup faces-intersection
330    dup f = [ 3drop ] [ process-corner ]  if ;
331
332: test-faces-combinaisons ( solid n -- )
333    [ dup faces>> ] dip among   
334    [ compute-intersection ] with each ;
335
336: compute-adjacencies ( solid -- solid )
337    dup dimension>> [ >= ] curry 
338    [ keep swap ] curry MAX-FACE-PER-CORNER swap
339    [ [ test-faces-combinaisons ] 2keep 1 - ] while drop ;
340
341: find-adjacencies ( solid -- solid ) 
342    erase-old-adjacencies   
343    compute-adjacencies
344    filter-real-faces 
345    t >>adjacencies-valid ;
346
347: ensure-adjacencies ( solid -- solid ) 
348    dup adjacencies-valid>> 
349    [ find-adjacencies ] unless 
350    ensure-silhouettes
351    ;
352
353: (non-empty-solid?) ( solid -- ? ) 
354    [ dimension>> ] [ corners>> length ] bi < ;
355: non-empty-solid? ( solid -- ? )   
356    ensure-adjacencies (non-empty-solid?) ;
357
358: compare-corners-roughly ( corner corner -- ? )
359    2drop t ;
360! : remove-inner-faces ( -- ) ;
361: face-project ( array face -- seq )
362    backface? 
363  [ 2drop f ]
364    [   [ enlight-projection ] 
365        [ initiate-solid-from-face ]
366        [ intersections-into-faces ]  tri
367        >>faces
368        swap >>color        
369    ]    if ;
370
371: solid-project ( lights ambient solid -- solids )
372  ensure-adjacencies
373    [ color>> ] [ faces>> ] bi [ 3array  ] dip
374    [ face-project ] with map 
375    [ ] filter 
376    [ ensure-adjacencies ] map
377;
378
379: (solid-move) ( solid v move -- solid ) 
380   curry [ map ] curry 
381   [ dup faces>> ] dip call drop  
382   unvalid-adjacencies ; inline
383
384: solid-translate ( solid v -- solid ) 
385    [ face-translate ] (solid-move) ; 
386: solid-transform ( solid m -- solid ) 
387    [ face-transform ] (solid-move) ; 
388
389: find-corner-in-silhouette ( s1 s2 -- elt bool )
390    pv> swap silhouettes>> nth     
391    swap corners>>
392    [ point-inside-solid? ] with find swap ;
393
394: valid-face-for-order ( solid point -- face )
395    [ point-inside-face? not ] 
396    [ drop face-orientation  0 = not ] 2bi and ;
397
398: check-orientation ( s1 s2 pt -- int )
399    [ nip faces>> ] dip
400    [ valid-face-for-order ] curry find swap
401    [ face-orientation ] [ drop f ] if ;
402
403: (order-solid) ( s1 s2 -- int )
404    2dup find-corner-in-silhouette
405    [ check-orientation ] [ 3drop f ] if ;
406
407: order-solid ( solid solid  -- i ) 
408    2dup (order-solid)
409    [ 2nip ]
410    [   swap (order-solid)
411        [ neg ] [ f ] if*
412    ] if* ;
413
414: subtract ( solid1 solid2 -- solids )
415    faces>> swap clone ensure-adjacencies ensure-silhouettes  
416    [ swap slice-solid drop ]  curry map
417    [ non-empty-solid? ] filter
418    [ ensure-adjacencies ] map
419; inline
420
421! -------------------------------------------------------------
422! space 
423! -------------------------------------------------------------
424TUPLE: space name dimension solids ambient-color lights ;
425: <space> ( -- space )      space new ;
426: suffix-solids ( space solid -- space ) 
427    [ suffix ] curry change-solids ; inline
428: suffix-lights ( space light -- space ) 
429    [ suffix ] curry change-lights ; inline
430: clear-space-solids ( space -- space )     f >>solids ;
431
432: space-ensure-solids ( space -- space ) 
433    [ [ ensure-adjacencies ] map ] change-solids ;
434: eliminate-empty-solids ( space -- space ) 
435    [ [ non-empty-solid? ] filter ] change-solids ;
436
437: projected-space ( space solids -- space ) 
438   swap dimension>> 1 -  <space>    
439   swap >>dimension    swap  >>solids ;
440
441: get-silhouette ( solid -- silhouette )    
442    silhouettes>> pv> swap nth ;
443: solid= ( solid solid -- ? )            [ corners>> ]  same? ;
444
445: space-apply ( space m quot -- space ) 
446        curry [ map ] curry [ dup solids>> ] dip
447        [ call ] [ 2drop ] recover drop ; inline
448: space-transform ( space m -- space ) 
449    [ solid-transform ] space-apply ;
450: space-translate ( space v -- space ) 
451    [ solid-translate ] space-apply ; 
452
453: describe-space ( space -- ) 
454    solids>>  
455    [  [ corners>>  [ pprint ] each ] [ name>> . ] bi ] each ;
456
457: clip-solid ( solid solid -- solids )
458    [ ]
459    [ solid= not ]
460    [ order-solid -1 = ] 2tri 
461    and
462    [ get-silhouette subtract ] 
463    [  drop 1array ] 
464    if 
465    
466    ;
467
468: (solids-silhouette-subtract) ( solids solid -- solids ) 
469     [  clip-solid append ] curry { } -rot each ; inline
470
471: solids-silhouette-subtract ( solids i solid -- solids )
472! solids is an array of 1 solid arrays
473      [ (solids-silhouette-subtract) ] curry map-but 
474; inline 
475
476: remove-hidden-solids ( space -- space ) 
477! We must include each solid in a sequence because 
478! during substration 
479! a solid can be divided in more than on solid
480    [ 
481        [ [ 1array ] map ] 
482        [ length ] 
483        [ ] 
484        tri     
485        [ solids-silhouette-subtract ] 2each
486        { } [ append ] reduce 
487    ] change-solids
488    eliminate-empty-solids ! TODO include into change-solids
489;
490
491: space-project ( space i -- space )
492  [
493  [ clone  
494    remove-hidden-solids? [ remove-hidden-solids ] when
495    dup 
496        [ solids>> ] 
497        [ lights>> ] 
498        [ ambient-color>> ]  tri 
499        [ rot solid-project ] 2curry 
500        map 
501        [ append ] { } -rot each 
502        ! TODO project lights
503        projected-space 
504      ! remove-inner-faces 
505      ! 
506      eliminate-empty-solids
507    ] with-pv 
508    ] [ 3drop <space> ] recover
509    ; inline
510
511: middle-of-space ( space -- point )
512    solids>> [ corners>> ] map concat
513    [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n
514;
515
516! -------------------------------------------------------------
517! 3D rendering
518! -------------------------------------------------------------
519
520: face-reference ( face -- halfspace point vect )
521       [ halfspace>> ] 
522       [ touching-corners>> first ] 
523       [ touching-corners>> second ] tri 
524       over v-
525;
526
527: theta ( v halfspace point vect -- v x )
528   [ [ over ] dip v- ] dip    
529   [ cross dup norm >float ]
530   [ v. >float ]  
531   2bi 
532   fatan2
533   -rot v. 
534   0 < [ neg ] when
535;
536
537: ordered-face-points ( face -- corners )  
538    [ touching-corners>> 1 head ] 
539    [ touching-corners>> 1 tail ] 
540    [ face-reference [ theta ] 3curry ]         tri
541    { } map>assoc    sort-values keys 
542    append
543    ; inline
544
545: point->GL  ( point -- )   gl-vertex ;
546: points->GL ( array -- )   do-cycle [ point->GL ] each ;
547
548: face->GL ( face color -- )
549   [ ordered-face-points ] dip
550   [ first3 1.0 glColor4d GL_POLYGON 
551        [ [ point->GL  ] each ] do-state ] curry
552   [  0 0 0 1 glColor4d GL_LINE_LOOP 
553        [ [ point->GL  ] each ] do-state ]
554   bi
555   ; inline
556
557: solid->GL ( solid -- )    
558    [ faces>> ]    
559    [ color>> ] bi
560    [ face->GL ] curry each ; inline
561
562: space->GL ( space -- )
563    solids>>
564    [ solid->GL ] each ;
565
566
567
568
569