! Copyright (C) 2008 Jeff Bigot

! See http://factorcode.org/license.txt for BSD license.

USING: accessors

arrays 

assocs

combinators

kernel 

fry

math 

math.constants

math.functions

math.libm

math.order

math.vectors 

math.matrices 

math.parser

namespaces

prettyprint

sequences

sequences.deep

sets

slots

sorting

tools.time

vars

continuations

words

opengl

opengl.gl

colors

adsoda.solution2

adsoda.combinators

opengl.demo-support

values

tools.walker

;



IN: adsoda



DEFER: combinations

VAR: pv





! -------------------------------------------------------------

! global values

VALUE: remove-hidden-solids?

VALUE: VERY-SMALL-NUM

VALUE: ZERO-VALUE

VALUE: MAX-FACE-PER-CORNER



t \ remove-hidden-solids? set-value

0.0000001 \ VERY-SMALL-NUM set-value

0.0000001 \ ZERO-VALUE set-value

4 \ MAX-FACE-PER-CORNER set-value

! -------------------------------------------------------------

! sequence complement



: with-pv ( i quot -- ) [ swap >pv call ] with-scope  ; inline



: dimension ( array -- x )      length 1 - ; inline 

: change-last ( seq quot -- ) 

    [ [ dimension ] keep ] dip change-nth  ; inline



! -------------------------------------------------------------

! light

! -------------------------------------------------------------



TUPLE: light name { direction array } color ;

: <light> ( -- tuple ) light new ;



! -------------------------------------------------------------

! halfspace manipulation

! -------------------------------------------------------------



: constant+ ( v x -- w )  '[ [ _ + ] change-last ] keep ;

: translate ( u v -- w )   dupd     v* sum     constant+ ; 



: transform ( u matrix -- w )

    [ swap m.v ] 2keep ! compute new normal vector    

    [

        [ [ abs ZERO-VALUE > ] find ] keep 

        ! find a point on the frontier

        ! be sure it's not null vector

        last ! get constant

        swap /f neg swap ! intercept value

    ] dip  

    flip 

    nth

    [ * ] with map ! apply intercep value

    over v*

    sum  neg

    suffix ! add value as constant at the end of equation

;



: position-point ( halfspace v -- x ) 

    -1 suffix v* sum  ; inline

: point-inside-halfspace? ( halfspace v -- ? )       

    position-point VERY-SMALL-NUM  > ; 

: point-inside-or-on-halfspace? ( halfspace v -- ? ) 

    position-point VERY-SMALL-NUM neg > ;

: project-vector (  seq -- seq )     

    pv> [ head ] [ 1 +  tail ] 2bi append ; 

: get-intersection ( matrice -- seq )     

    [ 1 tail* ] map     flip first ;



: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi*  ;



: compare-nleft-to-identity-matrix ( seq n -- ? ) 

    [ [ head ] curry map ] keep  identity-matrix m- 

    flatten

    [ abs ZERO-VALUE < ] all?

;



: valid-solution? ( matrice n -- ? )

    islenght=?

    [ compare-nleft-to-identity-matrix ]  

    [ 2drop f ] if ; inline



: intersect-hyperplanes ( matrice -- seq )

    [ solution dup ] [ first dimension ] bi

    valid-solution?     [ get-intersection ] [ drop f ] if ;



! -------------------------------------------------------------

! faces

! -------------------------------------------------------------



TUPLE: face { halfspace array } 

    touching-corners adjacent-faces ;

: <face> ( v -- tuple )       face new swap >>halfspace ;

: flip-face ( face -- face ) [ vneg ] change-halfspace ;

: erase-face-touching-corners ( face -- face ) 

    f >>touching-corners ;

: erase-face-adjacent-faces ( face -- face )   

    f >>adjacent-faces ;

: faces-intersection ( faces -- v )  

    [ halfspace>> ] map intersect-hyperplanes ;

: face-translate ( face v -- face ) 

    [ translate ] curry change-halfspace ; inline

: face-transform ( face m -- face )

    [ transform ] curry change-halfspace ; inline

: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;

: backface? ( face -- face ? )      dup face-orientation 0 <= ;

: pv-factor ( face -- f face )     

    halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline

: suffix-touching-corner ( face corner -- face ) 

    [ suffix ] curry   change-touching-corners ; inline

: real-face? ( face -- ? )

    [ touching-corners>> length ] 

    [ halfspace>> dimension ] bi >= ;



: (add-to-adjacent-faces) ( face face -- face )

    over adjacent-faces>> 2dup member?

    [ 2drop ] [ swap suffix >>adjacent-faces ] if ;



: add-to-adjacent-faces ( face face -- face )

    2dup =   [ drop ] [ (add-to-adjacent-faces) ] if ;



: update-adjacent-faces ( faces corner -- )

   '[ [ _ suffix-touching-corner drop ] each ] keep 

    2 among [ 

        [ first ] keep second  

        [ add-to-adjacent-faces drop ] 2keep 

        swap add-to-adjacent-faces drop  

    ] each ; inline



: face-project-dim ( face -- x )  halfspace>> length 2 -  ;



: apply-light ( color light normal -- u )

    over direction>>  v. 

    neg dup 0 > 

    [ 

        [ color>> swap ] dip 

        [ * ] curry map v+ 

        [ 1 min ] map 

    ] 

    [ 2drop ] 

    if

;



: enlight-projection ( array face -- color )

    ! array = lights + ambient color

    [ [ third ] [ second ] [ first ] tri ]

    [ halfspace>> project-vector normalize ] bi*

    [ apply-light ] curry each

    v*

;



: (intersection-into-face) ( face-init face-adja quot -- face )

    [

    [  [ pv-factor ] bi@ 

        roll 

        [ map ] 2bi@

        v-

    ] 2keep

    [ touching-corners>> ] bi@

    [ swap  [ = ] curry find  nip f = ] curry find nip

    ] dip  over

     [

        call

        dupd

        point-inside-halfspace? [ vneg ] unless 

        <face> 

     ] [ 3drop f ] if 

    ; inline



: intersection-into-face ( face-init face-adja -- face )

    [ [ project-vector ] bi@ ]     (intersection-into-face) ;



: intersection-into-silhouette-face ( face-init face-adja -- face )

    [ ] (intersection-into-face) ;



: intersections-into-faces ( face -- faces )

    clone dup  

    adjacent-faces>> [ intersection-into-face ] with map 

    [ ] filter ;



: (face-silhouette) ( face -- faces )

    clone dup adjacent-faces>>

    [   backface?

        [ intersection-into-silhouette-face ] [ 2drop f ]  if  

    ] with map 

    [ ] filter

; inline



: face-silhouette ( face -- faces )     

    backface? [ drop f ] [ (face-silhouette) ] if ;



! --------------------------------

! solid

! -------------------------------------------------------------

TUPLE: solid dimension silhouettes 

    faces corners adjacencies-valid color name ;



: <solid> ( -- tuple ) solid new ;



: suffix-silhouettes ( solid silhouette -- solid )  

    [ suffix ] curry change-silhouettes ;



: suffix-face ( solid face -- solid )     

    [ suffix ] curry change-faces ;

: suffix-corner ( solid corner -- solid ) 

    [ suffix ] curry change-corners ; 

: erase-solid-corners ( solid -- solid )  f >>corners ;



: erase-silhouettes ( solid -- solid ) 

    dup dimension>> f <array> >>silhouettes ;

: filter-real-faces ( solid -- solid ) 

    [ [ real-face? ] filter ] change-faces ;

: initiate-solid-from-face ( face -- solid ) 

    face-project-dim  <solid> swap >>dimension ;



: erase-old-adjacencies ( solid -- solid )

    erase-solid-corners

    [ dup [ erase-face-touching-corners 

        erase-face-adjacent-faces drop ] each ]

    change-faces ;



: point-inside-or-on-face? ( face v -- ? ) 

    [ halfspace>> ] dip point-inside-or-on-halfspace?  ;



: point-inside-face? ( face v -- ? ) 

    [ halfspace>> ] dip  point-inside-halfspace? ;



: point-inside-solid? ( solid point -- ? )

    [ faces>> ] dip [ point-inside-face? ] curry all? ; inline



: point-inside-or-on-solid? ( solid point -- ? )

    [ faces>> ] dip 

    [ point-inside-or-on-face? ] curry  all?   ; inline



: unvalid-adjacencies ( solid -- solid )  

    erase-old-adjacencies f >>adjacencies-valid 

    erase-silhouettes ;



: add-face ( solid face -- solid ) 

    suffix-face unvalid-adjacencies ; 



: cut-solid ( solid halfspace -- solid )    <face> add-face ; 



: slice-solid ( solid face  -- solid1 solid2 )

    [ [ clone ] bi@ flip-face add-face 

    [ "/outer/" append ] change-name  ] 2keep

    add-face [ "/inner/" append ] change-name ;



! -------------





: add-silhouette ( solid  -- solid )

   dup 

   ! find-adjacencies 

   faces>> { } 

   [ face-silhouette append ] reduce

   [ ] filter 

   <solid> 

        swap >>faces

        over dimension>> >>dimension 

        over name>> " silhouette " append 

                 pv> number>string append 

        >>name

     !   ensure-adjacencies

   suffix-silhouettes ; inline



: find-silhouettes ( solid -- solid )

    { } >>silhouettes 

    dup dimension>> [ [ add-silhouette ] with-pv ] each ;



: ensure-silhouettes ( solid  -- solid )

    dup  silhouettes>>  [ f = ] all?

    [ find-silhouettes  ]  when ; 



! ------------



: corner-added? ( solid corner -- ? ) 

    ! add corner to solid if it is inside solid

    [ ] 

    [ point-inside-or-on-solid? ] 

    [ swap corners>> member? not ] 

    2tri and

    [ suffix-corner drop t ] [ 2drop f ] if ;



: process-corner ( solid faces corner -- )

    swapd 

    [ corner-added? ] keep swap ! test if corner is inside solid

    [ update-adjacent-faces ] 

    [ 2drop ]

    if ;



: compute-intersection ( solid faces -- )

    dup faces-intersection

    dup f = [ 3drop ] [ process-corner ]  if ;



: test-faces-combinaisons ( solid n -- )

    [ dup faces>> ] dip among   

    [ compute-intersection ] with each ;



: compute-adjacencies ( solid -- solid )

    dup dimension>> [ >= ] curry 

    [ keep swap ] curry MAX-FACE-PER-CORNER swap

    [ [ test-faces-combinaisons ] 2keep 1 - ] while drop ;



: find-adjacencies ( solid -- solid ) 

    erase-old-adjacencies   

    compute-adjacencies

    filter-real-faces 

    t >>adjacencies-valid ;



: ensure-adjacencies ( solid -- solid ) 

    dup adjacencies-valid>> 

    [ find-adjacencies ] unless 

    ensure-silhouettes

    ;



: (non-empty-solid?) ( solid -- ? ) 

    [ dimension>> ] [ corners>> length ] bi < ;

: non-empty-solid? ( solid -- ? )   

    ensure-adjacencies (non-empty-solid?) ;



: compare-corners-roughly ( corner corner -- ? )

    2drop t ;

! : remove-inner-faces ( -- ) ;

: face-project ( array face -- seq )

    backface? 

  [ 2drop f ]

    [   [ enlight-projection ] 

        [ initiate-solid-from-face ]

        [ intersections-into-faces ]  tri

        >>faces

        swap >>color        

    ]    if ;



: solid-project ( lights ambient solid -- solids )

  ensure-adjacencies

    [ color>> ] [ faces>> ] bi [ 3array  ] dip

    [ face-project ] with map 

    [ ] filter 

    [ ensure-adjacencies ] map

;



: (solid-move) ( solid v move -- solid ) 

   curry [ map ] curry 

   [ dup faces>> ] dip call drop  

   unvalid-adjacencies ; inline



: solid-translate ( solid v -- solid ) 

    [ face-translate ] (solid-move) ; 

: solid-transform ( solid m -- solid ) 

    [ face-transform ] (solid-move) ; 



: find-corner-in-silhouette ( s1 s2 -- elt bool )

    pv> swap silhouettes>> nth     

    swap corners>>

    [ point-inside-solid? ] with find swap ;



: valid-face-for-order ( solid point -- face )

    [ point-inside-face? not ] 

    [ drop face-orientation  0 = not ] 2bi and ;



: check-orientation ( s1 s2 pt -- int )

    [ nip faces>> ] dip

    [ valid-face-for-order ] curry find swap

    [ face-orientation ] [ drop f ] if ;



: (order-solid) ( s1 s2 -- int )

    2dup find-corner-in-silhouette

    [ check-orientation ] [ 3drop f ] if ;



: order-solid ( solid solid  -- i ) 

    2dup (order-solid)

    [ 2nip ]

    [   swap (order-solid)

        [ neg ] [ f ] if*

    ] if* ;



: subtract ( solid1 solid2 -- solids )

    faces>> swap clone ensure-adjacencies ensure-silhouettes  

    [ swap slice-solid drop ]  curry map

    [ non-empty-solid? ] filter

    [ ensure-adjacencies ] map

; inline



! -------------------------------------------------------------

! space 

! -------------------------------------------------------------

TUPLE: space name dimension solids ambient-color lights ;

: <space> ( -- space )      space new ;

: suffix-solids ( space solid -- space ) 

    [ suffix ] curry change-solids ; inline

: suffix-lights ( space light -- space ) 

    [ suffix ] curry change-lights ; inline

: clear-space-solids ( space -- space )     f >>solids ;



: space-ensure-solids ( space -- space ) 

    [ [ ensure-adjacencies ] map ] change-solids ;

: eliminate-empty-solids ( space -- space ) 

    [ [ non-empty-solid? ] filter ] change-solids ;



: projected-space ( space solids -- space ) 

   swap dimension>> 1 -  <space>    

   swap >>dimension    swap  >>solids ;



: get-silhouette ( solid -- silhouette )    

    silhouettes>> pv> swap nth ;

: solid= ( solid solid -- ? )            [ corners>> ]  same? ;



: space-apply ( space m quot -- space ) 

        curry [ map ] curry [ dup solids>> ] dip

        [ call ] [ 2drop ] recover drop ; inline

: space-transform ( space m -- space ) 

    [ solid-transform ] space-apply ;

: space-translate ( space v -- space ) 

    [ solid-translate ] space-apply ; 



: describe-space ( space -- ) 

    solids>>  

    [  [ corners>>  [ pprint ] each ] [ name>> . ] bi ] each ;



: clip-solid ( solid solid -- solids )

    [ ]

    [ solid= not ]

    [ order-solid -1 = ] 2tri 

    and

    [ get-silhouette subtract ] 

    [  drop 1array ] 

    if 

    

    ;



: (solids-silhouette-subtract) ( solids solid -- solids ) 

     [  clip-solid append ] curry { } -rot each ; inline



: solids-silhouette-subtract ( solids i solid -- solids )

! solids is an array of 1 solid arrays

      [ (solids-silhouette-subtract) ] curry map-but 

; inline 



: remove-hidden-solids ( space -- space ) 

! We must include each solid in a sequence because 

! during substration 

! a solid can be divided in more than on solid

    [ 

        [ [ 1array ] map ] 

        [ length ] 

        [ ] 

        tri     

        [ solids-silhouette-subtract ] 2each

        { } [ append ] reduce 

    ] change-solids

    eliminate-empty-solids ! TODO include into change-solids

;



: space-project ( space i -- space )

  [

  [ clone  

    remove-hidden-solids? [ remove-hidden-solids ] when

    dup 

        [ solids>> ] 

        [ lights>> ] 

        [ ambient-color>> ]  tri 

        [ rot solid-project ] 2curry 

        map 

        [ append ] { } -rot each 

        ! TODO project lights

        projected-space 

      ! remove-inner-faces 

      ! 

      eliminate-empty-solids

    ] with-pv 

    ] [ 3drop <space> ] recover

    ; inline



: middle-of-space ( space -- point )

    solids>> [ corners>> ] map concat

    [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n

;



! -------------------------------------------------------------

! 3D rendering

! -------------------------------------------------------------



: face-reference ( face -- halfspace point vect )

       [ halfspace>> ] 

       [ touching-corners>> first ] 

       [ touching-corners>> second ] tri 

       over v-

;



: theta ( v halfspace point vect -- v x )

   [ [ over ] dip v- ] dip    

   [ cross dup norm >float ]

   [ v. >float ]  

   2bi 

   fatan2

   -rot v. 

   0 < [ neg ] when

;



: ordered-face-points ( face -- corners )  

    [ touching-corners>> 1 head ] 

    [ touching-corners>> 1 tail ] 

    [ face-reference [ theta ] 3curry ]         tri

    { } map>assoc    sort-values keys 

    append

    ; inline



: point->GL  ( point -- )   gl-vertex ;

: points->GL ( array -- )   do-cycle [ point->GL ] each ;



: face->GL ( face color -- )

   [ ordered-face-points ] dip

   [ first3 1.0 glColor4d GL_POLYGON 

        [ [ point->GL  ] each ] do-state ] curry

   [  0 0 0 1 glColor4d GL_LINE_LOOP 

        [ [ point->GL  ] each ] do-state ]

   bi

   ; inline



: solid->GL ( solid -- )    

    [ faces>> ]    

    [ color>> ] bi

    [ face->GL ] curry each ; inline



: space->GL ( space -- )

    solids>>

    [ solid->GL ] each ;