USING: accessors alien.c-types alien.data arrays assocs
byte-arrays colors combinators grouping images images.loader 
io.encodings.utf8 io.files kernel math math.functions 
math.parser math.vectors opengl opengl.gl opengl.glu math.order
opengl.textures sequences specialized-arrays splitting classes
ui ui.gadgets ui.gadgets.worlds ui.pens generic
   juere-engine.utils
   juere-engine.stage ;
IN: juere-engine.rendering

FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float

TUPLE: stage-gadget < gadget
   stage fov control-state stop? scraps ;

! == OpenGL Backend management ==
: light-var ( a b ? -- ) 
   [ float >c-array glLightfv ] [ 2drop ] if* ;
! f is "Default", not 0.
:: <light> ( ambient diffuse specular position name -- )
   name glEnable
   name GL_AMBIENT ambient light-var
   name GL_DIFFUSE diffuse light-var
   name GL_SPECULAR specular light-var
   name GL_POSITION position light-var ;

:: light-model ( ambient viewpt twoside separation -- )
      GL_LIGHT_MODEL_AMBIENT ambient float >c-array 
   glLightModelfv
      GL_LIGHT_MODEL_LOCAL_VIEWER viewpt
   glLightModelf
      GL_LIGHT_MODEL_TWO_SIDE twoside
   glLightModeli
      GL_LIGHT_MODEL_COLOR_CONTROL separation
   glLightModeli ;

: viewport-loc ( gadget -- x y w h )
   dup
   [ find-world ] [
      [ screen-loc first2 ]   ! Gadget x y
      [ find-world dim* nip ] ! Window Height
      [ dim* nip ] tri        ! Gadget Height
   - swap - rot dim* ]         ! winh - locY - dimY, Gadget dim*
   [ 2drop 1 1 1 1 ] 1if ;

: restore-viewport ( gadget -- )
   find-world [ [ loc>> first2 ] [ dim* ] bi glViewport ] 
   when* ;

: with-3dgl ( gadget quot -- )
   GL_PROJECTION glMatrixMode
      glLoadIdentity
      over [ class-of \ fov>> nearest-class ]
           [ fov>> ] [ drop 45.0 ] 1if 
         pick dim* / >float 0.1 100.0 gluPerspective
      over viewport-loc glViewport
   GL_MODELVIEW glMatrixMode
      glLoadIdentity
   GL_LEQUAL glDepthFunc
      GL_DEPTH_TEST glEnable
         GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA 
      glBlendFunc
   GL_BLEND glEnable
   GL_TEXTURE_2D glEnable
      GL_DEPTH_BUFFER_BIT glClear
      1.0 glClearDepth
  GL_NORMALIZE glEnable
  GL_SMOOTH glShadeModel
  { 0.55 0.55 0.55 1.0 } 0.0 GL_FALSE GL_SINGLE_COLOR light-model
   call( -- )
   glFlush
   dup restore-viewport
      GL_DEPTH_TEST glDisable
      GL_BLEND glDisable
      GL_NORMALIZE glDisable
   GL_PROJECTION glMatrixMode
      glLoadIdentity
   GL_MODELVIEW glMatrixMode
      glLoadIdentity 
   drop ;

MEMO:: (load-texture) ( path -- width height id )
   gen-texture :> tex-name
      GL_TEXTURE_2D tex-name 
   glBindTexture 
      GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST
   glTexParameteri
      GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST
   glTexParameteri
      GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE GL_MODULATE
   glTexEnvi
   path load-image 
      dup component-order>> 
        { { RGB [ 3 ] } { RGBA [ 4 ] } }
        case :> t-components
      dup dim>> 
         first2 :> t-height :> t-width
      dup component-order>> 
        { { RGB [ GL_RGB ] } { RGBA [ GL_RGBA ] } }
        case :> t-format
      dup bitmap>> 
         >byte-array :> t-pixels
   drop GL_TEXTURE_2D 0 t-components t-width t-height 
        0 t-format GL_UNSIGNED_BYTE t-pixels
   glTexImage2D 
   t-width t-height tex-name ;

: load-texture ( path -- width height )
   (load-texture) [ GL_TEXTURE_2D ] dip glBindTexture ;

! == Tile rendering ==

MEMO: (four-corners) ( -- seq )
   { 0 1 } { 1 0 } cartesian-product concat ;
: four-corners ( xy -- xys )
   1array (four-corners) [ v+ ] cartesian-map concat ;

:: insert-h ( xy h -- xhy ) h 1 xy insert-nth ;

: tile-verts ( xy tile -- verts )
   [ four-corners ] [ height>> ] bi*
   [ insert-h ] curry [ map ] keepd
   [ 0 insert-h ] map 2array concat ;

CONSTANT: cuboid-indices
   { 1 3 2 0
     5 7 3 1
     7 6 2 3
     4 6 2 0
     4 5 1 0
     5 7 6 4 }

CONSTANT: square-uvs 
   { { 0 0 } { 1 0 } { 1 1 } { 0 1 } }

CONSTANT: tile-normals
   { { 0 1 0 } { 0 0 -1 } { 1 0 0 }
     { 0 0 1 } { -1 0 0 } { 0 -1 0 } }

: render-quad ( uv-quad+norm tex-path -- )
   GL_TEXTURE_2D glEnable
   load-texture 2drop
   first2 
      float >c-array glNormal3fv
   GL_QUADS glBegin
      [ float >c-array glTexCoord2fv 
        float >c-array glVertex3fv
      ] assoc-each
   glEnd  
   GL_TEXTURE_2D glDisable ;

: render-sides ( uv-quad+norms mat -- ) 
   side-tex>> [ render-quad ] curry each ;

: render-top ( uv-quad+norm mat -- )
   top-tex>> render-quad ;

: quad-data ( xy tile -- uv-quad+norms )
   swap over tile-verts [ cuboid-indices ] dip nths 4 group 
   swap height>> '{ 1 _ } 
      '[ square-uvs _ [ v* ] curry map zip ] 
   map tile-normals zip ;

: adjust-uvs ( uv-quad+norm -- uv-quad+norm )
   ! Well that's janky.
   first2 [ [ [ 0 1 clamp ceiling ] map ] assoc-map ] 
   dip 2array ;

: draw-tile ( xy tile -- )
   [ quad-data unclip adjust-uvs ] [ material>> ] bi
   [ render-sides ] [ render-top ] bi-curry bi* ;

! == Sprite Rendering

:: (draw-entity) ( yaw scale w h x y z -- )
       h scale * :> h*
   w scale * 2 / :> w-off
   COLOR: white gl-color
   glPushMatrix
     x 0 z
   glTranslatef
      yaw -1 * 0 1 0 
   glRotatef
     x -1 * 0 z -1 * 
   glTranslatef
   GL_QUADS glBegin 
      0 0 glTexCoord2f
      x w-off - y h* + z
   glVertex3f
      1 0 glTexCoord2f
      x w-off + y h* + z
   glVertex3f
      1 1 glTexCoord2f
      x w-off + y z
   glVertex3f
      0 1 glTexCoord2f
      x w-off - y z
   glVertex3f 
   glEnd 
   glPopMatrix ;

: entity-y-pos ( tile-map entity -- y )
   [ class-of \ height>> nearest-class ] [ height>> nip ]
      [ position>> [ floor >integer ] map of
        [ height>> ] [ 0 ] if* 
      ] 1if ;

: draw-entity ( entity yaw tile-map -- )
   swapd over entity-y-pos
   over position>> first2 swapd 
   GL_TEXTURE_2D glEnable
   [ [ scale>> ] [ sprite>> ] bi load-texture ] 3dip
   (draw-entity) 
   GL_TEXTURE_2D glDisable ;

: draw-entities ( stage-gt -- )
   [ stage>> entities>> ] [ stage>> camera-yaw>> ] [ stage>> tiles>> ] tri
   [ draw-entity ] 2curry each ;

! == Object Rendering == 

: load-obj ( path -- vertices faces )
   utf8 file-lines 
      [ "f " head? ] partition
      [ "v " head? ] partition drop
    [ [ " " split rest ] map ] bi@
   [ [ [ string>number ] map ] map ] bi@ ;

: parse-faces ( face-strings vertex-array -- vertex-array )
   [ [ [ 1 - ] map ] map ] [ [ nths ] curry ] bi* map ;

MEMO: load-obj* ( path -- vertex-array )
   load-obj parse-faces ;

MEMO: estimate-normal ( arrays -- c-array )
   first3 [ v- ] curry bi@ cross 
   float >c-array ;

: render-face ( arrays -- )
   dup estimate-normal glNormal3fv
   GL_POLYGON glBegin
   [ float >c-array glVertex3fv ] 
   each glEnd ;

: render-obj ( path -- )
   GL_TEXTURE_2D glEnable
   "resource:work/juere-engine/resources/water.bmp" load-texture 2drop
      GL_S GL_TEXTURE_GEN_MODE GL_OBJECT_LINEAR 
   glTexGeni
      GL_S GL_OBJECT_PLANE { 0.25 0 0 0 } float >c-array
   glTexGenfv
      GL_T GL_TEXTURE_GEN_MODE GL_OBJECT_LINEAR 
   glTexGeni
      GL_T GL_OBJECT_PLANE { 0 0.25 0 0 } float >c-array
   glTexGenfv
   GL_TEXTURE_GEN_S glEnable GL_TEXTURE_GEN_T glEnable
   load-obj* [ render-face ] each 
   GL_TEXTURE_GEN_S glDisable GL_TEXTURE_GEN_T glDisable
   GL_TEXTURE_2D glDisable ;

: draw-objects ( stage-gt -- )
   drop glPushMatrix 
      -0.5 1.635 0.5 glTranslatef
      -90 -45 + 0 1 0 glRotatef
!      5 5 5 glScalef
      1/5 1/5 1/5 glScalef
      "resource:work/juere-engine/resources/lamp.obj" render-obj 
   glPopMatrix ; 

! == Etc. Rendering == 

: do-camera ( stage -- )
   dup stage>> camera-pitch>>
      1 0 0 glRotatef
   dup stage>> camera-xyz>> first3
      [ -1 * ] tri@ glTranslatef
   dup stage>> camera-yaw>> 
      0 1 0 glRotatef
   drop ;

: draw-background ( path -- )
   GL_PROJECTION glMatrixMode 
      glPushMatrix glLoadIdentity
   GL_MODELVIEW glMatrixMode 
      glPushMatrix glLoadIdentity
   GL_TEXTURE_2D glEnable
   GL_FALSE glDepthMask
   load-texture 2drop
   GL_QUADS glBegin 
      { 00 00 01 00 01 01 00 01 } 2 group
      { -1 -1 01 -1 01 01 -1 01 } 2 group zip
      [ [ float >c-array ] bi@ 
        [ glTexCoord2fv ] [ glVertex2fv ] bi* 
      ] assoc-each
   glEnd 
   GL_TRUE glDepthMask
   GL_TEXTURE_2D glDisable 
   GL_PROJECTION glMatrixMode 
      glPopMatrix
   GL_MODELVIEW glMatrixMode 
      glPopMatrix ;
   
: draw-stage ( stage-gt -- )
   "yellow-sunset.jpg" <rsrc> draw-background
   glPushMatrix
      dup do-camera
      glPushMatrix
         GL_LIGHTING glEnable
         { 0.1 0.1 0.1 1 } f f { -10 12 -2 1 } GL_LIGHT0 <light>
         dup stage>> tiles>> [ draw-tile ] assoc-each
   !     dup draw-objects
         GL_LIGHTING glDisable
   ! Replace with Z-Sorting or Depth Peeling if Alpha-related
   ! glitches arise.
         GL_GEQUAL 0.5 glAlphaFunc GL_ALPHA_TEST glEnable
         dup draw-entities
         GL_ALPHA_TEST glDisable
      glPopMatrix
   glPopMatrix 
   drop ;