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
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)
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)
inLCM :: (w -> IO w) -> LCM w e ()
inLCM act = LCM (\k t w -> act w >>= k ())
peekLCM :: LCM w e w
peekLCM = LCM (\k t w -> k w w)
pokeLCM :: w -> LCM w e ()
pokeLCM w' = LCM (\k t w -> k () w')
throwLCM :: e -> LCM w e a
throwLCM x = LCM (\k t w -> t x w)
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
data (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => FlattenScene vb ib t lp
= FlattenScene
{ fsRenderable :: [(Proj4,[RenderEntity vb ib t lp],Int,Int)]
, 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
, wrRenderSystem :: r
, 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' }
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
}
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)
}
data Camera
= Camera
{ cmName :: String
, cmFov :: FloatType
, cmNear :: FloatType
, cmFar :: FloatType
, cmAspectRatio :: Maybe FloatType
, cmPolygonMode :: PolygonMode
}
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
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
}
data Sky
= SkyBox --Material
| SkyDome
| SkyPlane
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
}
addVMesh :: RenderSystem r vb ib q t p lp
=> String
-> VMesh
-> 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
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!"
updateResource $ \rl -> rl { rlMeshMap = Map.insert name m (rlMeshMap rl) }
return m
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
suppTech <- forM (filter isSupportedTech (mtTechniques mat)) $ \tech -> do
passes <- forM (tchPasses tech) $ \pass -> do
lgp <- loadGpuProgram pass
tuss <- forM (psTextureUnitStates pass) loadTextureUnit
return $ pass
{ psTextureUnitStates = tuss
, psLinkedGpuProgram = lgp
}
return (tech { tchPasses = passes })
let mat' = mat { mtSupportedTechniques = Just suppTech }
updateResource $ \rl -> rl { rlMaterialMap = Map.insert (mtName mat') mat' (rlMaterialMap rl) }
return mat'
where
isSupportedTech _ = True
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
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
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
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
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
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])
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
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)
frames <- case tusTextureType t of
TEX_TYPE_CUBE_MAP -> maybeToList <$> loadCubicTexture (tusFrameNames t)
_ -> catMaybes <$> forM (tusFrameNames t) loadTexture
return $ t { tusFrames = Just frames }
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)
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
mesh <- getMesh mname
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
return (SubEntity { seMaterial = mat, seSubMesh = smesh })
return $ Entity
{ enName = ename
, enRenderQueue = fromEnum renderQueueID
, enMesh = mesh
, enSubEntityList = subents
}
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
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
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
let t = rtTexture rt
mapM_ (renderViewport flatScene rt) $ rtViewport rt
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
when (vpClearEveryFrame v) $
clearFrameBuffer rs (vpClearBuffers v) (vpBackColour v) 1 0
--mDestRenderSystem->_beginFrame();
setPolygonMode rs $ cmPolygonMode cam
setProjectionMatrix rs projectionMatrix
--setTextureProjectionRelativeTo
setViewMatrix rs cameraViewMatrix
--HINT:
unless (null $ vpCompositors v) $ do
return ()
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')]
rstat <- renderQueue time rs wrRenderOptions emptyRenderStatistics (fsLight fs) culledScene
forM_ (vpCompositors v) $ \c -> do
let ct = head $ fromMaybe (error "fromJust 112") $ cmpSupportedTechniques c
forM (ctTargetPasses ct ++ [ctOutputTarget ct]) $ \ctp -> do
when (ctpInputMode ctp == IM_PREVIOUS) $ do
dirtyHackCopyTexImage rs (fromMaybe (error "fromJust 212") $ tdTexture $ fromJust $ ctpOutput ctp) vx vy vw vh
forM (ctpPasses ctp) $ \cp -> do
case cpType cp of
PT_RENDERQUAD -> do
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 ()
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
addRenderTexture :: RenderSystem r vb ib q a p lp
=> String
-> Int
-> Int
-> 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 }
addRenderWindow :: RenderSystem r vb ib q t p lp
=> String
-> Int
-> Int
-> [LCM (World r vb ib q t p lp) e (Viewport t lp)]
-> 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))
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
let initCompositor c = catchLCM $ do
let ct = head $ cmpTechniques c
tds <- forM (ctTextureDefinitions ct) $ \td -> do
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
let initPasses tp = do
pl <- forM (ctpPasses tp) $ \cp -> case cpType cp of
PT_RENDERQUAD -> do
mmat@ ~(Just mat) <- getLoadedMaterial (cpMaterialName cp)
when (isNothing mmat) $ throwLCM Nothing
forM_ [itName it | it <- IntMap.elems $ cpInputs cp] checkTex
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 (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'] })
catMaybes <$> forM cl initCompositor
viewport :: RenderSystem r vb ib q t p lp
=> FloatType
-> FloatType
-> FloatType
-> FloatType
-> String
-> [String]
-> 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
let getCompositor l cn = case Map.lookup cn compMap of
Nothing -> do
errorLCM "ApplyCompositor" $ "Unknown compositor: " ++ cn
return l
Just c -> return $ c:l
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
}
updateTargetSize :: RenderSystem rs vb ib q t p lp
=> String
-> Int
-> Int
-> 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 }