initial framework for rendering

GPipeFPS.hs

@@ -1,39 +1,19 @@
 module GPipeFPS where
 
-import Graphics.GPipe
+import BSPLoader
 import Data.List
-import qualified Data.Vec as Vec
-import Data.Vec.Nat
+import Data.Trie (Trie)
 import Data.Vec.LinAlg.Transform3D
-import qualified Data.Vector as V
-import BSPLoader
+import Data.Vec.Nat
+import Foreign
+import Graphics.GPipe
+import qualified Data.ByteString as SB
+import qualified Data.Trie as T
+import qualified Data.Vec as Vec
 import qualified Data.Vect as Vect
-
-simple cWorldProjection fb obj = paintColorDepth Less True NoBlending (RGB $ Vec.vec True) (rast obj) fb
-  where
---    vert :: (Vec3 (Float),Vec2 (Float),Vec2 (Float),Vec3 (Float),Vec4 (Float)) -> (Vec4 (Vertex Float),Vec4 (Vertex Float))
-    vert (v{-,_,_,_,_-}) = (cWorldProjection `multmv` v4,cWorldProjection `multmv` v4)
-      where
-        v4 = Vec.snoc v 1
-
-    --rast :: PrimitiveStream Triangle (Vec3 (Vertex Float)) -> FragmentStream (Color RGBFormat (Fragment Float))
-    rast obj = fmap frag $ rasterizeBack $ fmap vert obj
-
-    --frag :: Vec4 (Fragment Float) -> Color RGBFormat (Fragment Float)
-    frag (x:.y:.z:.w:.()) = (RGB ((fract' x):.(fract' y):.(1 + fract' z):.()),z / w)
+import qualified Data.Vector as V
 
 {-
-TODO:
-    create gpipe mesh from every surfaces
-
-    = DrawVertex
-    { dvPosition    :: Vec3
-    , dvDiffuseUV   :: Vec2
-    , dvLightmaptUV :: Vec2
-    , dvNormal      :: Vec3
-    , dvColor       :: Vec4
-    }
-
 data Surface
     = Surface
     { srShaderNum      :: Int
@@ -52,35 +32,64 @@ data Surface
     , srLightmapVec3   :: Vec3
     , srPatchSize      :: Vec2
     }
-
-data SurfaceType
-    = Planar
-    | Patch
-    | TriangleSoup
-    | Flare
 -}
 
--- toIndexedGPUStream
---geometry :: BSPLevel -> V.Vector (PrimitiveStream Triangle (Vec3 (Vertex Float),Vec2 (Vertex Float),Vec2 (Vertex Float),Vec3 (Vertex Float),Vec4 (Vertex Float)))
-geometry' bsp = V.map convertSurface $ blSurfaces bsp    
+type VertexData = (Vec.Vec3 (Vertex Float),Vec.Vec2 (Vertex Float),Vec.Vec4 (Vertex Float))
+type Mesh = PrimitiveStream Triangle VertexData
+type FB = FrameBuffer RGBFormat DepthFormat ()
+
+-- time -> worldProjection -> inFrameBuffer -> resultFrameBuffer
+type SurfaceRenderer = Vertex Float -> Vec.Mat44 (Vertex Float) -> FB -> FB
+type Renderer = Mesh -> SurfaceRenderer
+
+errorRenderer :: Maybe (Texture2D RGBFormat) -> Renderer
+errorRenderer t obj time cWorldProjection fb = paintColorDepth Less True NoBlending (RGB $ Vec.vec True) (rast obj) fb
   where
-    convertSurface sf = case srSurfaceType sf of
+    vert (v,lt,c) = (cWorldProjection `multmv` v4,(cWorldProjection `multmv` v4,lt,c))
+      where
+        v4 = Vec.snoc v 1
+
+    rast obj = fmap frag $ rasterizeBack $ fmap vert obj
+
+    frag (x:.y:.z:.w:.(),lt,cr:.cg:.cb:.ca:.()) = (RGB ((cr * r * fract' x):.(cg * g * fract' y):.(cb * b * (1 + fract' z)):.()),z / w)
+      where
+        RGB (r:.g:.b:.()) = case t of
+            Just tx -> RGB (1:.1:.1:.())--sample (Sampler Linear Clamp) tx lt
+            Nothing -> RGB (1:.1:.1:.())
+
+compileBSP :: Trie Renderer -> BSPLevel -> V.Vector SurfaceRenderer
+compileBSP shaderMap bsp = V.map convertSurface $ blSurfaces bsp
+  where
+    shaders = V.map (\k -> T.lookup (shName k) shaderMap) $ blShaders bsp
+    lightmaps = V.map tx $ blLightmaps bsp
+
+    tx :: Lightmap -> Texture2D RGBFormat
+    tx lm = unsafePerformIO $ SB.useAsCString (lmMap lm) $ \p -> newTexture (PerComp3 UnsignedByteFormat) RGB8 (128:.128:.()) [castPtr p]
+
+    convertSurface sf = renderer $ case srSurfaceType sf of
         Planar       -> toIndexedGPUStream TriangleList v i
-        --Patch        -> toGPUStream Point v
         TriangleSoup -> toIndexedGPUStream TriangleList v i
+        --Patch        -> toGPUStream Point v
         --Flare        -> toGPUStream Point v
         _              -> toGPUStream TriangleList []
       where
         v = V.toList $ V.take (srNumVertices sf) $ V.drop (srFirstVertex sf) vertices
         i = V.toList $ V.take (srNumIndices sf) $ V.drop (srFirstIndex sf) indices
+        renderer = case shaders V.! srShaderNum sf of
+            Just r  -> r
+            Nothing -> errorRenderer lm
+        lm = if 0 <= lmidx && lmidx < V.length lightmaps then Just $ lightmaps V.! lmidx else Nothing
+        lmidx = srLightmapNum sf
+
     vertices = V.map convertVertex $ blDrawVertices bsp
     indices  = blDrawIndices bsp
-    convertVertex (DrawVertex p dt lt n c) = (v3 p {-, v2 dt, v2 lt, v3 n, v4 c-})
+    convertVertex (DrawVertex p dt lt n c) = (v3 p,v2 lt,v4 c)-- , v2 dt, v2 lt, v3 n, v4 c)
     v2 (Vect.Vec2 i j) = i:.j:.()
     v3 (Vect.Vec3 i j k) = (s i):.(s j):.(s k):.()
     v4 (Vect.Vec4 i j k l) = i:.j:.k:.l:.()
     s a = 0.01 * a
 
+{-
 geometry :: BSPLevel -> V.Vector (PrimitiveStream Triangle (Vec3 (Vertex Float)))
 geometry bsp = V.fromList [toGPUStream TriangleList $ V.toList $ V.map convertVertex $ V.concatMap convertSurface $ blSurfaces bsp]
   where
@@ -93,13 +102,15 @@ geometry bsp = V.fromList [toGPUStream TriangleList $ V.toList $ V.map convertVe
         i = V.take (srNumIndices sf) $ V.drop (srFirstIndex sf) indices
     vertices = blDrawVertices bsp
     indices  = blDrawIndices bsp
-    convertVertex (DrawVertex p dt lt n c) = (v3 p{-, v2 dt, v2 lt, v3 n, v4 c-})
+    convertVertex (DrawVertex p dt lt n c) = (v3 p)--, v2 dt, v2 lt, v3 n, v4 c)
     v2 (Vect.Vec2 i j) = i:.j:.()
     v3 (Vect.Vec3 i j k) = (s i):.(s j):.(s k):.()
     v4 (Vect.Vec4 i j k l) = i:.j:.k:.l:.()
     s a = 0.01 * a
+-}
 
-renderBSP worldProjection bsp = V.foldl' (simple worldProjection) clear $ bsp
+renderSurfaces :: Vertex Float -> Vec.Mat44 (Vertex Float) -> V.Vector SurfaceRenderer -> FB
+renderSurfaces time worldProjection faces = V.foldl' (\fb fun -> fun time worldProjection fb) clear $ faces
   where
     clear = newFrameBufferColorDepth (RGB (0:.0:.0:.())) 1000
 

ShaderParser.hs

@@ -7,6 +7,7 @@ import Data.Attoparsec.Char8
 import Data.Attoparsec.Combinator
 import Data.ByteString.Char8 (ByteString)
 import Data.Char (toLower)
+import GPipeFPS
 import qualified Data.ByteString.Char8 as B
 
 -- utility parsers
@@ -16,6 +17,8 @@ shaderName = word
 skip :: Parser ()
 skip = skipSpace <* many (comment <* skipSpace)
 
+skipRest = skipWhile (\c -> c /= '\n' && c /= '\r')
+
 comment = (stringCI "//" <* skipWhile (\c -> c /= '\n' && c /= '\r')) <|> (string "/*" <* manyTill anyChar (try (string "*/")))
 
 word :: Parser ByteString
@@ -37,30 +40,35 @@ int = skip *> decimal
 
 waveFun = kw "sin" <|> kw "triangle" <|> kw "square" <|> kw "sawtooth" <|> kw "inversesawtooth" <|> kw "noise"
 
-shaders = many shader <* skipSpace
+shaders :: Parser [(ByteString,(Int,Renderer))]
+shaders = skip *> many shader <* skip
 
-shader = word <*
+shader :: Parser (ByteString,(Int,Renderer))
+shader = (\n -> (n,(0,errorRenderer Nothing))) <$> word <*
     kw "{" <*
         many (general <|> q3map <|> editor <|> stage) <*
     kw "}"
 
-general = skyParms  <|> cull        <|> deformVertexes  <|> fogParms    <|> 
-          nopicmip  <|> nomipmaps   <|> polygonOffset   <|> portal      <|> sort <|>
-          entityMergable
+general = skyParms          <|> cull        <|> deformVertexes  <|> fogParms    <|> 
+          nopicmip          <|> nomipmaps   <|> polygonOffset   <|> portal      <|> sort <|>
+          entityMergable    <|> fogonly
 
-q3map = q3MapSun <|> surfaceParm <|> 
+q3map = q3MapSun <|> surfaceParm <|> light <|> lightning <|> cloudparams <|> sky <|> foggen <|>
         tessSize <|> (skip *> stringCI "q3map_" *> skipWhile (\c -> c /= '\n' && c /= '\r'))
 
 editor = (skip *> stringCI "qer_" *> skipWhile (\c -> c /= '\n' && c /= '\r'))
 
 stage = kw "{" <* many stageAttrs <* kw "}"
-stageAttrs  = mapP  <|> clampMap    <|> animMap     <|> blendFunc   <|> rgbGen  <|> alphaGen    <|>
-              tcGen <|> tcMod       <|> depthFunc   <|> depthWrite  <|> detail  <|> alphaFunc
+stageAttrs  = mapP      <|> clampMap    <|> animMap     <|> blendFunc   <|> rgbGen  <|> alphaGen    <|>
+              tcGen     <|> tcMod       <|> depthFunc   <|> depthWrite  <|> detail  <|> alphaFunc   <|>
+              alphaMap
 
 --
 -- General Shader Keywords
 --
 
+fogonly = kw "fogonly"
+
 {-
 skyParms <farbox> <cloudheight> <nearbox>
   <farbox>:
@@ -71,21 +79,22 @@ skyParms <farbox> <cloudheight> <nearbox>
     “-“ - ignore (This has not been tested in a long time)
 -}
 
-skyParms = kw "skyparms" <* (kw "-" <|> (const () <$> word)) <* (float <|> (const 0 <$> kw "-")) <* kw "-"
+skyParms = kw "skyparms" <* (kw "-" <|> (const () <$> word)) <* (kw "-" <|> (const () <$> word)) <* kw "-"
 
-cull = kw "cull" <* (kw "front" <|> kw "back" <|> kw "disable" <|> kw "none" <|> kw "twosided")
+cull = kw "cull" <* (kw "front" <|> kw "back" <|> kw "disable" <|> kw "none" <|> kw "twosided" <|> kw "backsided")
 
 deformVertexes = kw "deformvertexes" <* (
-    kw "wave" <* float <* waveFun <* float <* float <* float <* float <|>
-    kw "normal" <* float <* float <|>
-    kw "bulge" <* float <* float <* float <|>
-    kw "move" <* float <* float <* float <* waveFun <* float <* float <* float <* float <|>
     kw "autosprite" <|>
     kw "autosprite2" <|>
-    kw "projectionshadow"
+    kw "bulge" <* float <* float <* float <|>
+    kw "move" <* float <* float <* float <* waveFun <* float <* float <* float <* float <|>
+    kw "normal" <* float <* float <|>
+    kw "projectionshadow" <|>
+    kw "text0" <|> kw "text1" <|> kw "text2" <|> kw "text3" <|> kw "text4" <|> kw "text5" <|> kw "text6" <|> kw "text7" <|>
+    kw "wave" <* float <* waveFun <* float <* float <* float <* float
     )
 
-fogParms = kw "fogparms" <* kw "(" <* float <* float <* float <* kw ")" <* float
+fogParms = kw "fogparms" <* option () (kw "(") <* float <* float <* float <* option () (kw ")") <* float <* skipRest
 
 nopicmip = kw "nopicmip"
 
@@ -103,6 +112,12 @@ sort = kw "sort" <* (kw "portal" <|> kw "sky" <|> kw "opaque" <|> kw "banner" <|
 --
 -- Q3MAP Specific Shader Keywords
 --
+cloudparams = kw "cloudparms" *> skipRest
+lightning = kw "lightning" *> skipRest
+light = (kw "light" <|> kw "light1") *> skipRest
+sky = kw "sky" *> skipRest
+foggen = kw "foggen" *> skipRest
+alphaMap = kw "alphamap" *> skipRest
 
 tessSize = kw "tesssize" <* float
 
@@ -117,6 +132,7 @@ surfaceParm = kw "surfaceparm" <* (
     <|> kw "slick"      <|> kw "noimpact"   <|> kw "nomarks"        <|> kw "ladder"     <|> kw "nodamage"
     <|> kw "metalsteps" <|> kw "flesh"      <|> kw "nosteps"        <|> kw "nodraw"     <|> kw "antiportal"
     <|> kw "pointlight" <|> kw "nolightmap" <|> kw "nodlight"       <|> kw "dust"       <|> kw "lightgrid"
+    <|> kw "nopicmip"   <|> kw "nomipmaps"
     )
 
 --
@@ -141,7 +157,7 @@ blendFunc     = kw "blendfunc" <* choice [blendFuncFunc, srcBlend <* dstBlend]
 rgbGen = kw "rgbgen" <* (
     kw "wave" <* waveFun <* float <* float <* float <* float
     <|> kw "const" <* kw "(" <* float <* float <* float <* kw ")"
-    <|> kw "identity"   <|> kw "identitylighting"   <|> kw "entity"             <|> kw "oneminusentity"
+    <|> kw "identity"    <|> kw "identitylighting"  <|> kw "entity"             <|> kw "oneminusentity"
     <|> kw "exactvertex" <|> kw "vertex"            <|> kw "lightingdiffuse"    <|> kw "oneminusvertex"
     )
 
@@ -160,13 +176,14 @@ tcGen = kw "tcgen" <* (
     )
 
 tcMod = kw "tcmod" <* (
-    kw "rotate" <* float <|>
-    kw "scale" <* float <* float <|>
-    kw "scroll" <* float <* float <|>
+    kw "entitytranslate" <|>
+    kw "environment" <|>
+    kw "rotate" <* float <* skipRest <|>
+    kw "scale" <* float <* float <* skipRest <|>
+    kw "scroll" <* float <* float <* skipRest <|>
     kw "stretch" <* waveFun <* float <* float <* float <* float <|>
     kw "transform" <* float <* float <* float <* float <* float <* float <|>
-    kw "turb" <* float <* float <* float <* float <|>
-    kw "entitytranslate"
+    kw "turb" <* option () (kw "sin") <* float <* float <* float <* float
     )
 
 depthFunc = kw "depthfunc" <* (kw "lequal" <|> kw "equal")

fpsDemo.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 import Control.Applicative
 import Control.Monad
+import Data.Attoparsec.Char8
 import Data.IORef
 import Data.List
 import Data.Monoid
@@ -9,15 +10,19 @@ import Data.Vec.Nat
 import FRP.Elerea.Param
 import GPipeFPS
 import GPipeUtils
-import qualified BSPLoader as B
+import Graphics.GPipe
+import Graphics.Rendering.OpenGL ( Position(..) )
 import ShaderParser
+import System.Directory
+import System.FilePath
 import Utils as U
-import Graphics.GPipe
+import qualified BSPLoader as B
+import qualified Data.ByteString.Char8 as SB
 import qualified Data.Map as Map
+import qualified Data.Trie as T
 import qualified Data.Vec as Vec
 import qualified Data.Vect.Float as V
 import qualified Data.Vector as VC
-import Graphics.Rendering.OpenGL ( Position(..) )
 import Graphics.UI.GLUT( Window,
                          mainLoop,
                          postRedisplay,
@@ -32,6 +37,20 @@ import Graphics.UI.GLUT( Window,
                          keyboardMouseCallback)
 
 
+loadShaders :: IO (T.Trie (Int,Renderer))
+loadShaders = do
+    l <- filter (\a -> ".shader" == takeExtension a) <$> getDirectoryContents "fps/scripts"
+    sl <- forM l $ \n -> do
+        s <- SB.readFile $ "fps/scripts/" ++ n
+        return $ case parse shaders s of
+            Done "" r -> r
+            Fail _ c _   -> error $ show (n,"failed",c)
+            Partial f -> case f "" of
+                Done "" r -> r
+                _   -> error $ show (n,"partial failed")
+            Done rem r -> error $ show (n,"failed", map fst r)
+    return $ T.fromList $ concat sl
+
 main :: IO ()
 main = do
     getArgsAndInitialize
@@ -45,18 +64,13 @@ main = do
     --bsp <- B.loadBSP "fps/maps/pukka3tourney7.bsp"
     bsp <- B.loadBSP "fps/maps/SGDTT3.bsp"
     --bsp <- B.loadBSP "fps/maps/chiropteradm.bsp"
-    obj1 <- loadGPipeMesh "Monkey.lcmesh"
-    obj2 <- loadGPipeMesh "Scene.lcmesh"
-    obj3 <- loadGPipeMesh "Plane.lcmesh"
-    obj4 <- loadGPipeMesh "Icosphere.lcmesh"
-
-    let gr b = geometry' b
+    shaders <- loadShaders
+    let gr b = compileBSP (fmap snd shaders) b
         g = gr bsp
     print $ VC.length g
     net <- start $ scene g mousePosition fblrPress buttonPress winSize
     keys <- newIORef $ Map.empty
 
-
     putStrLn "creating window..."
     newWindow "FPS Demo" 
         (100:.100:.()) 
@@ -136,9 +150,7 @@ drawGLScene bsp (w,h) (cam,dir,up,_) time buttonPress = do
         lmat = V.fromProjective (lookat lpos lat lup)
         pmat = U.perspective 0.4 5 90 (fromIntegral w / fromIntegral h)
     --print "render frame"
-    return $ renderBSP (convMat (cm V..*. pm)) bsp
-    --return $ vsm (convMat (cm V..*. pm)) (convMat (cm V..*. pm)) objs
-    --return $ moments (convMat (cm V..*. pmat)) objs
+    return $ renderSurfaces (toGPU time) (convMat (cm V..*. pm)) bsp
 
 -- Key -> KeyState -> Modifiers -> Position -> IO ()
 keyboard keys mousePos key keyState mods (Position x y) = do

gpipeDemo.hs

@@ -43,7 +43,7 @@ main = do
     obj3 <- loadGPipeMesh "Plane.lcmesh"
     obj4 <- loadGPipeMesh "Icosphere.lcmesh"
 
-    net <- start $ scene [obj1,obj2,obj3,obj4] mousePosition fblrPress buttonPress winSize
+    net <- start $ scene (take 4 $ cycle [obj1,obj2,obj3,obj4]) mousePosition fblrPress buttonPress winSize
     keys <- newIORef $ Map.empty