{-
   A simple Quake 1 level viewer
   Sven Panne 2000.   mailto:Sven.Panne@informatik.uni-muenchen.de
-}
module Main(main) where

import Control.Monad         ( liftM, when, unless, zipWithM_ )
import Data.Array            ( elems, (!), rangeSize, bounds )
import Data.Char             ( toLower, isDigit )
import Data.IORef            ( IORef, newIORef, writeIORef, modifyIORef )
import Data.Maybe            ( fromMaybe, listToMaybe )
import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(Permute), OptDescr(Option), ArgDescr(..) )
import System.Directory      ( getDirectoryContents )
import System.Exit           ( exitFailure, exitWith, ExitCode(ExitSuccess) )
import System.IO             ( Handle, hSetBuffering, BufferMode(LineBuffering), stdout, hClose )
-- We really mean Control.Exception below, but GHC <= 5.04x has it in System.IO,
-- so we use the lowest common denominator. *sigh*
import IO                    ( bracket )

import GL
import GLU hiding ( Angle, Sphere )
import Graphics.UI.GLUT

import Geometry as G
import QuakeTypes
import Entity
import MipTex(LightLevel, qGetQPalette, gammaCorrect, qGetQColorMap)
import UserInput(KeyBinder, KeyEvent(..))
import Player
import BspTree
import RenderBsp(Rendering(..), previous, next, display)
import PackLib
import BitSet
import FPSCounter(newFPSCounter)

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

fieldOfViewY :: Angle
fieldOfViewY = 80

reshape :: IORef (Angle,Angle) -> ReshapeCallback
reshape fov (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   let zNear  = 1
       zFar   = 8000 -- must include skybox, if there is one
       aspect = (fromIntegral w / fromIntegral h)
   perspective (realToFrac fieldOfViewY) aspect zNear zFar
   matrixMode Modelview
   loadIdentity
   let theFOV = (radiansToDegree (2 * atan (realToFrac aspect * tanD (fieldOfViewY / 2))),
                 fieldOfViewY)
   putStrLn ("FOV is " ++ show theFOV)
   writeIORef fov theFOV

bindMisc :: KeyBinder -> IORef Rendering -> IORef Int -> Int -> IORef Bool -> IO ()
bindMisc bindKey rendering currentModel numModels lightsOn = do
   bind 'r' rendering    next
   bind 'R' rendering    previous
   bind 'm' currentModel ((`mod` numModels) . (+1))
   bind 'M' currentModel ((`mod` numModels) . (+(-1)))
   bind 'l' lightsOn     not
  where bind key ref func =
         bindKey (Char key) Press (Just (\_ _ -> do modifyIORef ref func
                                                    postRedisplay))

bindTeleportKeys :: KeyBinder -> IORef PlayerState -> [(PlayerState,String)] -> IO ()
bindTeleportKeys bindKey playerState startPositions =
   zipWithM_ (\k (newState,msg) -> bindKey (SpecialKey k) Press (Just $ \_ _ -> do
              putStrLn ("Teleporting to " ++ msg)
              writeIORef playerState newState
              postRedisplay))
      [ KeyF1, KeyF2, KeyF3, KeyF4,  KeyF5,  KeyF6,
        KeyF7, KeyF8, KeyF9, KeyF10, KeyF11, KeyF12 ]
      startPositions

-- NOTE: For the world, we do backface culling for ourselves.
initGraphics :: IO ()
initGraphics = do
   clearColor (Color4 0.0 0.0 0.0 1.0)
   disable DepthTest   -- We use the BSP

   -- fogging
   mapM_ fog [ FogColor (Color4 0.0 0.0 0.0 1.0), FogDensity (FogExp 0.0018) ]
   -- For linear fogging use:
   -- mapM_ fog [ FogColor (Color4 0.0 0.0 0.0 1.0), FogDensity (FogLinear 1 800) ]

   -- for texturing
   pixelStore Unpack (Alignment 1)

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

getInitialPlayerStates :: EntityClass -> BspTree -> [PlayerState]
getInitialPlayerStates classname theBspTree =
   -- Lift position by 24 units = 3 feet, so the player doesn't start on the floor
   [ makePlayerState (G.Point startX (startY + 24) startZ) 0 angle |
     entity <- getEntitiesOfClass classname theBspTree,
     let (startX,startY,startZ) = vectorForKey "origin" Nothing entity,
     let angle = angleForKey "angle" (Just 270) entity ]

getStartPositions :: BspTree -> [(PlayerState,String)]
getStartPositions theBspTree| null sps  = [defaultPos]
                            | otherwise = sps
   where sps  = [ (ps, name ++ " starting point " ++ show n) |
                  (name, classname) <- [("single player", "info_player_start"),
                                        ("cooperative",   "info_player_coop"),
                                        ("deathmatch",    "info_player_deathmatch")],
                  (ps,n) <- zip (getInitialPlayerStates classname theBspTree) [1::Int ..] ]
         defaultPos = (makePlayerState worldOrigin 0 0, "default start")

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

printBspTreeInfo :: String -> BspTree -> IO ()
printBspTreeInfo fName theBspTree =
   putStrLn (fName ++ " (" ++ mapName ++") has " ++
             sl entities " entities (" ++
             sl (getEntitiesStartingWith "light") " lights), " ++
             sl (elems . models) " models, " ++
             show noFaces ++ " faces in " ++
             show numVisLeaves ++ " leaves, and " ++
             sl (tail . elems . edges) " edges.")
   where mapName = stringForKey "message" (Just "Unknown Map") .
                   head . getEntitiesOfClass "worldspawn" $ theBspTree
         sl f msg = (show . length . f $ theBspTree) ++ msg
         Slice _ noFaces _ = modelFaces (models theBspTree ! 0)
         numVisLeaves  = rangeSize . bounds . leaves $ theBspTree

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

data Flag = GameDir String | Map String | Brightness LightLevel | Gamma Qfloat
          | TSpeed Qfloat | RSpeed Qfloat | LoadOnly | Help

options :: [OptDescr Flag]
options = [Option ['g']     ["gamedir"]    (ReqArg GameDir             "GAMEDIR") "mod directory",
           Option ['m']     ["map"]        (ReqArg Map                 "MAP")     "display level MAP",
           Option ['b']     ["brightness"] (ReqArg (Brightness . read) "NUM")     "use NUM [0..63] for brightness",
           Option ['G']     ["gamma"]      (ReqArg (Gamma      . read) "NUM")     "use NUM for gamma correction",
           Option ['t']     ["transspeed"] (ReqArg (TSpeed     . read) "NUM")     "set translation speed",
           Option ['r']     ["rotspeed"]   (ReqArg (RSpeed     . read) "NUM")     "set rotation speed",
           Option ['l']     ["loadonly"]   (NoArg LoadOnly)                       "only load level, then exit",
           Option ['h','?'] ["help"]       (NoArg Main.Help)                      "show help"]

usage :: String
usage = usageInfo "usage: QBSP [OPTION...] QUAKEDIRECTORY\nwhere OPTION is one of" options

printHelp :: IO ()
printHelp = do
   mapM_ putStrLn [
      usage,
      "Use the following keys:",
      "   * Translation: s/f, a/SPACE, d/e",
      "   * Rotation: cursor keys",
      "   * Jump to different starting points: F1 - F12",
      "   * next/previous rendering mode: r/R",
      "   * next/previous model: m/M",
      "   * toggle lights: l",
      "   * Exit: ESCAPE"]
   exitWith ExitSuccess

---------------------------------------------------------------------------
-- Read a file either directly or from a PACK file, trying the following
-- locations (the first two only when gameDir given):
--   * <quakePath>/<gameDir>/<fileName>
--   * Entry <fileName> within <quakePath>/<gameDir>/pak[0..9].pak
--   * <quakePath>/id1/<fileName>
--   * Entry <fileName> within <quakePath>/id1/pak[0..9].pak

type QuakeOpener = FilePath -> IO (Handle, FileLength)

makeQuakeOpener :: DirectoryPath -> Maybe DirectoryPath -> IO QuakeOpener
makeQuakeOpener quakePath mbGameDir = do
   gameDescriptors <- maybe (return []) (searchDescriptorsForDir . concPaths quakePath) mbGameDir
   id1Descriptors <- searchDescriptorsForDir (concPaths quakePath "id1")
   liftM pOpenFile (makePackFinder knownHandlers (gameDescriptors ++ id1Descriptors))

searchDescriptorsForDir :: DirectoryPath -> IO [SearchDescriptor]
searchDescriptorsForDir dirPath = do
   entries <- getDirectoryContents dirPath
   return $ SearchDirectory dirPath :
            [ SearchPackFile (concPaths dirPath entry) |
              entry <- entries, isPackFile (map toLower entry) ]
  where isPackFile ['p','a','k',c,'.','p','a','k' ] = isDigit c
        isPackFile _ = False

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

main :: IO ()
main = do
   hSetBuffering stdout LineBuffering   -- needed for Cygwin
   (progName, args) <- getArgsAndInitialize
   let (opts,realArgs,errs) = getOpt Permute options args
   unless (null [ () | Main.Help <- opts ]) printHelp
   quakePath <- case (realArgs,errs) of
      ([qp], []) -> return qp
      (_,    es) -> do putStrLn (concat es ++ usage); exitFailure
   let mbGameDir   = listToMaybe [ d | GameDir d <- opts ]
       mapName     = concPaths "maps" (ensureSuffix (head ([ m | Map m <- opts] ++ ["start"])) ".bsp")
       lightLevel  = fromMaybe 23  (listToMaybe [ b | Brightness b <- opts ])
       gamma       = fromMaybe 1.8 (listToMaybe [ g | Gamma      g <- opts ])
       translSpeed = fromMaybe 5   (listToMaybe [ t | TSpeed     t <- opts ])
       rotSpeed    = fromMaybe 8   (listToMaybe [ r | RSpeed     r <- opts ])

   playerState  <- newIORef undefined
   rendering    <- newIORef Textured
   currentModel <- newIORef 0
   lightsOn     <- newIORef False
   setInitialDisplayMode [ Graphics.UI.GLUT.Double, RGB, Graphics.UI.GLUT.Depth ]
   setInitialWindowSize (WindowSize 640 480)
   createWindow progName
   initGraphics

   qOpen        <- makeQuakeOpener quakePath mbGameDir
   let loadWith reader fileName = bracket (liftM fst (qOpen fileName)) hClose reader
   palette      <- loadWith qGetQPalette  "gfx/palette.lmp"
   colorMap     <- loadWith qGetQColorMap "gfx/colormap.lmp"

   -- This must come *after* initGraphics, because  texture parameters must be set.
   theBspTree   <- loadWith (readBspTree (gammaCorrect gamma palette) colorMap lightLevel) mapName
   printBspTreeInfo mapName theBspTree

   let startPositions = getStartPositions theBspTree
   writeIORef playerState (fst (head startPositions))

   fov <- newIORef (fieldOfViewY, fieldOfViewY)   -- reshape recalculates this correctly

   visibleLeaves <- emptyBS . rangeSize . bounds . leaves $ theBspTree

   let faceSlices    = map modelFaces . elems . models $ theBspTree
       totalNumFaces = maximum [ from + count | Slice from count _ <- faceSlices ]
   visibleFaces  <- emptyBS totalNumFaces

   (bindKey, stillDown) <- quakeBindings translSpeed rotSpeed playerState
   bindMisc bindKey rendering currentModel (rangeSize . bounds . models $ theBspTree) lightsOn
   bindTeleportKeys bindKey playerState startPositions
  
   -- We want to average the FPS over 50 frames
   fpsCounter <- newFPSCounter 50

   theTick <- newIORef 0

   let lightPositions = [ G.Point x y z |
                          entity <- getEntitiesStartingWith "light" theBspTree,
                          let (x,y,z) = vectorForKey "origin" Nothing entity ]
   [lightDList] <- genLists 1
   newEndList lightDList Compile $ renderObject Solid (Sphere 2 10 8)

   setDisplayCallback (display stillDown playerState fov rendering currentModel theBspTree
                               lightsOn visibleLeaves visibleFaces fpsCounter theTick
                               lightPositions lightDList)
   setReshapeCallback (Just (reshape fov))

   when (null [ () | LoadOnly <- opts ]) mainLoop
