extra/adsoda/adsoda.factor

   1 ! Copyright (C) 2008 Jeff Bigot\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: accessors\r
   4 arrays \r
   5 assocs\r
   6 combinators\r
   7 kernel \r
   8 fry\r
   9 math \r
  10 math.constants\r
  11 math.functions\r
  12 math.libm\r
  13 math.order\r
  14 math.vectors \r
  15 math.matrices \r
  16 math.parser\r
  17 namespaces\r
  18 prettyprint\r
  19 sequences\r
  20 sequences.deep\r
  21 sets\r
  22 slots\r
  23 sorting\r
  24 tools.time\r
  25 vars\r
  26 continuations\r
  27 words\r
  28 opengl\r
  29 opengl.gl\r
  30 colors\r
  31 adsoda.solution2\r
  32 adsoda.combinators\r
  33 opengl.demo-support\r
  34 values\r
  35 tools.walker\r
  36 ;\r
  37 \r
  38 IN: adsoda\r
  39 \r
  40 DEFER: combinations\r
  41 VAR: pv\r
  42 \r
  43 \r
  44 ! -------------------------------------------------------------\r
  45 ! global values\r
  46 VALUE: remove-hidden-solids?\r
  47 VALUE: VERY-SMALL-NUM\r
  48 VALUE: ZERO-VALUE\r
  49 VALUE: MAX-FACE-PER-CORNER\r
  50 \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
  57 \r
  58 : with-pv ( i quot -- ) [ swap >pv call ] with-scope  ; inline\r
  59 \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  ; inline\r
  64 \r
  65 ! -------------------------------------------------------------\r
  66 ! light\r
  67 ! -------------------------------------------------------------\r
  68 \r
  69 TUPLE: light name { direction array } color ;\r
  70 : <light> ( -- tuple ) light new ;\r
  71 \r
  72 ! -------------------------------------------------------------\r
  73 ! halfspace manipulation\r
  74 ! -------------------------------------------------------------\r
  75 \r
  76 : constant+ ( v x -- w )  '[ [ _ + ] change-last ] keep ;\r
  77 : translate ( u v -- w )   dupd     v* sum     constant+ ; \r
  78 \r
  79 : transform ( u matrix -- w )\r
  80     [ swap m.v ] 2keep ! compute new normal vector    \r
  81     [\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
  85         last ! get constant\r
  86         swap /f neg swap ! intercept value\r
  87     ] dip  \r
  88     flip \r
  89     nth\r
  90     [ * ] with map ! apply intercep value\r
  91     over v*\r
  92     sum  neg\r
  93     suffix ! add value as constant at the end of equation\r
  94 ;\r
  95 \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
 106 \r
 107 : islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi*  ;\r
 108 \r
 109 : compare-nleft-to-identity-matrix ( seq n -- ? ) \r
 110     [ [ head ] curry map ] keep  identity-matrix m- \r
 111     flatten\r
 112     [ abs ZERO-VALUE < ] all?\r
 113 ;\r
 114 \r
 115 : valid-solution? ( matrice n -- ? )\r
 116     islenght=?\r
 117     [ compare-nleft-to-identity-matrix ]  \r
 118     [ 2drop f ] if ; inline\r
 119 \r
 120 : intersect-hyperplanes ( matrice -- seq )\r
 121     [ solution dup ] [ first dimension ] bi\r
 122     valid-solution?     [ get-intersection ] [ drop f ] if ;\r
 123 \r
 124 ! -------------------------------------------------------------\r
 125 ! faces\r
 126 ! -------------------------------------------------------------\r
 127 \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
 151 \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
 155 \r
 156 : add-to-adjacent-faces ( face face -- face )\r
 157     2dup =   [ drop ] [ (add-to-adjacent-faces) ] if ;\r
 158 \r
 159 : update-adjacent-faces ( faces corner -- )\r
 160    '[ [ _ suffix-touching-corner drop ] each ] keep \r
 161     2 among [ \r
 162         [ first ] keep second  \r
 163         [ add-to-adjacent-faces drop ] 2keep \r
 164         swap add-to-adjacent-faces drop  \r
 165     ] each ; inline\r
 166 \r
 167 : face-project-dim ( face -- x )  halfspace>> length 2 -  ;\r
 168 \r
 169 : apply-light ( color light normal -- u )\r
 170     over direction>>  v. \r
 171     neg dup 0 > \r
 172     [ \r
 173         [ color>> swap ] dip \r
 174         [ * ] curry map v+ \r
 175         [ 1 min ] map \r
 176     ] \r
 177     [ 2drop ] \r
 178     if\r
 179 ;\r
 180 \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
 186     v*\r
 187 ;\r
 188 \r
 189 : (intersection-into-face) ( face-init face-adja quot -- face )\r
 190     [\r
 191     [  [ pv-factor ] bi@ \r
 192         roll \r
 193         [ map ] 2bi@\r
 194         v-\r
 195     ] 2keep\r
 196     [ touching-corners>> ] bi@\r
 197     [ swap  [ = ] curry find  nip f = ] curry find nip\r
 198     ] dip  over\r
 199      [\r
 200         call\r
 201         dupd\r
 202         point-inside-halfspace? [ vneg ] unless \r
 203         <face> \r
 204      ] [ 3drop f ] if \r
 205     ; inline\r
 206 \r
 207 : intersection-into-face ( face-init face-adja -- face )\r
 208     [ [ project-vector ] bi@ ]     (intersection-into-face) ;\r
 209 \r
 210 : intersection-into-silhouette-face ( face-init face-adja -- face )\r
 211     [ ] (intersection-into-face) ;\r
 212 \r
 213 : intersections-into-faces ( face -- faces )\r
 214     clone dup  \r
 215     adjacent-faces>> [ intersection-into-face ] with map \r
 216     [ ] filter ;\r
 217 \r
 218 : (face-silhouette) ( face -- faces )\r
 219     clone dup adjacent-faces>>\r
 220     [   backface?\r
 221         [ intersection-into-silhouette-face ] [ 2drop f ]  if  \r
 222     ] with map \r
 223     [ ] filter\r
 224 ; inline\r
 225 \r
 226 : face-silhouette ( face -- faces )     \r
 227     backface? [ drop f ] [ (face-silhouette) ] if ;\r
 228 \r
 229 ! --------------------------------\r
 230 ! solid\r
 231 ! -------------------------------------------------------------\r
 232 TUPLE: solid dimension silhouettes \r
 233     faces corners adjacencies-valid color name ;\r
 234 \r
 235 : <solid> ( -- tuple ) solid new ;\r
 236 \r
 237 : suffix-silhouettes ( solid silhouette -- solid )  \r
 238     [ suffix ] curry change-silhouettes ;\r
 239 \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
 245 \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
 252 \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
 257     change-faces ;\r
 258 \r
 259 : point-inside-or-on-face? ( face v -- ? ) \r
 260     [ halfspace>> ] dip point-inside-or-on-halfspace?  ;\r
 261 \r
 262 : point-inside-face? ( face v -- ? ) \r
 263     [ halfspace>> ] dip  point-inside-halfspace? ;\r
 264 \r
 265 : point-inside-solid? ( solid point -- ? )\r
 266     [ faces>> ] dip [ point-inside-face? ] curry all? ; inline\r
 267 \r
 268 : point-inside-or-on-solid? ( solid point -- ? )\r
 269     [ faces>> ] dip \r
 270     [ point-inside-or-on-face? ] curry  all?   ; inline\r
 271 \r
 272 : unvalid-adjacencies ( solid -- solid )  \r
 273     erase-old-adjacencies f >>adjacencies-valid \r
 274     erase-silhouettes ;\r
 275 \r
 276 : add-face ( solid face -- solid ) \r
 277     suffix-face unvalid-adjacencies ; \r
 278 \r
 279 : cut-solid ( solid halfspace -- solid )    <face> add-face ; \r
 280 \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
 285 \r
 286 ! -------------\r
 287 \r
 288 \r
 289 : add-silhouette ( solid  -- solid )\r
 290    dup \r
 291    ! find-adjacencies \r
 292    faces>> { } \r
 293    [ face-silhouette append ] reduce\r
 294    [ ] filter \r
 295    <solid> \r
 296         swap >>faces\r
 297         over dimension>> >>dimension \r
 298         over name>> " silhouette " append \r
 299                  pv> number>string append \r
 300         >>name\r
 301      !   ensure-adjacencies\r
 302    suffix-silhouettes ; inline\r
 303 \r
 304 : find-silhouettes ( solid -- solid )\r
 305     { } >>silhouettes \r
 306     dup dimension>> [ [ add-silhouette ] with-pv ] each ;\r
 307 \r
 308 : ensure-silhouettes ( solid  -- solid )\r
 309     dup  silhouettes>>  [ f = ] all?\r
 310     [ find-silhouettes  ]  when ; \r
 311 \r
 312 ! ------------\r
 313 \r
 314 : corner-added? ( solid corner -- ? ) \r
 315     ! add corner to solid if it is inside solid\r
 316     [ ] \r
 317     [ point-inside-or-on-solid? ] \r
 318     [ swap corners>> member? not ] \r
 319     2tri and\r
 320     [ suffix-corner drop t ] [ 2drop f ] if ;\r
 321 \r
 322 : process-corner ( solid faces corner -- )\r
 323     swapd \r
 324     [ corner-added? ] keep swap ! test if corner is inside solid\r
 325     [ update-adjacent-faces ] \r
 326     [ 2drop ]\r
 327     if ;\r
 328 \r
 329 : compute-intersection ( solid faces -- )\r
 330     dup faces-intersection\r
 331     dup f = [ 3drop ] [ process-corner ]  if ;\r
 332 \r
 333 : test-faces-combinaisons ( solid n -- )\r
 334     [ dup faces>> ] dip among   \r
 335     [ compute-intersection ] with each ;\r
 336 \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
 341 \r
 342 : find-adjacencies ( solid -- solid ) \r
 343     erase-old-adjacencies   \r
 344     compute-adjacencies\r
 345     filter-real-faces \r
 346     t >>adjacencies-valid ;\r
 347 \r
 348 : ensure-adjacencies ( solid -- solid ) \r
 349     dup adjacencies-valid>> \r
 350     [ find-adjacencies ] unless \r
 351     ensure-silhouettes\r
 352     ;\r
 353 \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
 358 \r
 359 : compare-corners-roughly ( corner corner -- ? )\r
 360     2drop t ;\r
 361 ! : remove-inner-faces ( -- ) ;\r
 362 : face-project ( array face -- seq )\r
 363     backface? \r
 364   [ 2drop f ]\r
 365     [   [ enlight-projection ] \r
 366         [ initiate-solid-from-face ]\r
 367         [ intersections-into-faces ]  tri\r
 368         >>faces\r
 369         swap >>color        \r
 370     ]    if ;\r
 371 \r
 372 : solid-project ( lights ambient solid -- solids )\r
 373   ensure-adjacencies\r
 374     [ color>> ] [ faces>> ] bi [ 3array  ] dip\r
 375     [ face-project ] with map \r
 376     [ ] filter \r
 377     [ ensure-adjacencies ] map\r
 378 ;\r
 379 \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
 384 \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
 389 \r
 390 : find-corner-in-silhouette ( s1 s2 -- elt bool )\r
 391     pv> swap silhouettes>> nth     \r
 392     swap corners>>\r
 393     [ point-inside-solid? ] with find swap ;\r
 394 \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
 398 \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
 403 \r
 404 : (order-solid) ( s1 s2 -- int )\r
 405     2dup find-corner-in-silhouette\r
 406     [ check-orientation ] [ 3drop f ] if ;\r
 407 \r
 408 : order-solid ( solid solid  -- i ) \r
 409     2dup (order-solid)\r
 410     [ 2nip ]\r
 411     [   swap (order-solid)\r
 412         [ neg ] [ f ] if*\r
 413     ] if* ;\r
 414 \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
 420 ; inline\r
 421 \r
 422 ! -------------------------------------------------------------\r
 423 ! space \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
 432 \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
 437 \r
 438 : projected-space ( space solids -- space ) \r
 439    swap dimension>> 1-  <space>    \r
 440    swap >>dimension    swap  >>solids ;\r
 441 \r
 442 : get-silhouette ( solid -- silhouette )    \r
 443     silhouettes>> pv> swap nth ;\r
 444 : solid= ( solid solid -- ? )            [ corners>> ]  bi@ = ;\r
 445 \r
 446 : space-apply ( space m quot -- space ) \r
 447         curry [ map ] curry [ dup solids>> ] dip\r
 448         [ call ] [ 2drop ] recover drop ; inline\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
 453 \r
 454 : describe-space ( space -- ) \r
 455     solids>>  \r
 456     [  [ corners>>  [ pprint ] each ] [ name>> . ] bi ] each ;\r
 457 \r
 458 : clip-solid ( solid solid -- solids )\r
 459     [ ]\r
 460     [ solid= not ]\r
 461     [ order-solid -1 = ] 2tri \r
 462     and\r
 463     [ get-silhouette subtract ] \r
 464     [  drop 1array ] \r
 465     if \r
 466     \r
 467     ;\r
 468 \r
 469 : (solids-silhouette-subtract) ( solids solid -- solids ) \r
 470      [  clip-solid append ] curry { } -rot each ; inline\r
 471 \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
 475 ; inline \r
 476 \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
 481     [ \r
 482         [ [ 1array ] map ] \r
 483         [ length ] \r
 484         [ ] \r
 485         tri     \r
 486         [ solids-silhouette-subtract ] 2each\r
 487         { } [ append ] reduce \r
 488     ] change-solids\r
 489     eliminate-empty-solids ! TODO include into change-solids\r
 490 ;\r
 491 \r
 492 : space-project ( space i -- space )\r
 493   [\r
 494   [ clone  \r
 495     remove-hidden-solids? [ remove-hidden-solids ] when\r
 496     dup \r
 497         [ solids>> ] \r
 498         [ lights>> ] \r
 499         [ ambient-color>> ]  tri \r
 500         [ rot solid-project ] 2curry \r
 501         map \r
 502         [ append ] { } -rot each \r
 503         ! TODO project lights\r
 504         projected-space \r
 505       ! remove-inner-faces \r
 506       ! \r
 507       eliminate-empty-solids\r
 508     ] with-pv \r
 509     ] [ 3drop <space> ] recover\r
 510     ; inline\r
 511 \r
 512 : middle-of-space ( space -- point )\r
 513     solids>> [ corners>> ] map concat\r
 514     [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n\r
 515 ;\r
 516 \r
 517 ! -------------------------------------------------------------\r
 518 ! 3D rendering\r
 519 ! -------------------------------------------------------------\r
 520 \r
 521 : face-reference ( face -- halfspace point vect )\r
 522        [ halfspace>> ] \r
 523        [ touching-corners>> first ] \r
 524        [ touching-corners>> second ] tri \r
 525        over v-\r
 526 ;\r
 527 \r
 528 : theta ( v halfspace point vect -- v x )\r
 529    [ [ over ] dip v- ] dip    \r
 530    [ cross dup norm >float ]\r
 531    [ v. >float ]  \r
 532    2bi \r
 533    fatan2\r
 534    -rot v. \r
 535    0 < [ neg ] when\r
 536 ;\r
 537 \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
 543     append\r
 544     ; inline\r
 545 \r
 546 : point->GL  ( point -- )   gl-vertex ;\r
 547 : points->GL ( array -- )   do-cycle [ point->GL ] each ;\r
 548 \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
 555    bi\r
 556    ; inline\r
 557 \r
 558 : solid->GL ( solid -- )    \r
 559     [ faces>> ]    \r
 560     [ color>> ] bi\r
 561     [ face->GL ] curry each ; inline\r
 562 \r
 563 : space->GL ( space -- )\r
 564     solids>>\r
 565     [ solid->GL ] each ;\r
 566 \r
 567 \r
 568 \r
 569 \r
 570 \r