{-
   Quake 1 mipmapped textures
   NOTE: Quake 1's handling of the sky texture is a real hack, and so is
   this code...
   Sven Panne 2000.   mailto:Sven.Panne@informatik.uni-muenchen.de
-}

module MipTex(
   MipTex(..), Alpha, TextureData(..), qGetTextures,
   QPalette, qGetQPalette, gammaCorrect,
   LightLevel, QColorMap, qGetQColorMap
) where

import Array(Array, (!), listArray)
import IO
import Monad(liftM, liftM3, zipWithM_)
import GL
import GLU
import QuakeTypes

---------------------------------------------------------------------------
-- The header of the miptex (sub-)file consists of the number of MipTexs
-- and an list of offsets to them.

qGetTextures :: QPalette -> QColorMap -> LightLevel -> Lump -> IO (Array Int MipTex)
qGetTextures palette colorMap lightLevel lump = do
   let h = lumpHandle lump
   hSetPosn (lumpFStart lump)
   hSeek h RelativeSeek . fromIntegral . lumpOffset $ lump
   startOfMipTexHeader <- hGetPosn h
   numTextures <- qGetQint h
   offsets <- qGetN numTextures qGetQint h
   liftM (listArray (0, fromIntegral numTextures - 1))
         (mapM (\offset ->
             if offset >= 0   -- no idea why -1 occurs in some maps...
                then do hSetPosn startOfMipTexHeader
                        hSeek h RelativeSeek (fromIntegral (offset::Qint))
                        qGetMipTex h >>= indexedToTexObj palette colorMap lightLevel
                else do putStrLn ("qGetTextures: skipping offset " ++ show offset)
                        return (MipTex ("SKIPPED TEXTURE " ++ show offset) 0 0 (TexObj defaultTexture 0)))
               offsets)

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

type Alpha = Qbyte

data TextureData =
     TexIndexed (Ptr GLubyte)       -- paletted textures, MIP level 0 only
   | TexObj TextureName Alpha       -- an OpenGL RGB texture object with an alpha value
   | TexSky TextureName TextureName -- lower and upper sky texture

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

numMipTexs :: Int
numMipTexs = 4   -- 1, 1/2, 1/4, 1/8

maxTextureNameLength :: Int
maxTextureNameLength = 16

data MipTex = MipTex {
   textureName           :: String,       -- always maxTextureNameLength chars in file
   textureWidth          :: Qint,         -- always a multiple of 8
   textureHeight         :: Qint,         -- always a multiple of 8
   textureData           :: TextureData
 }

instance Show MipTex where
   showsPrec p miptex =
      showParen (p>=9) (showString "MipTex " . shows (textureName miptex) .
                        showChar ' ' . shows (textureWidth miptex, textureHeight miptex))

qGetMipTex :: Handle -> IO MipTex
qGetMipTex h = do
   start   <- hGetPosn h
   name    <- readQstring maxTextureNameLength h
   width   <- qGetQint h
   height  <- qGetQint h
   offsets <- qGetN numMipTexs qGetQint h
   -- NOTE: We ignore levels 1, 2, 3 here.
   texData <- loadLumpBytes $ Lump {
      lumpHandle = h,
      lumpFStart = start,
      lumpOffset = head offsets,
      lumpLength = width * height }
   return $ MipTex {
      textureName   = name,
      textureWidth  = width,
      textureHeight = height,
      textureData   = TexIndexed texData }

---------------------------------------------------------------------------
-- Conversion from color indexed texture to RGB texture with a single alpha.
-- Only level 0 converted.

indexedToRGBA :: QPalette -> QColorMap -> LightLevel -> MipTex -> IO (PixelDescriptor, Alpha)
indexedToRGBA (QPalette palette) (QColorMap colorMap) lightLevel mipTex = do
   let name = textureName mipTex
       alpha | head name == '*' && name /= "*teleport" = 160   -- HACK, HACK, HACK
             | otherwise                               = 255
       TexIndexed indexedLevel0Data = textureData mipTex
       numTexels = fromIntegral (textureWidth mipTex * textureHeight mipTex)
   rgbTexture <- mallocArray numTexels
   mapM_ (\i -> do c <- peekElemOff indexedLevel0Data i
                   pokeElemOff rgbTexture i (palette ! (colorMap ! (lightLevel, c :: GLubyte))))
         [ 0 .. numTexels-1 ]
   return (PixelDescriptor Rgb UnsignedByte (castPtr rgbTexture), alpha)

skyToRGBA :: QPalette -> QColorMap -> LightLevel -> MipTex -> IO PixelDescriptor
skyToRGBA (QPalette palette) (QColorMap colorMap) lightLevel mipTex = do
   let TexIndexed indexedLevel0Data = textureData mipTex
       numTexels = fromIntegral (textureWidth mipTex * textureHeight mipTex)
   colorIndices <- mapM (peekElemOff indexedLevel0Data) [ 0 .. numTexels-1 ]
   rgbaTexture <- newArray [
      QRGBA r g b (if c == 0 then 0 else 255) |
      c <- colorIndices,
      let QRGB  r g b = palette ! (colorMap ! (lightLevel, c :: GLubyte)) ]
   return $ PixelDescriptor Rgba UnsignedByte (castPtr rgbaTexture)

---------------------------------------------------------------------------
-- Conversion from indexed texture to OpenGL texture object. This is a little
-- bit complicated by the fact that OpenGL textures must have dimensions which
-- are a power of 2. Quake 1 only guarantees multiples of 8. We solve this by
-- rebuilding all mipmaps from the level 0 texture via gluBuild2DMipmaps,
-- thereby ignoring level 1, 2, 3 already in the MipTex.

indexedToTexObj :: QPalette -> QColorMap -> LightLevel -> MipTex -> IO MipTex
indexedToTexObj palette colorMap lightLevel mipTex = do
   putStrLn ("Loading texture '" ++ textureName mipTex ++ "'...")
   (case textureName mipTex of
       ('s':'k':'y':_)
          | textureWidth  mipTex == 256 &&
            textureHeight mipTex == 128 -> convertSkyTexture
       _                                -> convertNormalTexture) palette colorMap lightLevel mipTex

convertSkyTexture :: QPalette -> QColorMap -> LightLevel -> MipTex -> IO MipTex
convertSkyTexture palette colorMap lightLevel mipTex = do
   lo <- copyHalf 0 (textureData mipTex)
   lower <- convertRGBA lo
   up <- copyHalf 128 (textureData mipTex)
   TexObj upper _ <- liftM textureData $ convertNormalTexture palette colorMap lightLevel up
   return $ mipTex {
      textureWidth  = 128,
      textureHeight = 128,
      textureData = TexSky lower upper }

  where convertRGBA mTex = do
           texName <- liftM head (genTextures 1)
           bindTexture  Texture2d texName
           mapM_ (texParameter Texture2d) [ TextureWrap S Repeat,
                                            TextureWrap T Repeat,
                                            TextureFilters LinearMipmapLinear Linear ]
           pixelDescr@(PixelDescriptor _ _ buf) <- skyToRGBA palette colorMap lightLevel mTex
           build2DMipmaps Texture2d Rgba' (textureWidth mTex) (textureHeight mTex) pixelDescr
           free buf
           return texName

        -- TODO: Make this a general blit
        copyHalf hOffset mTex = do
           let x         = hOffset
               y         = 0
               srcWidth  = 256
               dstWidth  = 128
               dstHeight = 128
               TexIndexed src = mTex
           dst <- mallocArray (dstWidth*dstHeight)
           zipWithM_ (\srcOff dstOff -> do val <- peekElemOff src srcOff
                                           pokeElemOff dst dstOff (val :: GLubyte))
                     [ srcOff | row    <- [y .. y + dstHeight - 1],
                                srcOff <- [ x + row * srcWidth .. x + row * srcWidth + dstWidth - 1 ] ]
                     [ 0 .. ]
           return $ mipTex {
              textureWidth  = 128,
              textureHeight = 128,
              textureData   = TexIndexed dst }
   
convertNormalTexture :: QPalette -> QColorMap -> LightLevel -> MipTex -> IO MipTex
convertNormalTexture palette colorMap lightLevel mipTex = do
   texName <- liftM head (genTextures 1)
   bindTexture  Texture2d texName
   mapM_ (texParameter Texture2d) [ TextureWrap S Repeat,
                                    TextureWrap T Repeat,
                                    TextureFilters LinearMipmapLinear Linear ]
   -- ??? Do we need this here ??? texEnv Replace
   (pixelDescr@(PixelDescriptor _ _ addr), alpha) <- indexedToRGBA palette colorMap lightLevel mipTex
   build2DMipmaps Texture2d Rgb' (textureWidth mipTex) (textureHeight mipTex) pixelDescr
   free addr
   return $ mipTex { textureData = TexObj texName alpha }

---------------------------------------------------------------------------
-- A single RGB triple

data QRGB = QRGB Qbyte Qbyte Qbyte

qGetQRGB :: Handle -> IO QRGB
qGetQRGB h = liftM3 QRGB (qGetQbyte h) (qGetQbyte h) (qGetQbyte h)

instance Storable QRGB where
   sizeOf    ~(QRGB r _ _) = 3 * sizeOf r
   alignment ~(QRGB r _ _) = alignment r

   peek addr = do [ r, g, b ] <- mapM (peekElemOff (castPtr addr)) [ 0 .. 2 ]
                  return $ QRGB r g b

   poke addr (QRGB r g b) = zipWithM_ (pokeElemOff (castPtr addr)) [ 0 .. ] [ r, g, b ]

---------------------------------------------------------------------------
-- A single RGBA triple

data QRGBA = QRGBA Qbyte Qbyte Qbyte Qbyte

instance Storable QRGBA where
   sizeOf    ~(QRGBA r _ _ _) = 4 * sizeOf r
   alignment ~(QRGBA r _ _ _) = alignment r

   peek addr = do [ r, g, b, a ] <- mapM (peekElemOff (castPtr addr)) [ 0 .. 3 ]
                  return $ QRGBA r g b a

   poke addr (QRGBA r g b a) = zipWithM_ (pokeElemOff (castPtr addr)) [ 0 .. ] [ r, g, b, a ]

---------------------------------------------------------------------------
-- A color palette

numPaletteEntries :: Int
numPaletteEntries = 256

type QColorIndex = Qbyte

newtype QPalette = QPalette (Array QColorIndex QRGB)

qGetQPalette :: Handle -> IO QPalette
qGetQPalette = liftM (QPalette . listArray (0, fromIntegral (numPaletteEntries-1))) .
               qGetN numPaletteEntries qGetQRGB

gammaCorrect :: Float -> QPalette -> QPalette
gammaCorrect gamma (QPalette p) = QPalette (fmap correctRGB p)
   where correctRGB (QRGB r g b) = QRGB (gammaTable ! r)
                                        (gammaTable ! g)
                                        (gammaTable ! b)
         gammaTable = listArray (0,255) (0 : [
            ceiling (((i / 255) ** rGamma) * 255) | i <- [1 .. 255] ])
         rGamma = recip gamma

---------------------------------------------------------------------------
-- A color map is a table from a light value (between 0 = full bright and
-- 63 = very dark) and a color index to an index into the (unique!) palette.

numColorMapEntries :: Int
numColorMapEntries = 64   -- Hmmm, QuakeSpecs 3.4 say 32 

type LightLevel = Int

newtype QColorMap = QColorMap (Array (LightLevel, QColorIndex) QColorIndex)

-- There's one trailing byte in Quake1's colormap.lmp, no idea what it means
qGetQColorMap :: Handle -> IO QColorMap
qGetQColorMap = liftM (QColorMap . listArray ((0, 0), (numColorMapEntries-1, fromIntegral (numPaletteEntries-1)))) .
                 qGetN (numColorMapEntries * numPaletteEntries) qGetQbyte
