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