Q3 BSP Parser.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Parser
  ( BSPFile(..)
  , Entities(..)
  , Texture(..)
  , Plane(..)
  , Node(..)
  , Leaf(..)
  , LeafFace(..)
  , LeafBrush(..)
  , Model(..)
  , Brush(..)
  , BrushSide(..)
  , Vertex(..)
  , MeshVert(..)
  , Effect(..)
  , Face(..)
  , LightMap(..)
  , LightVol(..)
  , Visdata(..)
  , parseBSP
  ) where

import Control.Monad
import Data.Bifunctor
import Data.Binary hiding (gget, get)
import Data.Binary.Get
import qualified Data.ByteString.Lazy as LBS
import Data.Int
import Data.Profunctor
import Data.Proxy
import Data.Tagged
import Data.Text (Text)
import Data.Text.Encoding
import Data.Typeable
import Data.Vector (Vector)
import qualified Data.Vector as V
import GHC.Generics
import GHC.TypeLits

--------------------------------------------------------------------------------
-- | 'Q3Type' is the class of types that can appear in a @.bsp@ file.
class Q3Type a where
  -- | Get decodes the binary encoding of a given value.
  get :: Get a

  -- We can generically derive an implementation of 'get' for any data types
  -- that are products of 'Q3Type's.
  default get :: (Typeable a, Generic a, GQ3Type (Rep a)) =>
    Get a
  get = label (show (typeRep (Proxy @a))) (to <$> gget)

-- We can have lists of 'Q3Type's, provided we know how many bytes each elemnt
-- occupies. 'Q3Sized' captures this information for us.
instance (Q3Type a, Q3Sized a) => Q3Type (Vector a) where
  get = do
    n <- remaining
    V.replicateM (fromIntegral (n `div` untag @a sizeOf)) get

-- | Unbounded text with ASCII decoding.
instance Q3Type Text where
  get = decodeUtf8 . LBS.toStrict <$> getRemainingLazyByteString

instance (Q3Type a, Q3Type b) => Q3Type (a, b) where
  get = (,) <$> get <*> get

instance (Q3Sized a, Q3Sized b) =>
         Q3Sized (a, b) where
  sizeOf = lmap (\(a, _) -> a) sizeOf + lmap (\(_, b) -> b) sizeOf

--------------------------------------------------------------------------------
-- | The class of types that occupy a static amount of bytes.
class Q3Sized a where
  sizeOf :: Tagged a Int64
  default sizeOf :: (Generic a, GQ3Sized (Rep a)) => Tagged a Int64
  sizeOf = first to gsizeOf

--------------------------------------------------------------------------------
class GQ3Type f where
  gget :: Get (f a)

instance GQ3Type f => GQ3Type (M1 i c f) where
  gget = M1 <$> gget

instance (GQ3Type f, GQ3Type g) => GQ3Type (f :*: g) where
  gget = (:*:) <$> gget <*> gget

instance Q3Type a => GQ3Type (K1 i a) where
  gget = K1 <$> get

--------------------------------------------------------------------------------
class GQ3Sized f where
  gsizeOf :: Tagged (f a) Int64

instance GQ3Sized f => GQ3Sized (M1 i c f) where
  gsizeOf = first M1 gsizeOf

instance (GQ3Sized f, GQ3Sized g) =>
         GQ3Sized (f :*: g) where
  gsizeOf =
    lmap (\(a :*: _) -> a) (gsizeOf @f) + lmap (\(_ :*: b) -> b) (gsizeOf @g)

instance Q3Sized a => GQ3Sized (K1 i a) where
  gsizeOf = first K1 sizeOf

--------------------------------------------------------------------------------
-- | Transform any decoder to operate over a fixed amount of bytes. Useful
-- for scoping 'Text'.
newtype FixedLength (l :: Nat) a = FixedLength a
  deriving (Show)

instance (KnownNat n, Q3Type a, Typeable a) =>
         Q3Type (FixedLength n a) where
  get = do
    let n = fromIntegral (natVal (Proxy @n))
    label
      ("FixedLength " ++ show n ++ " " ++ show (typeRep (Proxy @a)))
      (isolate n (FixedLength <$> get))

instance KnownNat n => Q3Sized (FixedLength n a) where
  sizeOf = Tagged (fromIntegral (natVal (Proxy @n)))

--------------------------------------------------------------------------------
-- | 4-byte integers in little-endian order.
instance Q3Type Int32 where
  get = getInt32le

instance Q3Sized Int32 where
  sizeOf = 4

instance Q3Type Int8 where
  get = getInt8

instance Q3Sized Int8 where
  sizeOf = 1

instance Q3Type Float where
  get = getFloatle

instance Q3Sized Float where
  sizeOf = 4

--------------------------------------------------------------------------------
data BSPFile = BSPFile
  { bspEntities    :: !Entities
  , bspTextures    :: !(Vector Texture)
  , bspPlanes      :: !(Vector Plane)
  , bspNodes       :: !(Vector Node)
  , bspLeafs       :: !(Vector Leaf)
  , bspLeafFaces   :: !(Vector LeafFace)
  , bspLeafBrushes :: !(Vector LeafBrush)
  , bspModels      :: !(Vector Model)
  , bspBrushes     :: !(Vector Brush)
  , bspBrushSides  :: !(Vector BrushSide)
  , bspVertexes    :: !(Vector Vertex)
  , bspMeshVerts   :: !(Vector MeshVert)
  , bspEffects     :: !(Vector Effect)
  , bspFaces       :: !(Vector Face)
  , bspLightMaps   :: !(Vector LightMap)
  , bspLightVols   :: !(Vector LightVol)
  , bspVisdata     :: !Visdata
  } deriving (Show)

data DirEntry a = DirEntry
  { deOffset :: {-# UNPACK #-} !Int32
  , deLength :: {-# UNPACK #-} !Int32
  } deriving (Generic, Show)

instance (Typeable a, Q3Type a) => Q3Type (DirEntry a)

data DirEntries = DirEntries
  { dirEntities    :: DirEntry Entities
  , dirTextures    :: DirEntry (Vector Texture)
  , dirPlanes      :: DirEntry (Vector Plane)
  , dirNodes       :: DirEntry (Vector Node)
  , dirLeafs       :: DirEntry (Vector Leaf)
  , dirLeafFaces   :: DirEntry (Vector LeafFace)
  , dirLeafBrushes :: DirEntry (Vector LeafBrush)
  , dirModels      :: DirEntry (Vector Model)
  , dirBrushes     :: DirEntry (Vector Brush)
  , dirBrushSides  :: DirEntry (Vector BrushSide)
  , dirVertexes    :: DirEntry (Vector Vertex)
  , dirMeshVerts   :: DirEntry (Vector MeshVert)
  , dirEffects     :: DirEntry (Vector Effect)
  , dirFaces       :: DirEntry (Vector Face)
  , dirLightMaps   :: DirEntry (Vector LightMap)
  , dirLightVols   :: DirEntry (Vector LightVol)
  , dirVisdata     :: DirEntry Visdata
  } deriving (Generic, Show, Q3Type)

newtype Entities =
  Entities Text
  deriving (Show)

instance Q3Type Entities where
  get = Entities . decodeUtf8 . LBS.toStrict <$> getRemainingLazyByteString

data Texture = Texture
  { textureName     :: {-# UNPACK #-} !(FixedLength 64 Text)
  , textureFlags    :: {-# UNPACK #-} !Int32
  , textureContents :: {-# UNPACK #-} !Int32
  } deriving (Generic, Show, Q3Type, Q3Sized)

data Plane = Plane
  { planeNormal :: {-# UNPACK #-} !V3f
  , planeDist   :: {-# UNPACK #-} !Float
  } deriving (Generic, Show, Q3Type, Q3Sized)

data Node = Node
  { nodePlane    :: {-# UNPACK #-} !Int32
  , nodeChildren :: {-# UNPACK #-} !(Int32, Int32)
  , nodeMin      :: {-# UNPACK #-} !V3i
  , nodeMax      :: {-# UNPACK #-} !V3i
  }
  deriving (Generic, Show, Q3Type, Q3Sized)

data Leaf = Leaf
  { leafCluster  :: {-# UNPACK #-}!Int32
  , leafArea     :: {-# UNPACK #-}!Int32
  , leafMin      :: {-# UNPACK #-}!V3i
  , leafMax      :: {-# UNPACK #-}!V3i
  , leafFace     :: {-# UNPACK #-}!Int32
  , leafNLeafs   :: {-# UNPACK #-}!Int32
  , leafBrush    :: {-# UNPACK #-}!Int32
  , leafNBrushes :: {-# UNPACK #-}!Int32
  } deriving (Generic, Show, Q3Type, Q3Sized)

newtype LeafFace = LeafFace
  { leafFaceFace :: Int32
  } deriving (Generic, Show, Q3Type, Q3Sized)

newtype LeafBrush = LeafBrush
  { leafBrushBrush :: Int32
  } deriving (Generic, Show, Q3Type, Q3Sized)

data Model = Model
  { modelMin      :: {-# UNPACK #-} !V3f
  , modelMax      :: {-# UNPACK #-} !V3f
  , modelFace     :: {-# UNPACK #-} !Int32
  , modelNFaces   :: {-# UNPACK #-} !Int32
  , modelBrush    :: {-# UNPACK #-} !Int32
  , modelNBrushes :: {-# UNPACK #-} !Int32
  } deriving (Generic, Show, Q3Type, Q3Sized)

data Brush = Brush
  { brushBrushSide   :: {-# UNPACK #-} !Int32
  , brushNBrushSides :: {-# UNPACK #-} !Int32
  , brushTexture     :: {-# UNPACK #-} !Int32
  } deriving (Generic, Show, Q3Type, Q3Sized)

data BrushSide = BrushSide
  { brushSidePlane   :: {-# UNPACK #-} !Int32
  , brushSideTexture :: {-# UNPACK #-} !Int32
  } deriving (Generic, Show, Q3Type, Q3Sized)

data Vertex = Vertex
  { vertexPosition         :: {-# UNPACK #-} !V3f
  , veretxTexCoordSurface  :: {-# UNPACK #-} !V2f
  , vertexTexCoordLightmap :: {-# UNPACK #-} !V2f
  , vertexNormal           :: {-# UNPACK #-} !V3f
  , vertexColor            :: {-# UNPACK #-} !V4b
  } deriving (Generic, Show, Q3Type, Q3Sized)

data MeshVert = MeshVert
  { meshVertOffset :: {-# UNPACK #-} !Int32
  } deriving (Generic, Show, Q3Type, Q3Sized)

data Effect = Effect
  { effectName    :: {-# UNPACK #-} !(FixedLength 64 Text)
  , effectBrush   :: {-# UNPACK #-} !Int32
  , effectUnknown :: {-# UNPACK #-} !Int32
  } deriving (Generic, Show, Q3Type, Q3Sized)

data Face = Face
  { faceTexture    :: {-# UNPACK #-} !Int32
  , faceEffect     :: {-# UNPACK #-} !Int32
  , faceType       :: {-# UNPACK #-} !Int32
  , faceVertex     :: {-# UNPACK #-} !Int32
  , faceNVertexes  :: {-# UNPACK #-} !Int32
  , faceMeshVert   :: {-# UNPACK #-} !Int32
  , faceNMeshVerts :: {-# UNPACK #-} !Int32
  , faceLMIndex    :: {-# UNPACK #-} !Int32
  , faceLMStart    :: {-# UNPACK #-} !(Int32, Int32)
  , faceLMSize     :: {-# UNPACK #-} !(Int32, Int32)
  , faceLMOrigin   :: {-# UNPACK #-} !V3f
  , faceLMS        :: {-# UNPACK #-} !V3f
  , faceLMT        :: {-# UNPACK #-} !V3f
  , faceNormal     :: {-# UNPACK #-} !V3f
  , faceSize       :: {-# UNPACK #-} !(Int32, Int32)
  } deriving (Generic, Show, Q3Type, Q3Sized)

newtype LightMap = LightMap { lightMapData :: FixedLength (128 * 128 * 3) (Vector V3b) }
  deriving (Generic, Show, Q3Type, Q3Sized)

data LightVol = LightVol
  { lightVolAmbient     :: {-# UNPACK #-} !V3b
  , lightVolDirectional :: {-# UNPACK #-} !V3b
  , lightVolDir         :: {-# UNPACK #-} !V2b
  } deriving (Generic, Show, Q3Type, Q3Sized)

data Visdata = Visdata
  { visdataNVecs  :: {-# UNPACK #-} !Int32
  , visdataSzVecs :: {-# UNPACK #-} !Int32
  , visdataVecs   :: {-# UNPACK #-} !(Vector Int8)
  } deriving (Generic, Show)

instance Q3Type Visdata where
  get = do
    visdataNVecs <- get
    visdataSzVecs <- get
    visdataVecs <-
      V.replicateM (fromIntegral (visdataNVecs * visdataSzVecs)) get
    pure Visdata {..}

data V3f = V3f {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float
  deriving (Generic, Show, Q3Type, Q3Sized)

data V2f = V2f {-# UNPACK #-} !Float {-# UNPACK #-} !Float
  deriving (Generic, Show, Q3Type, Q3Sized)

data V3i = V3i {-# UNPACK #-} !Int32 {-# UNPACK #-} !Int32 {-# UNPACK #-} !Int32
  deriving (Generic, Show, Q3Type, Q3Sized)

data V2b = V2b {-# UNPACK #-} !Int8 {-# UNPACK #-} !Int8
  deriving (Generic, Show, Q3Type, Q3Sized)

data V3b = V3b {-# UNPACK #-} !Int8 {-# UNPACK #-} !Int8 {-# UNPACK #-} !Int8
  deriving (Generic, Show, Q3Type, Q3Sized)

data V4b = V4b {-# UNPACK #-} !Int8 {-# UNPACK #-} !Int8 {-# UNPACK #-} !Int8 {-# UNPACK #-} !Int8
  deriving (Generic, Show, Q3Type, Q3Sized)

parseBSP :: LBS.ByteString -> Either (LBS.ByteString, ByteOffset, String) BSPFile
parseBSP bytes = do
  (_, _, DirEntries {..}) <- runGetOrFail parseHeader bytes
  bspEntities    <- parseLump dirEntities
  bspTextures    <- parseLump dirTextures
  bspPlanes      <- parseLump dirPlanes
  bspNodes       <- parseLump dirNodes
  bspLeafs       <- parseLump dirLeafs
  bspLeafFaces   <- parseLump dirLeafFaces
  bspLeafBrushes <- parseLump dirLeafBrushes
  bspModels      <- parseLump dirModels
  bspBrushes     <- parseLump dirBrushes
  bspBrushSides  <- parseLump dirBrushSides
  bspVertexes    <- parseLump dirVertexes
  bspMeshVerts   <- parseLump dirMeshVerts
  bspEffects     <- parseLump dirEffects
  bspFaces       <- parseLump dirFaces
  bspLightMaps   <- parseLump dirLightMaps
  bspLightVols   <- parseLump dirLightVols
  bspVisdata     <- parseLump dirVisdata
  pure BSPFile {..}
  where
    parseLump
      :: Q3Type a
      => DirEntry a -> Either (LBS.ByteString, ByteOffset, String) a
    parseLump DirEntry {deLength, deOffset} =
      fmap
        (\(_, _, a) -> a)
        (runGetOrFail
           (isolate (fromIntegral deLength) (get <* getRemainingLazyByteString))
           (LBS.drop (fromIntegral deOffset) bytes))

parseHeader :: Get DirEntries
parseHeader = do
  _ <- mfilter ("IBSP" ==) (getByteString 4)
  _ <- mfilter (0x2e ==) (get @Int32)
  get