{-
   Basic Quake 1 types
   Sven Panne 2000.   mailto:Sven.Panne@informatik.uni-muenchen.de
-}
module QuakeTypes where

import Array(Ix(..), Array, (!), listArray)
import IO(Handle, hGetChar, HandlePosn, hSetPosn, SeekMode(RelativeSeek), hSeek)
import Data.Int(Int16,Int32)
import Monad(liftM)
import Data.Word(Word8, Word16)
import System.IO(hGetBuf)
import Foreign

import GL(GLubyte, Storable(..))
import Geometry

---------------------------------------------------------------------------
-- basic Quake I/O stuff. Haskell *really* lacks binary I/O!!!

hGetBin :: Storable a => Handle -> IO a
hGetBin h = helper undefined
   where helper :: Storable a => a -> IO a
         helper dummy = alloca $ \buf -> do
                        hGetBuf h buf (sizeOf dummy)
                        peek buf

qGetN :: Integral a => a -> (Handle -> IO b) -> Handle -> IO [b]
qGetN n f = sequence . replicate (fromIntegral n) . f

{-
   This function was used to read n bytes Intel-like into number, but
   reading a Float was not portable, anyway, so we now simply use the
   non-portable binary IO from GL_BinaryIO for everything.

readBytes :: Num a => Int -> Handle -> IO a
readBytes n h = liftM (foldr (\x val -> val * 256 + fromIntegral (fromEnum x)) 0)
                      (qGetN n hGetChar h)
-}

---------------------------------------------------------------------------
-- Quake's strings within files have a fixed maximum length each, but I'm
-- unsure if it is guaranteed that they are 0-terminated.

readQstring :: Int -> Handle -> IO String
readQstring maxChars h = liftM (takeWhile (/='\0')) (qGetN maxChars hGetChar h)

---------------------------------------------------------------------------
-- *Very* basic Quake types
---------------------------------------------------------------------------

type Qbyte = Word8

instance Scalar Qbyte

qbyteSize :: Int
qbyteSize = sizeOf (undefined :: Qbyte)

qGetQbyte :: Handle -> IO Qbyte
qGetQbyte = hGetBin

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

type Qshort = Int16

instance Scalar Qshort

qshortSize :: Int
qshortSize = sizeOf (undefined :: Qshort)

qGetQshort :: Handle -> IO Qshort
qGetQshort = hGetBin

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

type Qushort = Word16

instance Scalar Qushort

qushortSize :: Int
qushortSize = sizeOf (undefined :: Qushort)

qGetQushort :: Handle -> IO Qushort
qGetQushort = hGetBin

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

type Qint = Int32

instance Scalar Qint

qintSize :: Int
qintSize = sizeOf (undefined :: Qint)

qGetQint :: Handle -> IO Qint
qGetQint = hGetBin

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

type Qfloat = Float -- hopefully 32-bit IEEE floating point

qfloatSize :: Int
qfloatSize = sizeOf (undefined :: Qfloat)

qGetQfloat :: Handle -> IO Qfloat
qGetQfloat = hGetBin

---------------------------------------------------------------------------
-- A Quake vector. NOTE: Quake's horizontal plane is x-y, OpenGL's x-z
-- Don't forget that angles have to adjusted by -90 degrees, too.

type QVector = Vector Qfloat

qVectorSize :: Int
qVectorSize = 3 * qfloatSize

qGetQVector :: Handle -> IO QVector
qGetQVector h = do
   x <- qGetQfloat h
   y <- qGetQfloat h
   z <- qGetQfloat h
   return $ Vector x z (-y)

---------------------------------------------------------------------------
-- A Quake point. NOTE: Quake's horizontal plane is x-y, OpenGL's x-z
-- Don't forget that angles have to adjusted by -90 degrees, too.

type QPoint = Point Qfloat

qPointSize :: Int
qPointSize = 3 * qfloatSize

qGetQPoint :: Handle -> IO QPoint
qGetQPoint h = do
   x <- qGetQfloat h
   y <- qGetQfloat h
   z <- qGetQfloat h
   return $ Point x z (-y)

---------------------------------------------------------------------------
-- An edge is represented by two points. NOTE: There is no qEdgeSize and no
-- qGetQEdge, because Quake uses indices into a field of vertices in its files.

data QEdge = QEdge QPoint QPoint   deriving Show

---------------------------------------------------------------------------
-- An axis aligned bounding box. NOTE: Quake's horizontal plane is x-y,
-- OpenGL's x-z (see QVertex), therefore min/max of the z-coordinate have
-- to be swapped.

type QAABBox = AABBox Qfloat

qAABBoxSize :: Int
qAABBoxSize = 6 * qfloatSize

qGetQAABBoxWith :: Scalar s => (Handle -> IO s) -> Handle -> IO (AABBox s)
qGetQAABBoxWith get h = do
   minX <- get h
   minY <- get h
   minZ <- get h
   maxX <- get h
   maxY <- get h
   maxZ <- get h
   return $ AABBox {
      aABBoxMin = Point minX minZ (-maxY),   -- swap!
      aABBoxMax = Point maxX maxZ (-minY)}

qGetQAABBox :: Handle -> IO QAABBox
qGetQAABBox = qGetQAABBoxWith qGetQfloat

---------------------------------------------------------------------------
-- Another kind of axis aligned bounding box, this time with shorts. This
-- means that all world coordinates must be between -32768..32767. 8 units
-- are 1 feet, so the world is max. 2.5km large.

type QAABBoxShort = AABBox Qshort

qAABBoxShortSize :: Int
qAABBoxShortSize = 6 * qshortSize

qGetQAABBoxShort :: Handle -> IO QAABBoxShort
qGetQAABBoxShort = qGetQAABBoxWith qGetQshort

---------------------------------------------------------------------------
-- A lump describes an area of a file.

data Lump = Lump {
   lumpHandle :: Handle,       -- associated file handle
   lumpFStart :: HandlePosn,   -- start of the file
   lumpOffset :: Qint,         -- offset in bytes relative to start of file
   lumpLength :: Qint          -- size in bytes
 }

instance Show Lump where
   showsPrec p (Lump {lumpOffset = offs, lumpLength = len}) =
      showParen (p >= 9) (showString "Lump " . shows offs . showChar ' ' . shows len)

lumpSize :: Int
lumpSize = 2 * qintSize

qGetLump :: HandlePosn -> Handle -> IO Lump
qGetLump start h = do
   offs <- qGetQint h
   len  <- qGetQint h
   return $ Lump {
      lumpHandle = h,
      lumpFStart = start,
      lumpOffset = offs,
      lumpLength = len }

seekLump :: Lump -> IO ()
seekLump lump = do
   hSetPosn (lumpFStart lump)
   hSeek (lumpHandle lump) RelativeSeek . fromIntegral . lumpOffset $ lump

readLumpInternal :: Integral i =>  (i -> [a] -> b) -> (Handle -> IO a) -> Lump -> i -> IO b
readLumpInternal fromList reader lump size = do
   seekLump lump
   let count = (fromIntegral (lumpLength lump) `asTypeOf` size) `div` size
       h = lumpHandle lump
   liftM (fromList count) (sequence (replicate (fromIntegral count) (reader h)))

readLumpAWith :: (Integral a, Ix b, Num b) => (Handle -> IO c) -> Lump -> a -> IO (Array b c)
readLumpAWith = readLumpInternal (\len -> listArray (0, if len == 0 then -1 else fromIntegral (len-1)))

loadLumpBytes :: Lump -> IO (Ptr GLubyte)
loadLumpBytes lump = do
   let count = fromIntegral (lumpLength lump)
   seekLump lump
   buf <- mallocArray count
   hGetBuf (lumpHandle lump) buf count
   return buf

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

data Slice a = Slice Int             -- from
                     Int             -- count
                     (Array Int a)   -- all elements

instance Show (Slice a) where
   showsPrec p (Slice from count _) =
      showParen (p>=9) (showString "Slice " . shows from . showChar ' ' . shows count)

slice :: (Integral a, Integral b) => a -> b -> Array Int c -> Slice c
slice from count arr = Slice (fromIntegral from) (fromIntegral count) arr

-- The case distinction is necessary for preventing underflow with unsigned numbers.
lSlice :: (Integral a, Integral b) => a -> b -> Array Int d -> [d]
lSlice from count arr
   | count > 0 = map (arr !) [fromIntegral from .. fromIntegral from + fromIntegral count - 1]
   | otherwise = []
