{-# 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 }