unmaintained/adsoda/adsoda.factor

   1 ! Copyright (C) 2008 Jeff Bigot
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors
   4 arrays
   5 assocs
   6 combinators
   7 kernel
   8 fry
   9 math
  10 math.constants
  11 math.functions
  12 math.libm
  13 math.order
  14 math.vectors
  15 math.matrices
  16 math.parser
  17 namespaces
  18 prettyprint
  19 sequences
  20 sequences.deep
  21 sets
  22 slots
  23 sorting
  24 tools.time
  25 vars
  26 continuations
  27 words
  28 opengl
  29 opengl.gl
  30 colors
  31 adsoda.solution2
  32 adsoda.combinators
  33 opengl.demo-support
  34 values
  35 tools.walker
  36 ;
  37
  38 IN: adsoda
  39
  40 DEFER: combinations
  41 VAR: pv
  42
  43
  44 ! -------------------------------------------------------------
  45 ! global values
  46 VALUE: remove-hidden-solids?
  47 VALUE: VERY-SMALL-NUM
  48 VALUE: ZERO-VALUE
  49 VALUE: MAX-FACE-PER-CORNER
  50
  51 t \ remove-hidden-solids? set-value
  52 0.0000001 \ VERY-SMALL-NUM set-value
  53 0.0000001 \ ZERO-VALUE set-value
  54 4 \ 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
  68 TUPLE: 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
 127 TUPLE: 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     sift ;
 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     sift
 223 ; inline
 224
 225 : face-silhouette ( face -- faces )
 226     backface? [ drop f ] [ (face-silhouette) ] if ;
 227
 228 ! --------------------------------
 229 ! solid
 230 ! -------------------------------------------------------------
 231 TUPLE: 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    sift
 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     sift
 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 ! -------------------------------------------------------------
 424 TUPLE: 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