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