lambdacube-engine-0.1.1: Graphics/LambdaCube/World.hs
{-# LANGUAGE MultiParamTypeClasses #-}
module Graphics.LambdaCube.World where
import Data.Maybe
import qualified Data.List as List
import Data.Map (Map,(!))
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Control.Applicative
import Control.Monad
import System.Directory
import System.FilePath
import System.Log.Logger
import Data.Graph.Inductive
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString as SB
import qualified Data.ByteString.Internal as SB
import Codec.Archive.Zip
import Graphics.LambdaCube.Common
import Graphics.LambdaCube.Loader.ResourceScript
import Graphics.LambdaCube.Loader.MeshXML
import Graphics.LambdaCube.Compositor
import Graphics.LambdaCube.Material
import Graphics.LambdaCube.Pass
import Graphics.LambdaCube.Technique
import Graphics.LambdaCube.TextureUnitState
import Graphics.LambdaCube.PixelFormat
import Graphics.LambdaCube.Math
import Graphics.LambdaCube.Light
import Graphics.LambdaCube.Image
import Graphics.LambdaCube.Entity
import Graphics.LambdaCube.Mesh
import Graphics.LambdaCube.Types
import Graphics.LambdaCube.Texture
import Graphics.LambdaCube.GpuProgram
import Graphics.LambdaCube.GpuProgramUsage
import Graphics.LambdaCube.RenderQueue
import Graphics.LambdaCube.RenderSystem
import Graphics.LambdaCube.HardwareBuffer
import Graphics.LambdaCube.HardwareVertexBuffer
import Graphics.LambdaCube.HardwareIndexBuffer
--import Graphics.LambdaCube.Resource
import Graphics.LambdaCube.RenderOperation
-- * World
data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => FlattenScene vb ib t lp
= FlattenScene
{ fsRenderable :: [(Matrix4,[RenderEntity vb ib t lp],Int,Int)] -- ^ List of Renderable information including WorldMatrix RenderQueueID and RenderPriority
, fsCamera :: [(Matrix4,Camera)]
, fsLight :: [(Matrix4,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]
}
mapResource f w = w { wrResource = f (wrResource w) }
mapScene f w = w { wrScene = f (wrScene w) }
mapTargets f w = w { wrTargets = f (wrTargets w) }
mkWorld :: RenderSystem r vb ib q t p lp => r -> [ImageLoader] -> IO (World r vb ib q t p lp)
mkWorld rs imgLoaders = return 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 (mkUGraph [0] []) (IntMap.fromList [(0, SceneNode "Root" [] (transl 0 0 0))]) (Map.fromList [("Root",0)]) Nothing
-- TODO: update for new scene structure
mkScene = Scene
{ scGraph = mkGraph [(0,"Root")] []
-- use: bytestring-trie (efficient ByteString map)
, scMap = Map.fromList [("Root", (0,SceneNode "Root" [] (transl 0 0 0)))]
, 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
data Camera
= Camera
{ cmName :: String
, cmFov :: FloatType
, cmNear :: FloatType
, cmFar :: FloatType
, cmAspectRatio :: Maybe FloatType
, 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 -> Matrix4
cameraProjectionMatrix a cam = perpectiveMatrix fov aspect near far
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 :: RenderTarget -> Viewport -> (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 :: Matrix4
}-- 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 :: Gr String ()
-- use: bytestring-trie (efficient ByteString map)
, scMap :: Map String (Int,SceneNode vb ib t lp) -- ^ Contains GraphNodeID and SceneNode.
, scSky :: Maybe Sky
-- Fog settings
}
getMesh name world = case Map.lookup name (rlMeshMap rl) of
Nothing -> do
f <- loadFile (rlResourceGroups rl) name
when (isNothing f) $ error $ "File not found: " ++ name
m <- case takeExtension name of
".xml" -> do
debugM "ResourceLibrary" $ "parsing mesh XML file " ++ name
parseMesh rs $ map SB.w2c $ B.unpack $ fromMaybe (error "fromJust 9") f
_ -> error ("Unsupported format!")
return (m,world { wrResource = rl { rlMeshMap = Map.insert name m (rlMeshMap rl) } })
Just m -> return (m,world)
where
rl = wrResource world
rs = wrRenderSystem world
--loadMaterialResources :: ResourceLibrary -> Material -> IO (ResourceLibrary,Material)
loadMaterialResources rs loaders reslib0 mat = case isJust $ mtSupportedTechniques mat of
{ True -> return (reslib0,mat) -- Material is already initialized
; False -> do
let isSupportedTech _ = True -- TODO
loadImage name = do
d <- loadFile (rlResourceGroups reslib0) name
case d of
{ Just imgdata -> do
let loadImg img loader = case img of
{ Just _ -> return img
; Nothing -> loader name imgdata
}
foldM loadImg Nothing loaders
; Nothing -> do
debugM "Load image" $ "File not found: " ++ name
return Nothing
}
loadTextureUnit (rl0,tl) t = do
let loadTexture (rl0',tl') texname = case Map.lookup texname $ rlTextureMap rl0' of
{ Just t -> return (rl0',t:tl') -- texture is loaded
; Nothing -> do -- we have to create it
-- TODO: create and load texture via render system
i <- loadImage texname
case i of
{ Just img -> do
{-
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
let usage = TextureUsage HBU_STATIC True False
t <- createTexture rs 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 rl0'
return (rl0' { rlTextureMap = Map.insert texname t texmap },t:tl')
; Nothing -> do
debugM "Load texture" $ "No proper image codec was found: " ++ texname
return (rl0',tl')
}
}
let loadCubicTexture rl0' texname = case Map.lookup (concat texname) $ rlTextureMap rl0' of
{ Just t -> return (rl0',[t]) -- texture is loaded
; Nothing -> do -- we have to create it
-- TODO: create and load texture via render system
i <- mapM loadImage texname
case all isJust i of
{ True -> do
let usage = TextureUsage HBU_STATIC True False
img = fromJust $ head i
t <- createTexture rs (concat texname) (tusTextureType t) (imWidth img) (imHeight img) (imDepth img)
(tusTextureSrcMipmaps t) (tusDesiredFormat t) usage (tusHwGamma t) 0 "" $ Just $ map fromJust i
let texmap = rlTextureMap rl0'
return (rl0' { rlTextureMap = Map.insert (concat texname) t texmap },[t])
; False -> do
debugM "Load texture" $ "No proper image codec was found: " ++ concat texname
return (rl0',[])
}
}
-- load textures
-- TODO: load all frames
(rl1,tex) <- case tusTextureType t of
{ TEX_TYPE_CUBE_MAP -> loadCubicTexture rl0 $ tusFrameNames t
; _ -> foldM loadTexture (rl0,[]) $ tusFrameNames t
}
let frames = reverse tex -- TODO: wrong in cubemap case
return (rl1,(t { tusFrames = Just frames }):tl)
loadShader (rl0,sl) sn = case Map.lookup sn $ rlGpuProgramMap rl0 of
{ Nothing -> do
errorM "loadShader" $ "Unknown GpuProgram: " ++ sn
return (rl0,sl)
; Just gpd -> case gpdGpuProgram gpd of
{ Just p -> return (rl0,p:sl)
; Nothing -> do
-- GpuProgram is not loaded yet
let fname = gpdFilename gpd
msource <- loadFile (rlResourceGroups rl0) fname
case msource of
{ Nothing -> do
errorM "loadShader" $ "GpuProgram source not found: " ++ sn ++ " - " ++ fname
return (rl0,sl)
; Just src -> do
eprog <- createGpuProgram rs (gpdType gpd) $ map SB.w2c $ B.unpack src
case eprog of
{ Right err -> do
errorM "loadShader" $ "Error compile " ++ sn ++ ": " ++ err
return (rl0,sl)
; Left prog -> do
debugM "loadShader" $ "GpuProgram loaded: " ++ sn
let gpd' = gpd { gpdGpuProgram = Just prog }
gpmap = Map.insert sn gpd' $ rlGpuProgramMap rl0
return (rl0 { rlGpuProgramMap = gpmap }, prog:sl)
}
}
}
}
loadPass (rl0,pl) p = do
-- load GpuPrograms
(rl1,mlgp) <- case psLinkedGpuProgram p of
{ Just lgp -> return (rl0,Just lgp)
; Nothing -> do
let getName Nothing = ""
getName (Just u) = gpuProgramName u
progName = (getName $ psVertexProgramUsage p, getName $ psFragmentProgramUsage p, getName $ psGeometryProgramUsage p)
(vpn,fpn,gpn) = progName
gpuprogmap = rlGpuProgramMap rl0
collectNames cl [] = return cl
collectNames cl nl = do
-- check list nl
let a = filter (`notElem` cl) nl
getAttach m = case Map.lookup m gpuprogmap of
{ Nothing -> do
errorM "loadShader" $ "Unknown attached GpuProgram: " ++ m
return []
; Just gp -> return $ gpdAttach gp
}
b <- mapM getAttach a
collectNames (cl ++ a) $ concat b
-- collect required shaders name list
progNames <- collectNames [] $ filter (/="") [vpn,fpn,gpn]
case null progNames of
{ True -> return (rl0,Nothing)
; False -> do
-- load all shader
(rl1,progs) <- foldM loadShader (rl0,[]) progNames
case Map.lookup progName $ rlLinkedGpuProgramMap rl1 of
{ Just lp -> return (rl1,Just lp)
; Nothing -> do
-- create LinkedGpuProgram
elprog <- createLinkedGpuProgram rs progs
case elprog of
{ Right err -> do
errorM "loadGpuProgram" $ "Error link " ++ (show progName) ++ ": " ++ err
return (rl1,Nothing)
; Left lprog -> do
debugM "loadGpuProgram" $ "GpuProgram linked: " ++ (show progName)
let lprogmap = rlLinkedGpuProgramMap rl1
lprogmap' = Map.insert progName lprog lprogmap
return (rl1 { rlLinkedGpuProgramMap = lprogmap' },Just lprog)
}
}
}
}
-- load textureunitstates (Texture)
(rl2,texUnits) <- foldM loadTextureUnit (rl1,[]) $ psTextureUnitStates p
return (rl2,(p { psTextureUnitStates = reverse texUnits, psLinkedGpuProgram = mlgp }):pl)
loadTechnique (rl0,tl) t = do
-- load passes (GpuProgram)
(rl1,passes) <- foldM loadPass (rl0,[]) $ tchPasses t
return (rl1,(t { tchPasses = reverse passes }):tl)
-- select and load supported techniques
(reslib1,suppTech) <- foldM loadTechnique (reslib0,[]) $ filter isSupportedTech $ mtTechniques mat
-- Insert loaded material into MaterialMap
let matmap = rlMaterialMap reslib1
mat' = mat { mtSupportedTechniques = Just $ reverse suppTech }
reslib2 = reslib1 { rlMaterialMap = Map.insert (mtName mat') mat' matmap }
return (reslib2,mat')
}
--getLoadedMaterial :: String -> World -> IO (World,Maybe Material)
--NOTE: this should return with Nothing if there's no supported technique
getLoadedMaterial matname world0 = case Map.lookup matname $ rlMaterialMap $ wrResource world0 of
{ Nothing -> do
errorM "loadMaterial" $ "Material not found: " ++ matname
return (world0,Nothing)
; Just mat0 -> case isJust $ mtSupportedTechniques mat0 of
{ True -> return (world0,Just mat0)
; False -> do
let rs = wrRenderSystem world0
loaders = wrImageLoaders world0
rl0 = wrResource world0
(rl1,mat1) <- loadMaterialResources rs loaders rl0 mat0
--TODO: this should return with Nothing if there's no supported technique
return (world0 { wrResource = rl1 },Just mat1)
}
}
--setEntityMaterial :: World -> [String] -> Entity -> IO (World,Entity)
setEntityMaterial world0 mats ent = do
let reslib1 = wrResource world0
rs = wrRenderSystem world0
loaders = wrImageLoaders world0
setSubEntMat (rl1,ses) (sent,matname) = do
let matmap = (rlMaterialMap rl1)
(rl2,mat) <- case Map.lookup matname matmap of
{ Just m -> do
loadMaterialResources rs loaders rl1 m
; Nothing -> do
error $ "Material not found: " ++ matname
}
return (rl2,sent { seMaterial = mat } : ses)
(reslib2,subents) <- foldM setSubEntMat (reslib1,[]) $ zip (enSubEntityList ent) mats
return (world0 { wrResource = reslib2 },ent { enSubEntityList = reverse subents })
--createEntity :: World -> String -> String -> IO (World,Entity)
createEntity world0 ename mname = do
-- lookup mesh, load if not exists
--debugM "ResourceLibrary" $ "creating entity: \"" ++ ename ++ "\" from mesh: \"" ++ mname ++ "\""
(mesh,world1) <- getMesh mname world0
--debugM "ResourceLibrary" " done"
let reslib1 = wrResource world1
rs = wrRenderSystem world1
loaders = wrImageLoaders world1
mkSubent (rl1,ses) smesh = do
let matname = (smMaterialName smesh)
matmap = (rlMaterialMap rl1)
(rl2,mat) <- case Map.lookup matname matmap of
{ Just m -> do
loadMaterialResources rs loaders rl1 m
; Nothing -> do
--debugM "createEntity" $ "Material not found: " ++ matname
-- TODO
error $ "Material not found: " ++ matname
--loadMaterialResources rs loaders rl1 (matmap ! "WarningMaterial")
}
return (rl2,SubEntity { seMaterial = mat, seSubMesh = smesh } : ses)
(reslib2,subents) <- foldM mkSubent (reslib1,[]) (msSubMeshList mesh)
let ent = Entity
{ enName = ename
, enRenderQueue = constRenderQueueMain
, enMesh = mesh
, enSubEntityList = reverse subents
}
return (world1 { wrResource = reslib2 },ent)
--loadFile :: [ResourceGroup] -> String -> Maybe 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 <- B.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 B.readFile ffname else return B.empty
return $ if e then Just ret else Nothing
renderWorld time name flatScene world = do
-- 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 targetMap of
{ Nothing -> do
debugM "renderWold" $ "RenderTarget not found: " ++ name
return world
; Just t -> do
let targets = Map.elems targetMap
(tg,tgs) = List.partition ((== name) . rtName) targets
(rtl,rwl) = List.partition (isNothing . rtTexture) tgs
mapM_ renderTarget $ rtl ++ rwl ++ tg
return world
}
where
targetMap = wrTargets world
rs = wrRenderSystem world
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
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 $ cameraProjectionMatrix (fromIntegral vw / fromIntegral vh) cam
--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 ()
-- render objects
rstat <- renderQueue time rs (wrRenderOptions world) emptyRenderStatistics $ fsRenderable fs
-- print rstat
-- Compositor
-- TargetPass
-- Pass
forM_ (vpCompositors v) $ \c -> do
let ct = head $ fromMaybe (error "fromJust 112") $ cmpSupportedTechniques c
-- select first technique
forM (zip [0..] $ ctTargetPasses ct ++ [ctOutputTarget ct]) $ \(ctpidx,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 world)
quadSM = head $ msSubMeshList quadM
quadSE = SubEntity { seMaterial = fromMaybe (error "fromJust 412") $ cpMaterial cp, seSubMesh = quadSM }
quadE = Entity "" constRenderQueueMain quadM [quadSE]
quadRE = head $ prepare (transl 0 0 0) quadE
quadRP = [RenderablePass (reOperation quadRE) p (transl 0 0 0) [] | p <- rePassList quadRE]
setProjectionMatrix rs $ transl 0 0 0
setViewMatrix rs $ transl 0 0 0
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]
return ()
{-
= 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]
where
(camMat,cam) = head $ Prelude.filter (\(_,a) -> camName == (cmName a)) cams
camName = vpCamera v
cams = fsCamera fs
(Matrix4
r11 r12 r13 _
r21 r22 r23 _
r31 r32 r33 _
tx ty tz _) = camMat
{-
cameraViewMatrix = (Matrix4
r11 r21 r31 0
r12 r22 r32 0
r13 r23 r33 0
(-tx) (-ty) (-tz) 1)
-}
cameraViewMatrix = camMat
-- createTexture :: a -> String -> TextureType -> Int -> Int -> Int -> TextureMipmap -> PixelFormat -> TextureUsage -> Bool -> Int -> String -> Image -> IO t
addRenderTexture n w h world = do
let rl = wrResource world
tm = rlTextureMap rl
rs = wrRenderSystem world
t <- createTexture rs n TEX_TYPE_2D w h 1 (MIP_NUMBER 1) PF_R8G8B8A8 (TextureUsage HBU_STATIC True False) False 0 "" Nothing
return world { wrResource = rl { rlTextureMap = Map.insert n t tm } }
--mapResource f w = w { wrResource = f (wrResource w) }
--addRenderWindow :: String -> Int -> Int -> [Viewport] -> World -> IO World
addRenderWindow n w h l world = do
vl <- mapM (\f -> f world) l
let rt = RenderTarget
{ rtName = n
, rtWidth = w
, rtHeight = h
, rtViewport = vl
, rtTexture = Nothing
}
return $ mapTargets (Map.insert n rt) world
{-
= 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 wr0 cl0 = do
-- 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 rs = wrRenderSystem wr0
initCompositor (world0,cl) c = 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 <- createTexture rs txn TEX_TYPE_2D w h 1 (MIP_NUMBER 1) (head $ tdFormatList td) (TextureUsage HBU_STATIC True False) False 0 "" Nothing
debugM "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 b tn = case Map.member tn texmap of
{ True -> return b
; False -> do
errorM "Initialize Compositor" $ "Unknown compositor texture: " ++ tn
return False
}
oktex <- foldM checkTex True onamel
case oktex of
{ False -> return (world0,Nothing:cl)
; True -> do
-- setup compositor target pass output
let tps0 = [tp { ctpOutput = o } | (o,tp) <- zip outtexl $ ctTargetPasses ct]
initPasses (w0,tpl,okPasses) tp = do
let initPass (w0,pl,okPass) cp = case cpType cp of
{ PT_RENDERQUAD -> do
-- setup composition pass input
-- load material
(w1,mmat) <- getLoadedMaterial (cpMaterialName cp) w0
case mmat of
{ Nothing -> return (w1,cp:pl,False)
; Just mat -> do
-- check pass input texture names
okInput <- foldM checkTex True [itName it | it <- IntMap.elems $ cpInputs cp]
case okInput of
{ False -> return (w1,cp:pl,False)
; True -> do
-- 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 (w1,(cp { cpMaterial = Just mat' }):pl,okPass)
}
}
; _ -> return (w0,cp:pl,okPass)
}
(w1,pl,okPasses') <- foldM initPass (w0,[],okPasses) $ ctpPasses tp
return (w1,(tp { ctpPasses = reverse pl }):tpl, okPasses')
(world1,tps1,okInit1) <- foldM initPasses (world0,[],True) tps0
(world2,motp,okInit2) <- initPasses (world1,[],okInit1) $ ctOutputTarget ct
case okInit2 of
{ False -> return (world2,Nothing:cl)
; True -> do
let otp = head motp
tps2 = reverse tps1 -- [tp | Just tp <- tps1]
return (world2,(Just c { cmpSupportedTechniques = Just [ct { ctTextureDefinitions = tds, ctTargetPasses = tps2, ctOutputTarget = otp }] }):cl)
}
}
-- setup compositor target pass input
(wr1,cl1) <- foldM initCompositor (wr0,[]) cl0
let cl2 = reverse [c | Just c <- cl1]
-- TODO: setup compositor chain connection
return (wr1,cl2)
-- | Create a viewport and attach given compositors.
mkViewport x y w h cam cnl world0 = do
-- collect compositors
let compMap = rlCompositorMap $ wrResource world0
getCompositor l cn = case Map.lookup cn compMap of
{ Nothing -> do
errorM "ApplyCompositor" $ "Unknown compositor: " ++ cn
return l
; Just c -> return $ c:l
}
-- setup compositor chain
cl0 <- foldM getCompositor [] cnl
(world1,cl1) <- mkCompositorChain world0 $ 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
}
--updateTargetSize :: String -> Int -> Int -> World -> IO World
updateTargetSize n w h = return . mapTargets (Map.adjust f n)
where
f t = t { rtWidth = w, rtHeight = h }