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