{-
   Quake 1 entities
   Sven Panne 2000.   mailto:Sven.Panne@informatik.uni-muenchen.de
-}

module Entity (
   EntityClass, EntityKey, EntityValue, Entity(..), readEntities,
   stringForKey, numForKey, angleForKey, vectorForKey
) where

import Char(isSpace)
import List(partition)
import Maybe(fromMaybe)
import Monad(liftM)
import QuakeTypes(Lump(..))
import Geometry(Angle, addAngle)
import IO(hSetPosn, SeekMode(..), hSeek, hGetChar)

---------------------------------------------------------------------------
-- A Quake 1 entity is basically a table mapping key strings to value
-- strings. The only key which is certainly in every entity is "classname",
-- but neither the set of class names nor the set of keys are fixed.
-- Note: In a BSP file there are no brushes in entities.

type EntityClass = String
type EntityKey   = String
type EntityValue = String

data Entity = Entity EntityClass [(EntityKey,EntityValue)]   deriving Show

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

readEntities :: Lump -> IO [Entity]
readEntities lump = do
   let h = lumpHandle lump
   hSetPosn (lumpFStart lump)
   hSeek h RelativeSeek . fromIntegral . lumpOffset $ lump
   let loop cs = case readEntity cs of
                    [(entity,rest)] -> entity : loop rest
                    _               -> []
   liftM loop (sequence (replicate (fromIntegral (lumpLength lump)) (hGetChar h)))

-- An enitity has a funny text format: { "key1" "value1"  "key2" "value2" ... }
-- Note: Brushes would be included within braces within an entity.

readEntity :: ReadS Entity
readEntity s = do
   ("{", t) <- myLex s
   (tok, u) <- myLex t
   (kvs, z) <- loop tok u
   case partition (\(k,_) -> k == "classname") kvs of
      ([(_,classname)],rest) -> return (Entity classname rest, z)
      _                      -> error ("Huh? Entity without a class name? " ++ show kvs)
  where loop "}"       v = return ([],v)
        loop ('"':key) v = do ('"':value, w) <- myLex v
                              (tk,        x) <- myLex w
                              (kvs,       y) <- loop tk x
                              [((key,value):kvs,y)]
        loop _         _ = []

myLex :: ReadS String
myLex "" = [("","")]
myLex (c:s) | isSpace c = myLex (dropWhile isSpace s)
myLex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
   where lexString ""      = []
         lexString ('"':t) = return ("",t) -- HACK: Dropping the double quote is done here!
         lexString (c  :t) = [(c:str, u) | (str,u) <- lexString t ]
myLex (c:s) | c `elem` "{}()" = return ([c],s)
myLex s = [span (not . isSpace) s]

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

valueForKey :: (EntityValue -> a) -> EntityKey -> Maybe a -> Entity -> a
valueForKey f key mbDefault entity@(Entity _ kvs) =
   maybe (fromMaybe err mbDefault) f (lookup key kvs)
       where err = error ("No key " ++ key ++ " in entity " ++ show entity)

stringForKey :: String -> Maybe EntityKey -> Entity -> String
stringForKey = valueForKey id

numForKey :: (Num a, Read a) => EntityKey -> Maybe a -> Entity -> a
numForKey = valueForKey read

 -- Note: Quake to OpenGL coordinate conversion is done below!
angleForKey :: String -> Maybe Angle -> Entity -> Angle
angleForKey = valueForKey (addAngle (-90) . read)

vectorForKey :: (Num a ,Read a) => EntityKey -> Maybe (a,a,a) -> Entity -> (a,a,a)
vectorForKey = valueForKey readVec3

 -- Note: Quake to OpenGL coordinate conversion is done below!
readVec3 :: (Num a, Read a) => String -> (a,a,a)
readVec3 = (\(x,y,z) -> (x,z,-y)) . onlyOneParse . reads3
   where reads3 s = do (x, t) <- reads s
                       (y, u) <- reads t
                       (z, v) <- reads u
                       return ((x,y,z),v)

onlyOneParse :: [(a,String)] -> a
onlyOneParse [(x,rest)] | all isSpace rest = x
                        | otherwise        = error ("onlyOneParse: trailing garbage " ++ rest)
onlyOneParse []                            = error "onlyOneParse no parse"
onlyOneParse _                             = error "onlyOneParse: multiple parses"
