{-
   The rendering part, still experimental!
   Sven Panne 2000.   mailto:Sven.Panne@informatik.uni-muenchen.de
-}
module RenderBsp(
   Rendering(..), previous, next, display
) where

import Control.Monad ( liftM2, when, zipWithM_ )
import Data.Array    ( (!), elems )
import Data.Bits     ( Bits((.&.)) )
import Data.IORef    (IORef, readIORef, writeIORef, modifyIORef )

import GL
import Graphics.UI.GLUT

import UserInput(StillDownHandler)
import Player(PlayerState(..), positionCamera)
import QuakeTypes
import MipTex(MipTex(..), TextureData(..))
import Plane
import DFace
import BSP
import BspTree
import BitSet
import FPSCounter(FPSCounter, getFPS)
import Text(with2D, strokeStringAt)
import Geometry  as G

---------------------------------------------------------------------------

data Rendering = WireFrame | AAWireFrame | Textured
   deriving (Eq, Show, Enum, Bounded)

previous :: (Enum a, Bounded a) => a -> a
previous = toEnum . (`mod` (fromEnum (maxBound::Rendering) + 1)) . (+(-1)) . fromEnum

next     :: (Enum a, Bounded a) => a -> a
next     = toEnum . (`mod` (fromEnum (maxBound::Rendering) + 1)) . (+1) . fromEnum

---------------------------------------------------------------------------

instance Vertex (Point Qfloat) where
   vertex (G.Point x y z) = vertex (Vertex3 x y z)

drawLights :: [QPoint] -> DisplayList -> IO ()
drawLights lightPositions lightDList = do
   pushAttrib [ EnableBit ]
   enable CullFace
   enable Lighting
   enable (Light 0)
   lightModel (LightModelAmbient (Color4 0.8 0.8 0.0 1.0))
   sequence_ [ command | G.Point x y z <- lightPositions,
                         command <- [ pushMatrix,
                                      translate (Vector3 x y z),
                                      callList lightDList,
                                      popMatrix ]]
   popAttrib


-- Find the leaf of the BSP tree currently containing the the player via a top-down search.
findLeaf :: BSP -> QPoint -> BSP
findLeaf theBspTree playerPos = find theBspTree
   where find (BspNode {frontBspChild = front, backBspChild = back, splittingPlane = qPlane})
            | playerPos `isInFrontOf` planeOf qPlane = find front
            | otherwise                              = find back
         find leaf@(BspLeaf {}) = leaf


-- Mark all leaves potentially visible from the current leaf.
markLeaves :: BSP -> BitSet -> Int -> IO ()
markLeaves (BspNode {}) _ _ = error "markLeaves: impossible"
markLeaves (BspLeaf {visiInfo = (visiOff, visiData)}) visibleLeaves numLeaves =
   when (visiOff > 0) $ do   -- only the world has visibility info
      clearAllBS visibleLeaves
      mark 1 visiOff
  where mark leafNo visOff = do   -- decode RLE
           if leafNo >= numLeaves
              then return ()
              else do
                 vData <- peekElemOff visiData visOff
                 if (vData :: GLubyte) == 0
                    then do
                       v <- peekElemOff visiData (visOff + 1)
                       mark (leafNo + 8 * fromIntegral (v :: GLubyte)) (visOff + 2)
                    else do
                       do zipWithM_ (\b l -> when ((vData .&. b) /= 0) (setBS visibleLeaves l))
                                    [1, 2, 4, 8, 16, 32, 64, 128]
                                    [leafNo .. ]
                          mark (leafNo + 8) (visOff + 1)


-- Mark all nodes which eventually lead to a potentially visible leaf via a first bottom-up walk.
-- Leaves without any visibility info (e.g. parts of moving models) are always considered visible.
markNodes :: BSP -> BitSet -> IO Bool
markNodes theBspTree visibleLeaves = mark theBspTree
   where mark (BspNode {frontBspChild = front , backBspChild = back, bspNodeMark = nodeMark}) = do
            somethingVisible <- liftM2 (||) (mark front) (mark back)
            writeIORef nodeMark somethingVisible
            return somethingVisible
         mark (BspLeaf {leafId = i, visiInfo = (visiOff, _)})
            | visiOff >= 0 = isSetBS visibleLeaves i
            | otherwise    = do setBS visibleLeaves i
                                return True


type QFrustum = Frustum Qfloat

-- Mark all visible faces via a top-down walk, taking the view frustum into account.
markFaces :: BSP -> BitSet -> QFrustum -> BitSet -> IO ()
markFaces theBspTree visibleLeaves viewFrustum visibleFaces =
   mark theBspTree (\bbox -> aABBoxFrustumStatus bbox viewFrustum)
   where mark(BspNode {frontBspChild = front, backBspChild = back, bspNodeMark = nodeMark, bspBBox = bbox}) frustumTest = do
            nodeIsVisible <- readIORef nodeMark
            when nodeIsVisible $
               case frustumTest bbox of
                  InsideFrustum     -> do mark front (const InsideFrustum)
                                          mark back  (const InsideFrustum)
                  IntersectsFrustum -> do mark front frustumTest
                                          mark back  frustumTest
                  OutsideFrustum    -> writeIORef nodeMark False
         mark (BspLeaf {leafId = i, bspMarkSurfaces = (Slice from count mSurf), bspBBox = bbox}) frustumTest = do
            leafIsVisible <- isSetBS visibleLeaves i
            when leafIsVisible $
               case frustumTest bbox of
                  OutsideFrustum -> return ()
                  _              -> mapM_ (\f -> setBS visibleFaces (fromIntegral (mSurf ! f)))
                                          [from .. from + count - 1]


-- Draw all visible faces back-to-front. The order is important for correct
-- (non-additive) translucency.  Side effect: Clear marks of visible faces.
renderNode :: BSP -> PlayerState -> BitSet -> Int -> IO ()
renderNode theBspTree playerState@(PlayerState{ playerFrame = Frame{ origin = playerPos }}) visibleFaces tick = do
   enable Texture2d'
   render theBspTree
   disable Texture2d'
  where render (BspNode {frontBspChild = front, backBspChild = back, bspNodeMark = nodeMark,
                         splittingPlane = qPlane, bspFaces = faces}) = do
           nodeIsVisible <- readIORef nodeMark
           when nodeIsVisible $
              if playerPos `isInFrontOf` planeOf qPlane
                 then do render back
                         renderFaces faces True  visibleFaces playerState tick
                         render front
                 else do render front
                         renderFaces faces False visibleFaces playerState tick
                         render back
        render (BspLeaf {}) = return ()


-- To minimize texture changes, we do backface culling for ourselves.
renderFaces :: Slice DFace -> Bool -> BitSet -> PlayerState -> Int -> IO ()
renderFaces (Slice from count theFaces) inFront visibleFaces playerState tick =
   when (count > 0) $ do
      let firstFace = theFaces ! from
          QEdge pt _ = head (faceEdges firstFace)
          playerPos  = origin (playerFrame playerState)
          dist = (playerPos `pSub` pt) `dot` planeNormal (planeOf (facePlane firstFace))
      depthFunc GL.Lequal
      mapM_ (\f -> do faceIsVisible <- isSetBS visibleFaces f
                      let face = theFaces ! f
                      when (faceIsVisible &&                     -- face in PVS?
                            inFront == frontIsTextured face &&   -- is player on the textured side?
                            inFront == (dist >= 0))              -- backface culling
                           (drawFace face playerState tick)
                      clearBS visibleFaces f)
            [from .. from + count - 1]

drawFace :: DFace -> PlayerState -> Int -> IO ()
drawFace face playerState tick = do
   case lightMap face of
      Nothing | skyFlag (texInfo face) -> drawSpecialPolygon face playerState tick
              | otherwise              -> drawBlackPolygon face
      Just lMap                        -> drawLightMappedPolygon lMap face

drawSpecialPolygon :: DFace -> PlayerState -> Int -> IO ()
drawSpecialPolygon face playerState tick = do
   case textureName . mipTex . texInfo $ face of
      ('*':_) -> drawLiquidPolygon face tick
      _       -> drawSkyPolygon    face tick playerState

drawLiquidPolygon :: DFace -> Int -> IO ()
drawLiquidPolygon face tick = do
   texEnv (TextureEnvMode Modulate)
   depthMask False
   blendFunc SrcAlpha OneMinusSrcAlpha
   enable Blend'
   let TexObj texture alpha = textureData . mipTex . texInfo $ face
       qbspSpeedFactorHack = 60
   color (Color4 1 1 1 (fromIntegral alpha / (255::GLfloat)))
   drawPolygon texture
--            [ TexCoord2 (s + sin ((shift+s) * 2*pi) * 0.1)
--                        (t + cos ((shift+t) * 2*pi) * 0.1) |
            [ TexCoord2 (s + sin (t * 0.125 + fromIntegral tick / qbspSpeedFactorHack))
                        (t + sin (s * 0.125 + fromIntegral tick / qbspSpeedFactorHack)) |
              TexCoord2 s t <- stCoords face ]
            (faceEdges face)
   disable Blend'
   depthMask True

drawSkyPolygon :: DFace -> Int -> PlayerState -> IO ()
drawSkyPolygon face tick (PlayerState{ playerFrame = Frame{ origin = playerPos }}) = do
   texEnv (TextureEnvMode Replace)
   -- matrixMode Texture
   let TexSky lower upper = textureData . mipTex . texInfo $ face
       qbspSpeedFactorHack = 20
   drawSkyPoly upper ((tick * 8 `div` qbspSpeedFactorHack) `mod` 128)
   blendFunc SrcAlpha OneMinusSrcAlpha
   enable Blend'
   drawSkyPoly lower ((tick * 16 `div` qbspSpeedFactorHack) `mod` 128)
   disable Blend'
   -- loadIdentity
   -- matrixMode Modelview
  where drawSkyPoly tex speedScale = do
           bindTexture Texture2d tex
           -- translate (Vector3 shift shift 0)
           beginEnd Polygon $ sequence_ [
             cmd | QEdge v _ <- faceEdges face,
                   let Vector x y z = v `pSub` playerPos
                       flattenedDir = Vector x y (z * 3)   -- flatten the sphere
                       len          = 6 * 63 / sqrt (flattenedDir `dot` flattenedDir),
                       cmd <- [ texCoord (TexCoord2 ((fromIntegral speedScale + x*len) / 128)
                                                    ((fromIntegral speedScale + y*len) / 128)),
                                vertex v ] ]

drawBlackPolygon :: DFace -> IO ()
drawBlackPolygon face = do
   disable Texture2d'
   color (Color3 0 0 0 :: Color3 GLfloat)
   beginEnd Polygon $ mapM_ vertex [ v | QEdge v _ <- faceEdges face ]
   enable Texture2d'

drawLightMappedPolygon :: TextureName -> DFace -> IO ()
drawLightMappedPolygon lMap face = do
   texEnv (TextureEnvMode Replace)
   drawPolygon lMap (lmCoords face) (faceEdges face)
   depthMask False
   blendFunc DstColor Zero
   enable Blend'
   drawPolygon texture (stCoords face) (faceEdges face)
   disable Blend'
   depthMask True
  where TexObj texture _ = textureData . mipTex . texInfo $ face

drawPolygon :: TextureName -> [TexCoord2 Qfloat] -> [QEdge] -> IO ()
drawPolygon tObj texCoords theEdges = do
   bindTexture Texture2d tObj
   beginEnd Polygon $ sequence_ [
      cmd | (st, QEdge v _) <- zip texCoords theEdges,
            cmd <- [ texCoord st, vertex v ] ]


drawBspTree :: BspTree -> PlayerState -> (Angle, Angle) -> Rendering -> Int -> BitSet -> BitSet -> Int -> IO ()

drawBspTree theBspTree playerState (fovX, fovY) Textured curModel visibleLeaves visibleFaces tick = do
   let model       = models theBspTree ! curModel
       bsp         = bspTree model
       currentLeaf = findLeaf bsp (origin (playerFrame playerState))
       numLeaves   = fromIntegral (visLeaves model)
       viewFrustum = calcViewFrustum (playerFrame playerState) fovX fovY
   markLeaves currentLeaf visibleLeaves numLeaves
   markNodes bsp visibleLeaves
   markFaces bsp visibleLeaves viewFrustum visibleFaces
   renderNode bsp playerState visibleFaces tick


drawBspTree theBspTree _ _ AAWireFrame _ _ _ _ = do
   pushAttrib [AllAttribBits] -- [ColorBufferBit', DepthBufferBit', FogBit]
   enable DepthTest
   enable Fog
   enable LineSmooth
   enable Blend'
   blendFunc SrcAlpha OneMinusSrcAlpha
   hint LineSmoothHint Nicest
   color (Color3 1 1 1 :: Color3 GLfloat)
   beginEnd Lines $ mapM_ vertex [ v | QEdge v0 v1 <- elems (edges theBspTree),
                                       v <- [v0, v1] ]
   popAttrib

drawBspTree theBspTree _ _ WireFrame _ _ _ _ = do
   pushAttrib [AllAttribBits] -- [DepthBufferBit', FogBit]
   enable DepthTest
   enable Fog
   color (Color3 1 1 1 :: Color3 GLfloat)
   beginEnd Lines $ mapM_ vertex [ v | QEdge v0 v1 <- elems (edges theBspTree),
                                   v <- [v0, v1] ]
   popAttrib

displayFPS :: FPSCounter -> IO ()
displayFPS fpsCounter = do
   -- 0.1 FPS resolution is more than enough
   rawFPS <- getFPS fpsCounter
   let fps = fromIntegral ((round (rawFPS * 10))::Int) / 10
   with2D [ color (Color3 1 0 0 :: Color3 GLfloat),
            strokeStringAt (RasterPos2 10 10) (show (fps :: Float)) ]


-- Hmmm, some kind of abstraction for all these parameters is urgently needed.
display :: StillDownHandler -> IORef PlayerState -> IORef (Angle,Angle) -> IORef Rendering -> IORef Int -> BspTree -> IORef Bool -> BitSet -> BitSet -> FPSCounter -> IORef Int -> [QPoint] -> DisplayList -> DisplayCallback
display stillDown playerState fov rendering currentModel theBspTree lightsOn visibleLeaves visibleFaces fpsCounter theTick lightPositions lightDList = do
   modifyIORef theTick (+1)
   tick <- readIORef theTick
   stillDown
   lightsAreOn <- readIORef lightsOn
   rMode <- readIORef rendering
   if lightsAreOn || rMode == WireFrame || rMode == AAWireFrame then do
      enable DepthTest
      clear [ DepthBufferBit ]
    else do
      disable DepthTest
   curModel <- readIORef currentModel
   when (curModel /= 0  ||  rMode /= Textured) (clear [ ColorBufferBit ])
   thePlayerState <- readIORef playerState
   positionCamera thePlayerState
   theFov   <- readIORef fov
   drawBspTree theBspTree thePlayerState theFov rMode curModel visibleLeaves visibleFaces tick
   when lightsAreOn (drawLights lightPositions lightDList)
   displayFPS fpsCounter
   postRedisplay
   swapBuffers
