lambdacube-engine-0.2.3: Graphics/LambdaCube/World.hs
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification, Rank2Types, NamedFieldPuns #-}
module Graphics.LambdaCube.World where
import Control.Applicative
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Trans
import System.Directory
import System.FilePath
import Data.List
import Data.IntMap (IntMap)
import Data.Map (Map)
import Data.Maybe
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import Codec.Archive.Zip
import qualified Data.ByteString.Char8 as SB8
import qualified Data.ByteString as SB
import qualified Data.ByteString.Internal as SB
import qualified Data.ByteString.Lazy as LB
import Graphics.LambdaCube.Common
import Graphics.LambdaCube.Compositor
import Graphics.LambdaCube.Entity
import Graphics.LambdaCube.Frustum
import Graphics.LambdaCube.GpuProgram
import Graphics.LambdaCube.GpuProgramUsage
import Graphics.LambdaCube.HardwareBuffer
import Graphics.LambdaCube.HardwareIndexBuffer
import Graphics.LambdaCube.HardwareVertexBuffer
import Graphics.LambdaCube.Image
import Graphics.LambdaCube.Light
import Graphics.LambdaCube.Loader.MeshXML
import Graphics.LambdaCube.Loader.VMesh
import Graphics.LambdaCube.Loader.ResourceScript
import Graphics.LambdaCube.Material
import Graphics.LambdaCube.Mesh
import Graphics.LambdaCube.Pass
import Graphics.LambdaCube.PixelFormat
import Graphics.LambdaCube.RenderQueue
import Graphics.LambdaCube.RenderSystem
import Graphics.LambdaCube.Technique
import Graphics.LambdaCube.Texture
import Graphics.LambdaCube.TextureUnitState
import Graphics.LambdaCube.Tree
import Graphics.LambdaCube.Types
import Graphics.LambdaCube.Utility
import Graphics.LambdaCube.VertexBufferVector
-- * World transformation
newtype LCM w e a = LCM { unLCM :: forall r . (a -> w -> IO r) -> (e -> w -> IO r) -> w -> IO r }
instance Functor (LCM w e) where
fmap = liftM
instance Applicative (LCM w e) where
pure = return
(<*>) = ap
instance Monad (LCM w e) where
return x = LCM (\k t w -> k x w)
LCM lc >>= f = LCM (\k t -> lc (\x -> unLCM (f x) k t) t)
instance MonadIO (LCM w e) where
liftIO m = LCM (\k t w -> m >>= \x -> k x w)
-- | Embed a LambdaCube program in IO. The embedding manages a world,
-- therefore it requires all the information to create one: the render
-- system and a list of image loaders.
runLCM :: (RenderSystem r vb ib q t1 p lp) => r
-> [ImageLoader]
-> LCM (World r vb ib q t1 p lp) e a
-> IO ()
runLCM renderSystem imageLoaders (LCM lc) = do
let nop _ _ = return ()
lc nop nop (mkWorld renderSystem imageLoaders)
-- Run a world transforming IO action in LCM.
inLCM :: (w -> IO w) -> LCM w e ()
inLCM act = LCM (\k t w -> act w >>= k ())
-- Get the current state of the world.
peekLCM :: LCM w e w
peekLCM = LCM (\k t w -> k w w)
-- Set the current state of the world.
pokeLCM :: w -> LCM w e ()
pokeLCM w' = LCM (\k t w -> k () w')
-- Bypass the rest of the computation and throw an out-of-band value.
throwLCM :: e -> LCM w e a
throwLCM x = LCM (\k t w -> t x w)
-- Join the normal and the out-of-band result of a computation: if a
-- value was thrown, return it, otherwise return the result of the
-- computation.
catchLCM :: LCM w a a -> LCM w e a
catchLCM (LCM lc) = LCM (\k t w -> lc k k w)
errorLCM :: String -> String -> LCM w e ()
errorLCM ty msg = liftIO $ putStrLn $ ty ++ msg
debugLCM :: String -> String -> LCM w e ()
debugLCM ty msg = liftIO $ putStrLn $ ty ++ msg
-- * World
data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => FlattenScene vb ib t lp
= FlattenScene
{ fsRenderable :: [(Proj4,[RenderEntity vb ib t lp],Int,Int)] -- ^ List of Renderable information including WorldMatrix RenderQueueID and RenderPriority
, fsCamera :: [(Proj4,Camera)]
, fsLight :: [(Proj4,Light)]
}
data RenderSystem r vb ib q t p lp => World r vb ib q t p lp
= World
{ wrResource :: ResourceLibrary vb ib t p lp -- IO related
, wrRenderSystem :: r -- IO related
, wrScene :: Scene vb ib t lp
, wrTargets :: Map String (RenderTarget t lp)
, wrRenderOptions :: IntMap RenderGroupOptions
, wrImageLoaders :: [ImageLoader]
}
updateWorld :: (w -> w) -> LCM w e ()
updateWorld f = do
world <- peekLCM
pokeLCM $! f world
updateResource :: (RenderSystem r vb ib q t p lp) => (ResourceLibrary vb ib t p lp -> ResourceLibrary vb ib t p lp) -> LCM (World r vb ib q t p lp) e ()
updateResource f = do
world@World { wrResource = res } <- peekLCM
let res' = f res
res' `seq` pokeLCM $ world { wrResource = res' }
{-
mapResource :: (RenderSystem r vb ib q t p lp) => (ResourceLibrary vb ib t p lp -> ResourceLibrary vb ib t p lp) -> World r vb ib q t p lp -> World r vb ib q t p lp
mapResource f w = w { wrResource = f (wrResource w) }
-}
mapScene :: (RenderSystem r vb ib q t p lp) => (Scene vb ib t lp -> Scene vb ib t lp) -> World r vb ib q t p lp -> World r vb ib q t p lp
mapScene f w = w { wrScene = f (wrScene w) }
mapTargets :: (RenderSystem r vb ib q t p lp) => (Map String (RenderTarget t lp) -> Map String (RenderTarget t lp)) -> World r vb ib q t p lp -> World r vb ib q t p lp
mapTargets f w = w { wrTargets = f (wrTargets w) }
mkWorld :: RenderSystem r vb ib q t p lp => r -> [ImageLoader] -> World r vb ib q t p lp
mkWorld rs imgLoaders = World
{ wrResource = mkResource
, wrRenderSystem = rs
, wrScene = mkScene
, wrTargets = Map.empty
, wrRenderOptions = IntMap.empty
, wrImageLoaders = imgLoaders
}
mkResource :: (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, GpuProgram p, LinkedGpuProgram lp) => ResourceLibrary vb ib t p lp
mkResource = ResourceLibrary [] Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty
mkScene :: (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => Scene vb ib t lp
mkScene = Scene
{ scGraph = root "Root" (SceneNode "Root" [] idmtx)
, scSky = Nothing
}
-- * Resource
data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, GpuProgram p, LinkedGpuProgram lp) => ResourceLibrary vb ib t p lp
= ResourceLibrary
{ rlResourceGroups :: [ResourceGroup]
, rlMeshMap :: Map String (Mesh vb ib)
, rlMaterialMap :: Map String (Material t lp)
, rlTextureMap :: Map String t
, rlGpuProgramMap :: Map String (GpuProgramDescriptor p)
, rlLinkedGpuProgramMap :: Map (String,String,String) lp
, rlCompositorMap :: Map String (Compositor t lp)
}
-- * SceneGraph
-- | Camera description.
data Camera
= Camera
{ cmName :: String -- ^ The name of the camera.
, cmFov :: FloatType -- ^ Field of view in radians.
, cmNear :: FloatType -- ^ Near plane clipping distance.
, cmFar :: FloatType -- ^ Far plane clipping distance.
, cmAspectRatio :: Maybe FloatType -- ^ Camera aspect ratio (width/height).
, cmPolygonMode :: PolygonMode -- ^ Rendering type.
}
{-
name CDATA #IMPLIED
id ID #IMPLIED
FOVy CDATA "45"
aspectRatio CDATA "1.3333333"
projectionType (perspective | orthographic) "perspective"
polygonMode (points | wireframe | solid) "solid"
useRenderingDistance (yes | no) "yes"
lodBiasFactor CDATA "1.0"
-}
cameraProjectionMatrix :: FloatType -> Camera -> Mat4
cameraProjectionMatrix a cam = perspective near far fov aspect
where
Camera
{ cmFov = fov
, cmNear = near
, cmFar = far
, cmAspectRatio = aspectr
} = cam
aspect = fromMaybe a aspectr
data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => SceneObject vb ib t lp
= SO_Entity (Entity vb ib t lp)
| SO_Camera Camera
| SO_Light Light
-- | SO_ParticleSystem ParticleSystem
--data RenderTarget
-- = RT_MainBuffer
-- | RT_FrameBuffer
{-
data RenderWindow = RenderWindow
{ rwWidth :: Int
, rwHeight :: Int
, rwViewport :: [Viewport]
--, rtTarget -- texture or screen
}
-}
data (Texture t, LinkedGpuProgram lp) => RenderTarget t lp
= RenderTarget
{ rtName :: String
, rtWidth :: Int
, rtHeight :: Int
, rtViewport :: [Viewport t lp]
, rtTexture :: Maybe String
}
data (Texture t, LinkedGpuProgram lp) => Viewport t lp
= Viewport
{ vpLeft :: FloatType
, vpTop :: FloatType
, vpWidth :: FloatType
, vpHeight :: FloatType
, vpCamera :: String --Camera
, vpCompositors :: [Compositor t lp]
, vpBackColour :: ColourValue
, vpClearEveryFrame :: Bool
, vpClearBuffers :: FrameBufferType
}
getViewportSize :: (Texture t, LinkedGpuProgram lp) => RenderTarget t lp -> Viewport t lp -> (Int,Int,Int,Int)
getViewportSize t v = (x,y,w,h)
where
ww = fromIntegral $ rtWidth t
wh = fromIntegral $ rtHeight t
x = floor $ ww * (vpLeft v)
y = floor $ wh * (vpTop v)
w = floor $ ww * (vpWidth v)
h = floor $ wh * (vpHeight v)
data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => SceneNode vb ib t lp
= SceneNode
{ snName :: String
, snObject :: [SceneObject vb ib t lp]
, snTransform :: Proj4
}-- deriving (Show,Read)
data Sky
= SkyBox --Material
| SkyDome
| SkyPlane
{-
data Scene = Scene
{ scGraph :: Gr () ()
-- , scMap :: Map Int SceneNode
, scMap :: IntMap SceneNode
, scNameMap :: Map String Int
, scSky :: Maybe Sky
-- Fog settings
}
-}
data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => Scene vb ib t lp
= Scene
{ scGraph :: IndexedTree (SceneNode vb ib t lp)
, scSky :: Maybe Sky
-- Fog settings
}
-- | Add a new vector mesh to the world.
addVMesh :: RenderSystem r vb ib q t p lp
=> String -- ^ The name of the mesh in the world.
-> VMesh -- ^ The mesh to add.
-> LCM (World r vb ib q t p lp) e ()
addVMesh name vmesh = do
world <- peekLCM
mesh <- liftIO $ meshFromV (wrRenderSystem world) vmesh
pokeLCM $ addMesh name mesh world
-- | Retrieve a vector mesh from the world by name.
getVMesh :: RenderSystem r vb ib q t p lp => String -> LCM (World r vb ib q t p lp) e VMesh
getVMesh name = do
mesh <- getMesh name
liftIO $ vFromMesh mesh
addMesh :: RenderSystem r vb ib q t p lp => String -> Mesh vb ib -> World r vb ib q t p lp -> World r vb ib q1 t p lp
addMesh name mesh world = world { wrResource = rl { rlMeshMap = Map.insert name mesh (rlMeshMap rl) } }
where
rl = wrResource world
getMesh :: RenderSystem r vb ib q t p lp => String -> LCM (World r vb ib q t p lp) e (Mesh vb ib)
getMesh name = catchLCM $ do
World { wrResource, wrRenderSystem } <- peekLCM
let mm@ ~(Just m) = Map.lookup name (rlMeshMap wrResource)
when (isJust mm) $ throwLCM m
f <- readFile' name
m <- liftIO $ case takeExtension name of
".xml" -> do
putStrLn $ "ResourceLibrary " ++ "parsing mesh XML file " ++ name
parseMesh wrRenderSystem $ SB8.unpack f
".vmesh" -> do
putStrLn $ "ResourceLibrary " ++ "parsing VMesh file " ++ name
meshFromV wrRenderSystem $ decodeVMesh $ LB.fromChunks [f]
_ -> error "Unsupported format!"
{-
f <- loadFile (rlResourceGroups rl) name
when (isNothing f) $ error $ "File not found: " ++ name
case takeExtension name of
".xml" -> do
debugM "ResourceLibrary" $ "parsing mesh XML file " ++ name
parseMesh rs $ map SB.w2c $ LB.unpack $ fromMaybe (error "fromJust 9") f
_ -> error ("Unsupported format!")
-}
updateResource $ \rl -> rl { rlMeshMap = Map.insert name m (rlMeshMap rl) }
return m
--loadMaterialResources :: RenderSystem rs vb ib q t p lp =>
-- rs -> [FilePath -> LB.ByteString -> IO (Maybe Image)] -> ResourceLibrary vb ib t p lp ->
-- Material t lp -> IO (ResourceLibrary vb ib t p lp, Material t lp)
loadMaterialResources :: RenderSystem rs vb ib q t p lp =>
Material t lp -> LCM (World rs vb ib q t p lp) e (Material t lp)
loadMaterialResources mat = catchLCM $ do
when (isJust (mtSupportedTechniques mat)) $ throwLCM mat -- Material is already initialized
-- select and load supported techniques
suppTech <- forM (filter isSupportedTech (mtTechniques mat)) $ \tech -> do
-- load passes (GpuProgram)
passes <- forM (tchPasses tech) $ \pass -> do
lgp <- loadGpuProgram pass
tuss <- forM (psTextureUnitStates pass) loadTextureUnit
return $ pass
{ psTextureUnitStates = tuss
, psLinkedGpuProgram = lgp
}
return (tech { tchPasses = passes })
-- Insert loaded material into MaterialMap
let mat' = mat { mtSupportedTechniques = Just suppTech }
updateResource $ \rl -> rl { rlMaterialMap = Map.insert (mtName mat') mat' (rlMaterialMap rl) }
return mat'
where
isSupportedTech _ = True -- TODO
loadGpuProgram pass = catchLCM $ do
let mlgp = psLinkedGpuProgram pass
when (isJust mlgp) $ throwLCM mlgp
world@World { wrRenderSystem = rs, wrResource = reslib } <- peekLCM
let gpuprogmap = rlGpuProgramMap reslib
progName@(vpn,fpn,gpn) =
(getName (psVertexProgramUsage pass),
getName (psFragmentProgramUsage pass),
getName (psGeometryProgramUsage pass))
where
getName = maybe "" gpuProgramName
-- collect required shaders name list
progNames <- flip fix ([],filter (/="") [vpn,fpn,gpn]) $ \loop (cl,nl) ->
case nl of
[] -> return cl
_ -> do
let fnl = filter (`notElem` cl) nl
nl' <- forM fnl $ \m -> case Map.lookup m gpuprogmap of
Nothing -> do
errorLCM "loadShader" $ "Unknown attached GpuProgram: " ++ m
return []
Just gp -> return (gpdAttach gp)
loop (cl ++ fnl, concat nl')
when (null progNames) $ throwLCM Nothing
-- load all shaders
progs <- fmap catMaybes . forM progNames $ \sn -> catchLCM $ do
reslib <- wrResource <$> peekLCM
let mgpd@ ~(Just gpd) = Map.lookup sn (rlGpuProgramMap reslib)
when (isNothing mgpd) $ do
errorLCM "loadShader" $ "Unknown GpuProgram: " ++ sn
throwLCM Nothing
let mp = gpdGpuProgram gpd
when (isJust mp) $ throwLCM mp
-- GpuProgram is not loaded yet
let fname = gpdFilename gpd
msrc@ ~(Just src) <- liftIO $ loadFile (rlResourceGroups reslib) fname
when (isNothing msrc) $ do
errorLCM "loadShader" $ "GpuProgram source not found: " ++ sn ++ " - " ++ fname
throwLCM Nothing
eprog <- liftIO $ createGpuProgram rs (gpdType gpd) (map SB.w2c (LB.unpack src))
case eprog of
Right err -> do
errorLCM "loadShader" $ "Error compile " ++ sn ++ ": " ++ err
return Nothing
Left prog -> do
debugLCM "loadShader" $ "GpuProgram loaded: " ++ sn
let mprog = Just prog
gpmap = Map.insert sn (gpd { gpdGpuProgram = mprog }) (rlGpuProgramMap reslib)
updateResource $ \rl -> rl { rlGpuProgramMap = gpmap }
return mprog
mlp <- Map.lookup progName . rlLinkedGpuProgramMap . wrResource <$> peekLCM
when (isJust mlp) $ throwLCM mlp
-- create LinkedGpuProgram
elprog <- liftIO $ createLinkedGpuProgram rs progs
case elprog of
Right err -> do
errorLCM "loadGpuProgram" $ "Error link " ++ show progName ++ ": " ++ err
return Nothing
Left lprog -> do
debugLCM "loadGpuProgram" $ "GpuProgram linked: " ++ show progName
lgpmap <- rlLinkedGpuProgramMap . wrResource <$> peekLCM
updateResource $ \rl -> rl { rlLinkedGpuProgramMap = Map.insert progName lprog lgpmap }
return (Just lprog)
loadImage name = do
World { wrResource, wrImageLoaders } <- peekLCM
d <- liftIO $ loadFile (rlResourceGroups wrResource) name
case d of
Just imgdata -> liftIO $ foldM' loadImg Nothing wrImageLoaders
where
loadImg Nothing loader = loader name imgdata
loadImg img _ = return img
Nothing -> do
debugLCM "Load image" $ "File not found: " ++ name
return Nothing
loadTextureUnit t = do
World { wrRenderSystem } <- peekLCM
let loadTexture texname = catchLCM $ do
reslib <- wrResource <$> peekLCM
let mt = Map.lookup texname (rlTextureMap reslib)
when (isJust mt) $ throwLCM mt -- texture is loaded
-- we have to create the texture
-- TODO: create and load texture via render system
{-
virtual TexturePtr createManual(const String & name, const String& group,
TextureType texType, uint width, uint height, uint depth,
int num_mips, PixelFormat format, int usage = TU_DEFAULT, ManualResourceLoader* loader = 0,
bool hwGammaCorrection = false, uint fsaa = 0, const String& fsaaHint = StringUtil::BLANK);
{ imName :: String
, imHeight :: Int
, imWidth :: Int
, imDepth :: Int
, imSize :: Int
, imNumMipmaps :: Int
-- uint flags;
, imFormat :: PixelFormat
, imData :: (Ptr Word8) -- ^ Image can be empty
}
mkGLTexture :: String -> TextureType -> Int -> Int -> Int -> Int -> PixelFormat -> TextureUsage -> Bool -> Int -> String -> IO GLTexture
mkGLTexture name texType width height depth numMips format usage hwGammaCorrection fsaa fsaaHint = do
--createTexture :: a -> String -> TextureType -> Int -> Int -> Int -> Int -> PixelFormat -> TextueUsage -> Bool -> Int -> String -> IO t
-}
mi@ ~(Just img) <- loadImage texname
when (isNothing mi) $ do
debugLCM "Load texture" $ "No proper image codec was found: " ++ texname
throwLCM Nothing
let usage = TextureUsage HBU_STATIC True False
t <- liftIO $ createTexture wrRenderSystem texname (tusTextureType t)
(imWidth img) (imHeight img) (imDepth img)
(tusTextureSrcMipmaps t) (tusDesiredFormat t) usage (tusHwGamma t) 0 "" (Just [img])
-- TODO
--let t = undefined
let texmap = rlTextureMap reslib
updateResource $ \rl -> rl { rlTextureMap = Map.insert texname t texmap }
return (Just t)
loadCubicTexture texname = catchLCM $ do
texmap <- rlTextureMap . wrResource <$> peekLCM
let mt = Map.lookup (concat texname) texmap
when (isJust mt) $ throwLCM mt -- texture is loaded
-- we have to create the texture
-- TODO: create and load texture via render system
i <- forM texname loadImage
unless (all isJust i) $ do
debugLCM "Load texture" $ "No proper image codec was found: " ++ concat texname
throwLCM Nothing
let usage = TextureUsage HBU_STATIC True False
Just img : _ = i
t <- liftIO $ createTexture wrRenderSystem (concat texname) (tusTextureType t)
(imWidth img) (imHeight img) (imDepth img)
(tusTextureSrcMipmaps t) (tusDesiredFormat t) usage (tusHwGamma t) 0 "" (Just (map fromJust i))
updateResource $ \rl -> rl { rlTextureMap = Map.insert (concat texname) t texmap }
return (Just t)
-- load textures
-- TODO: load all frames
frames <- case tusTextureType t of
TEX_TYPE_CUBE_MAP -> maybeToList <$> loadCubicTexture (tusFrameNames t)
_ -> catMaybes <$> forM (tusFrameNames t) loadTexture
return $ t { tusFrames = Just frames }
--NOTE: this should return with Nothing if there's no supported technique
--getLoadedMaterial :: (RenderSystem rs vb ib q t p lp) => String -> World rs vb ib q t p lp -> IO (World rs vb ib q t p lp, Maybe (Material t lp))
getLoadedMaterial :: RenderSystem r vb ib q t p lp => String -> LCM (World r vb ib q t p lp) e (Maybe (Material t lp))
getLoadedMaterial matname = do
matmap <- rlMaterialMap . wrResource <$> peekLCM
case Map.lookup matname matmap of
Nothing -> do
errorLCM "loadMaterial" $ "Material not found: " ++ matname
return Nothing
Just m -> case mtSupportedTechniques m of
Just _ -> return (Just m)
--TODO: this should return with Nothing if there's no supported technique
Nothing -> Just <$> loadMaterialResources m
setEntityMaterial :: RenderSystem r vb ib q t p lp => [String] -> Entity vb ib t lp -> LCM (World r vb ib q t p lp) e (Entity vb ib t lp)
setEntityMaterial mats ent = do
subents <- forM (zip (enSubEntityList ent) mats) $ \(sent,matname) -> do
matmap <- rlMaterialMap . wrResource <$> peekLCM
mat <- case Map.lookup matname matmap of
Just m -> loadMaterialResources m
Nothing -> error $ "Material not found: " ++ matname
return (sent { seMaterial = mat })
return (ent { enSubEntityList = subents })
createEntity :: (RenderSystem r vb ib q t p lp, Enum rqp) => String -> String -> rqp -> LCM (World r vb ib q t p lp) e (Entity vb ib t lp)
createEntity ename mname renderQueueID = do
-- lookup mesh, load if not exists
--debugM "ResourceLibrary" $ "creating entity: \"" ++ ename ++ "\" from mesh: \"" ++ mname ++ "\""
mesh <- getMesh mname
--debugM "ResourceLibrary" " done"
subents <- forM (msSubMeshList mesh) $ \smesh -> do
matmap <- rlMaterialMap . wrResource <$> peekLCM
let matname = smMaterialName smesh
mat <- case Map.lookup matname matmap of
Just m -> loadMaterialResources m
Nothing -> error $ "Material not found: " ++ matname
--debugM "createEntity" $ "Material not found: " ++ matname
-- TODO
--loadMaterialResources (matmap ! "WarningMaterial")
return (SubEntity { seMaterial = mat, seSubMesh = smesh })
return $ Entity
{ enName = ename
, enRenderQueue = fromEnum renderQueueID
, enMesh = mesh
, enSubEntityList = subents
}
-- | Get the raw data for a resource in a lazy bytestring given its
-- path. The data is cached, so this does not necessarily require
-- disk I/O.
readFile :: RenderSystem r vb ib q t p lp => FilePath -> LCM (World r vb ib q t p lp) e LB.ByteString
readFile fname = do
world <- peekLCM
f <- liftIO $ loadFile (rlResourceGroups (wrResource world)) fname
case f of
Nothing -> throwLCM $ error $ "File not found: " ++ fname
Just d -> return d
-- | Get the raw data for a resource in a strict bytestring given its
-- path. The data is cached, so this does not necessarily require
-- disk I/O.
readFile' :: RenderSystem r vb ib q t p lp => FilePath -> LCM (World r vb ib q t p lp) e SB.ByteString
readFile' fname = SB.concat <$> LB.toChunks <$> Graphics.LambdaCube.World.readFile fname
loadFile :: [ResourceGroup] -> FilePath -> IO (Maybe LB.ByteString)
loadFile respath fname = foldM' (\s (_,l) -> foldM' load s l) Nothing respath
where
load s@(Just str) _ = return s
load s (PathZip,n) = do
-- TODO: this is a naive implementation with poor perfomance
f <- LB.readFile n
let a = toArchive f
return $ fmap fromEntry $ findEntryByPath fname a
load Nothing (PathDir,n) = do
let ffname = (addTrailingPathSeparator n) ++ fname
e <- doesFileExist ffname
ret <- if e then LB.readFile ffname else return LB.empty
return $ if e then Just ret else Nothing
renderFlatScene :: RenderSystem r vb ib q t p lp => FloatType -> String -> FlattenScene vb ib t lp -> LCM (World r vb ib q t p lp) e ()
renderFlatScene time name flatScene = do
World { wrTargets, wrRenderSystem = rs, wrRenderOptions, wrResource } <- peekLCM
let renderTarget rt = do
-- TODO: calc render statistics
let t = rtTexture rt
-- call setRenderTarget rs
mapM_ (renderViewport flatScene rt) $ rtViewport rt
--if isNothing t then return () else do
--let tex = txObject $ (rlTextureMap $ wrResource world) ! (fromMaybe (error "fromJust 0") t)
--GL.textureBinding GL.Texture2D $= Just tex
-- only hint code: glCopyTexImage2D(GL_TEXTURE_2D, 0, GL_LUMINANCE, 0, 0, 128, 128, 0);
--GL.copyTexImage2D Nothing 0 GL.RGBA' (GL.Position 0 0) (GL.TextureSize2D w' h') 0
--return ()
renderViewport fs rtarget v = do
let (vx,vy,vw,vh) = getViewportSize rtarget v
(camMat,cam) = head $ Prelude.filter (\(_,a) -> camName == (cmName a)) $ fsCamera fs
camName = vpCamera v
cameraViewMatrix = inverse camMat
projectionMatrix = cameraProjectionMatrix (fromIntegral vw / fromIntegral vh) cam
camFrustum = frustumFromMatrix $ (fromProjective cameraViewMatrix) .*. projectionMatrix
setViewport rs vx vy vw vh
-- Clear the viewport if required
when (vpClearEveryFrame v) $
clearFrameBuffer rs (vpClearBuffers v) (vpBackColour v) 1 0
-- Begin the frame
--mDestRenderSystem->_beginFrame();
-- Set rasterisation mode
setPolygonMode rs $ cmPolygonMode cam
-- Set initial camera state
setProjectionMatrix rs projectionMatrix
--mDestRenderSystem->_setTextureProjectionRelativeTo(mCameraRelativeRendering, camera->getDerivedPosition());
--setTextureProjectionRelativeTo
setViewMatrix rs cameraViewMatrix
-- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-- TODO: activate compositor chain render target if necessary
-- (re)initialize compositor resources if necessary
-- foreach compositor
-- select technique
-- create render textures
-- initialize target passes
-- do render
-- foreach compositor and target pass
-- bind target pass
-- execute each composition pass in target pass
--HINT:
--
-- FIXME: TEMP CODE
unless (null $ vpCompositors v) $ do
-- bind render texture
return ()
--TODO: cull scene
-- sphereInFrustum p r fr
--fsRenderable :: [(Mat44FT,[RenderEntity vb ib t lp],Int,Int)]
let culledScene = cull (fsRenderable fs)
where
cull rs = [(reMat,rel',rqid,rprio) | (reMat,rel,rqid,rprio) <- rs,
let p = trim (_4 (fromProjective reMat))
r re = norm $ (Vec3 (reBoundRadius re) 0 0) .* (trim (fromProjective reMat) :: Mat3)
rel' = [re | re <- rel, sphereInFrustum p (r re) camFrustum],
not (null rel')]
--putStrLn $ "full: " ++ (show $ length (fsRenderable fs)) ++ " culled: " ++ (show $ length culledScene)
-- render objects
rstat <- renderQueue time rs wrRenderOptions emptyRenderStatistics (fsLight fs) culledScene
-- print rstat
-- Compositor
-- TargetPass
-- Pass
forM_ (vpCompositors v) $ \c -> do
let ct = head $ fromMaybe (error "fromJust 112") $ cmpSupportedTechniques c
-- select first technique
forM (ctTargetPasses ct ++ [ctOutputTarget ct]) $ \ctp -> do
-- -- copy previous output to target's output when input is previous
when (ctpInputMode ctp == IM_PREVIOUS) $ do
-- FIXME
dirtyHackCopyTexImage rs (fromMaybe (error "fromJust 212") $ tdTexture $ fromJust $ ctpOutput ctp) vx vy vw vh
forM (ctpPasses ctp) $ \cp -> do
-- do composition pass action
case cpType cp of
PT_RENDERQUAD -> do
-- TODO
-- setup quad material
-- render quad
let quadM = fromMaybe (error "fromJust 312") $ Map.lookup "Quad.mesh.xml" (rlMeshMap wrResource)
quadSM = head $ msSubMeshList quadM
quadSE = SubEntity { seMaterial = fromMaybe (error "fromJust 412") $ cpMaterial cp, seSubMesh = quadSM }
quadE = Entity "" (fromEnum RQP_Main) quadM [quadSE]
quadRE = head $ prepare idmtx quadE
quadRP = [RenderablePass (reOperation quadRE) p idmtx [(idmtx,defaultLight)] | p <- rePassList quadRE]
defaultLight = Light
{ lgType = LT_POINT
, lgDiffuse = (1,1,1,1)
, lgDirection = Vec3 0 0 1
, lgSpecular = (0,0,0,0)
, lgSpotOuter = pi / 180 * 40
, lgSpotFalloff = 1
, lgRange = 100000
, lgAttenuationConst = 1
, lgAttenuationLinear = 0
, lgAttenuationQuad = 0
}
setProjectionMatrix rs idmtx
setViewMatrix rs idmtx
setWorldMatrix rs idmtx
setPolygonMode rs PM_SOLID
renderPassGroup time rs emptyRenderStatistics quadRP
return ()
_ -> return ()
{-
unless (null $ vpCompositors v) $ do
-- FIXME: TEMP CODE
-- unbind render texture, and we'll have the rendered scene in a texture
-- create a custom temp pass with temp render texture input
-- create quad render operation
let quadSM = head $ msSubMeshList $ fromJust $ Map.lookup "Quad.mesh.xml" (rlMeshMap $ wrResource world)
quadRO = RenderOperation
{ roVertexData = fromJust $ smVertexData quadSM
, roOperationType = smOperationType quadSM
, roIndexData = smIndexData quadSM
}
quadP = head $ tchPasses $ head $ fromJust $ mtSupportedTechniques $ fromJust $ Map.lookup "QuadMaterial" (rlMaterialMap $ wrResource world)
quadRP = RenderablePass
{ rpOperation = quadRO
, rpPass = quadP'
, rpMatrix = transl 0 0 0
, rpLights = []
}
rtex = fromJust $ Map.lookup "RenderTex01" $ (rlTextureMap $ wrResource world)
tus = psTextureUnitStates quadP
tu = head tus
tut = tail tus
tu' = tu { tusFrames = Just [rtex] }
quadP' = quadP { psTextureUnitStates = (tu':tut) }
--setProjectionMatrix rs $ cameraProjectionMatrix (fromIntegral vw / fromIntegral vh) cam
setProjectionMatrix rs $ transl 0 0 0
setViewMatrix rs $ transl 0 0 0
dirtyHackCopyTexImage rs rtex vx vy vw vh
setPolygonMode rs PM_SOLID
renderPassGroup rs [quadRP]
-- invert back
--dirtyHackCopyTexImage rs rtex vx vy vw vh
-} --renderPassGroup rs [quadRP]
-- TODO
-- collect all render textures
-- render the world on all render textures
-- render the world last to the given named target
-- forall viewports:
-- setup viewport related matrices
-- render scene
case Map.lookup name wrTargets of
Nothing -> debugLCM "renderWold" $ "RenderTarget not found: " ++ name
Just t -> do
let targets = Map.elems wrTargets
(tg,tgs) = partition ((== name) . rtName) targets
(rtl,rwl) = partition (isNothing . rtTexture) tgs
liftIO $ prepareRender rs >> mapM_ renderTarget (rtl ++ rwl ++ tg) >> finishRender rs
{-
= RenderOperation
{ roVertexData :: VertexData vb -- ^ Vertex source data
, roOperationType :: OperationType -- ^ The type of operation to perform
, roIndexData :: Maybe (IndexData ib) -- ^ Index data - only valid if useIndexes is true
}
= RenderablePass
{ rpOperation :: RenderOperation vb ib
, rpPass :: Pass t lp
, rpMatrix :: Matrix4
, rpLights :: [(Matrix4,Light)]
}
--renderPassGroup :: RenderSystem -> RenderablePass -> IO ()
-}
-- do a manual render for temp pass (we should reset world, view, projection and texture matrix)
---------------------------------------------------------------------
-- push flatten scene into a render queue
-- collect lights which affect each renderable
-- fold addRenderable
-- call renderQueue
--let addRend (m,rend,grpID,prior) rq = addRenderable m rend (map snd $ fsLight fs) grpID prior rq
--renderQueue' rs $ foldr addRend emptyRenderQueue $ fsRenderable fs
-- old code below-------------------------------------------------------------------------------------------
--mapM_ (renderEntity (wrRenderSystem world)) $ optimize $ foldr (\(m,r) l -> (prepare m r) ++ l) [] [(a,b) | (a,b,_,_) <- fsRenderable fs]
-- | Create a new texture.
addRenderTexture :: RenderSystem r vb ib q a p lp
=> String -- ^ The name of the texture.
-> Int -- ^ Width in texels.
-> Int -- ^ Height in texels.
-> LCM (World r vb ib q a p lp) e ()
addRenderTexture n w h = do
World { wrRenderSystem, wrResource } <- peekLCM
let tm = rlTextureMap wrResource
t <- liftIO $ createTexture wrRenderSystem n TEX_TYPE_2D w h 1 (MIP_NUMBER 1) PF_R8G8B8A8 (TextureUsage HBU_STATIC True False) False 0 "" Nothing
updateResource $ \rl -> rl { rlTextureMap = Map.insert n t tm }
-- | Specify the viewports to display in the window.
addRenderWindow :: RenderSystem r vb ib q t p lp
=> String -- ^ The name of the window.
-> Int -- ^ The width of the window in pixels.
-> Int -- ^ The height of the window in pixels.
-> [LCM (World r vb ib q t p lp) e (Viewport t lp)] -- ^ The actions describing the viewports to use.
-> LCM (World r vb ib q t p lp) e ()
addRenderWindow n w h l = do
vl <- sequence l
let rt = RenderTarget
{ rtName = n
, rtWidth = w
, rtHeight = h
, rtViewport = vl
, rtTexture = Nothing
}
updateWorld (mapTargets (Map.insert n rt))
{-
= Compositor
{ cmpName :: String
, cmpTechniques :: [CompositionTechnique t]
, cmpSupportedTechniques :: Maybe [CompositionTechnique t]
}
= CompositionTechnique
{ ctTextureDefinitions :: [TextureDefinition t]
, ctTargetPasses :: [CompositionTargetPass] -- ^ Intermediate target passes
, ctOutputTarget :: CompositionTargetPass -- ^ Output target pass (can be only one)
, ctSchemeName :: String -- ^ Optional scheme name
}
= TextureDefinition
{ tdName :: String
, tdWidth :: Maybe Int -- Nothing means adapt to target width
, tdHeight :: Maybe Int -- Nothing means adapt to target height
, tdWidthFactor :: FloatType -- multiple of target width to use (if width = Nothing)
, tdHeightFactor :: FloatType -- multiple of target height to use (if height = Nothing)
, tdFormatList :: [PixelFormat] -- more than one means MRT
, tdFsaa :: Bool -- FSAA enabled; true = determine from main target (if render_scene), false = disable
, tdHwGammaWrite :: Bool -- Do sRGB gamma correction on write (only 8-bit per channel formats)
, tdShared :: Bool -- whether to use shared textures for this one
, tdTexture :: Maybe t
}
= CompositionTargetPass
{ ctpInputMode :: InputMode -- ^ Input name
, ctpOutputName :: String -- ^ (local) output texture
, ctpOutput :: Maybe (TextureDefinition t)
, ctpPasses :: [CompositionPass] -- ^ Passes
, ctpOnlyInitial :: Bool -- ^ This target pass is only executed initially after the effect has been enabled.
, ctpVisibilityMask :: Word32 -- ^ Visibility mask for this render
, ctpLodBias :: FloatType -- ^ LOD bias of this render
, ctpMaterialScheme :: String -- ^ Material scheme name
, ctpShadowsEnabled :: Bool -- ^ Shadows option
}
= InputTex
{ itName :: String -- ^ Name (local) of the input texture
, itMrtIndex :: Int -- ^ MRT surface index if applicable
}
= CompositionPass
{ cpType :: PassType -- ^ Type of composition pass
, cpIdentifier :: Word32 -- ^ Identifier for this pass
, cpMaterialName :: String -- ^ Material used for rendering
, cpMaterial :: Maybe (Material t lp)
, cpFirstRenderQueue :: Int -- ^ [first,last] render queue to render this pass (in case of PT_RENDERSCENE)
, cpLastRenderQueue :: Int
, cpClearBuffers :: (Bool,Bool,Bool) -- ^ Clear buffers (in case of PT_CLEAR), hint: [colour] [depth] [stencil]
, cpClearColour :: ColourValue -- ^ Clear colour (in case of PT_CLEAR)
, cpClearDepth :: FloatType -- ^ Clear depth (in case of PT_CLEAR)
, cpClearStencil :: Word32 -- ^ Clear stencil value (in case of PT_CLEAR)
, cpInputs :: IntMap InputTex -- ^ Inputs (for material used for rendering the quad)
, cpStencilCheck :: Bool -- ^ Stencil operation parameters
, cpStencilFunc :: CompareFunction
, cpStencilRefValue :: Word32
, cpStencilMask :: Word32
, cpStencilFailOp :: StencilOperation
, cpStencilDepthFailOp :: StencilOperation
, cpStencilPassOp :: StencilOperation
, cpStencilTwoSidedOperation :: Bool
, cpQuadCornerModified :: Bool -- ^ true if quad should not cover whole screen
, cpQuadLeft :: FloatType -- ^ quad positions in normalised coordinates [-1;1]x[-1;1] (in case of PT_RENDERQUAD)
, cpQuadTop :: FloatType
, cpQuadRight :: FloatType
, cpQuadBottom :: FloatType
, cpQuadFarCorners :: Bool
, cpQuadFarCornersViewSpace :: Bool
}
data PassType
= PT_CLEAR -- ^ Clear target to one colour
| PT_STENCIL -- ^ Set stencil operation
| PT_RENDERSCENE -- ^ Render the scene or part of it
| PT_RENDERQUAD -- ^ Render a full screen quad
-}
-- | Create render textures, and setup compositor chain.
mkCompositorChain :: RenderSystem r vb ib q t p lp => [Compositor t lp] -> LCM (World r vb ib q t p lp) e [Compositor t lp]
mkCompositorChain cl = do
rs <- wrRenderSystem <$> peekLCM
-- do we really need this ???? -- HINT: add an implicit target to first compositor which renders the scene into a viewportsized texture,
-- iterate trough compositors and select first supported technique
let initCompositor c = catchLCM $ do -- :: (World,[Maybe Compositor]) -> Compositor -> (World,[Maybe Compositor])
-- TODO: select first supported technique
let ct = head $ cmpTechniques c
tds <- forM (ctTextureDefinitions ct) $ \td -> do
-- create render textures
let w = fromMaybe 1 $ tdWidth td
h = fromMaybe 1 $ tdHeight td
txn = (cmpName c ++ "/" ++ tdName td)
t <- liftIO $ createTexture rs txn TEX_TYPE_2D w h 1 (MIP_NUMBER 1) (head $ tdFormatList td) (TextureUsage HBU_STATIC True False) False 0 "" Nothing
debugLCM "Initialize Compositor" $ "Created compositor texture: " ++ txn
return td { tdTexture = Just t }
let texmap = Map.fromList [(tdName td,td) | td <- tds]
onamel = map ctpOutputName $ ctTargetPasses ct
outtexl = [Map.lookup o texmap | o <- onamel]
checkTex tn = unless (Map.member tn texmap) $ do
errorLCM "Initialize Compositor" $ "Unknown compositor texture: " ++ tn
throwLCM Nothing
forM_ onamel checkTex
-- setup compositor target pass output
let initPasses tp = do
pl <- forM (ctpPasses tp) $ \cp -> case cpType cp of
PT_RENDERQUAD -> do
-- setup composition pass input
-- load material
mmat@ ~(Just mat) <- getLoadedMaterial (cpMaterialName cp)
when (isNothing mmat) $ throwLCM Nothing
-- check pass input texture names
forM_ [itName it | it <- IntMap.elems $ cpInputs cp] checkTex
-- foreach material pass and for each textureunitstate
-- setup texture when it's a RT
let fp p = p { psTextureUnitStates = tul' }
where
tul' = [tu { tusFrames = fromMaybe (tusFrames tu) (ft i) } | (i,tu) <- tusl]
ft i = case IntMap.lookup i (cpInputs cp) of
Nothing -> Nothing
Just it -> Just $ Just [fromJust $ tdTexture $ texmap Map.! (itName it)]
tusl = zip [0..] $ psTextureUnitStates p
mat' = mat { mtSupportedTechniques = Just [tch { tchPasses = [fp p | p <- tchPasses tch] } | tch <- fromJust $ mtSupportedTechniques mat] }
--return with modified pass attached to the list
return (cp { cpMaterial = Just mat' })
_ -> return cp
return (tp { ctpPasses = pl })
tps <- forM [tp { ctpOutput = o } | (o,tp) <- zip outtexl (ctTargetPasses ct)] initPasses
otp <- initPasses (ctOutputTarget ct)
let ct' = ct { ctTextureDefinitions = tds, ctTargetPasses = tps, ctOutputTarget = otp }
return (Just c { cmpSupportedTechniques = Just [ct'] })
-- setup compositor target pass input
-- TODO: setup compositor chain connection
catMaybes <$> forM cl initCompositor
-- | Create a viewport and attach given compositors.
viewport :: RenderSystem r vb ib q t p lp
=> FloatType -- ^ Viewport x position.
-> FloatType -- ^ Viewport y position.
-> FloatType -- ^ Viewport width.
-> FloatType -- ^ Viewport height.
-> String -- ^ The camera associated with the viewport.
-> [String] -- ^ The compositor chain to process the image with.
-> LCM (World r vb ib q t p lp) e (Viewport t lp)
viewport x y w h cam cnl = do
compMap <- rlCompositorMap . wrResource <$> peekLCM
-- collect compositors
let getCompositor l cn = case Map.lookup cn compMap of
Nothing -> do
errorLCM "ApplyCompositor" $ "Unknown compositor: " ++ cn
return l
Just c -> return $ c:l
-- setup compositor chain
cl0 <- foldM' getCompositor [] cnl
cl1 <- mkCompositorChain (reverse cl0)
return Viewport
{ vpLeft = x
, vpTop = y
, vpWidth = w
, vpHeight = h
, vpCamera = cam
, vpCompositors = cl1
, vpBackColour = (0,0,0,0)
, vpClearEveryFrame = True
, vpClearBuffers = FrameBufferType True True False
}
-- | Adjust the dimensions of a given render target.
updateTargetSize :: RenderSystem rs vb ib q t p lp
=> String -- ^ The target to adjust.
-> Int -- ^ The new width.
-> Int -- ^ The new height.
-> LCM (World rs vb ib q t p lp) e ()
updateTargetSize n w h = updateWorld (mapTargets (Map.adjust f n))
where
f t = t { rtWidth = w, rtHeight = h }