Skip to content

Instantly share code, notes, and snippets.

@ocharles
Last active October 15, 2018 20:59
Show Gist options
  • Save ocharles/fcab6fcfded76f0ccf084f18cda0224f to your computer and use it in GitHub Desktop.
Save ocharles/fcab6fcfded76f0ccf084f18cda0224f to your computer and use it in GitHub Desktop.
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment