Resource.hs

module Graphics.LambdaCube.Resource where

import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Control.Monad
import System.Directory
import System.FilePath

import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString as SB
import Data.ByteString.Internal as B
import Codec.Archive.Zip
import System.Log.Logger

import Graphics.LambdaCube.Loader.CompositorScript
import Graphics.LambdaCube.Loader.MaterialScript
import Graphics.LambdaCube.Loader.ResourceScript
import Graphics.LambdaCube.Compositor
import Graphics.LambdaCube.Material
import Graphics.LambdaCube.Texture
import Graphics.LambdaCube.GpuProgram
import Graphics.LambdaCube.World

-- load resources into resource library (initResources :: [ResourceGroup] -> ResourceLibrary)

{-
    Stores data about:
      - loaded meshes (name)
      - loaded and compiled materials (name)
-}

-- TODO: load all available materials
-- scan path tree searching for *.material files
data (Texture t, GpuProgram p, LinkedGpuProgram lp) => ResourceItem t p lp
    = RI_Material   (String,Material t lp)
    | RI_GpuProgram (String,GpuProgramDescriptor p)
    | RI_Compositor (String,Compositor t lp)
                
addConfig cfgFile world = do
    Just rp <- loadResourcesCfg cfgFile
    addResourceLibrary rp world

addResourceLibrary resPath w@World { wrResource = res } = do
    -- fold on every group and path
    -- getDirectoryContents :: FilePath -> IO [FilePath]
    -- doesDirectoryExist :: FilePath -> IO Bool
    -- takeExtension :: FilePath -> String
    -- TODO:
    --  scan whole resource path searching for resource files and load them:
    --    .material
    --    .program
    --  add normal (uncompiled) materials to material library
    let loadResGrp s (_,l) = foldM loadRes s l
        loadRes l (PathZip,n) = return l
        loadRes l p@(PathDir,n) = do
            ok <- doesDirectoryExist n
            case ok of
                { True  -> do
                    c <- getDirectoryContents n
                    foldM (loadItem n) l c
                ; False -> return l
                }
        loadItem dn l n = do
            --parseMaterial -> Maybe (mats,verts,frags)
            case takeExtension n of
                { ".material" -> do
                    debugM "ResourceLibrary" $ "load: " ++ n
                    f <- B.readFile $ dn ++ "/" ++ n -- FIXME: this is temporary solution
                    mb <- parseMaterial n $ map B.w2c $ B.unpack f
                    case mb of
                        { Nothing   -> do
                            errorM  "ResourceLibrary" $ "Syntax error in file " ++ n
                            return l
                        ; Just (ml,vpl,fpl) -> do
                            let ms = [RI_Material (mtName m,m) | m <- ml]
                                vs = [RI_GpuProgram (gpdName m,m) | m <- vpl]
                                fs = [RI_GpuProgram (gpdName m,m) | m <- fpl]
                            return $ l ++ ms ++ vs ++ fs
                        }
                ; ".compositor" -> do
                    debugM "ResourceLibrary" $ "load: " ++ n
                    f <- B.readFile $ dn ++ "/" ++ n -- FIXME: this is temporary solution
                    mb <- parseCompositor n $ map B.w2c $ B.unpack f
                    case mb of
                        { Nothing   -> do
                            errorM  "ResourceLibrary" $ "Syntax error in file " ++ n
                            return l
                        ; Just cl -> do
                            return $ l ++ [RI_Compositor (cmpName m,m) | m <- cl]
                        }
                ; _ -> return l
                }
        insertList = List.foldl' (flip (uncurry Map.insert))
    l <- foldM loadResGrp [] resPath
    return w { wrResource = res 
                { rlResourceGroups = resPath ++ rlResourceGroups res
                , rlMaterialMap     = insertList (rlMaterialMap res)    [m | (RI_Material m) <- l]
                , rlGpuProgramMap   = insertList (rlGpuProgramMap res)  [m | (RI_GpuProgram m) <- l]
                , rlCompositorMap   = insertList (rlCompositorMap res)  [m | (RI_Compositor m) <- l]
                }
             }
               --ResourceLibrary (resPath++path) meshes (Map.union mats materialMap) texes (Map.union shads shaderMap) progs

{-
loadResourceGroup
dropResourceGroup
-}

{-
--compileMaterial
-- load textures from disk to opengl
-- drops unnecessary techniques (include,exlude rules)
compileMaterial :: ResourceLibrary -> String -> IO (ResourceLibrary,Material)
compileMaterial rlib m = do
    let mm = (rlMaterialMap rlib)
    if Map.notMember m mm then error ("Unknown material: " ++ m) else return ()
    let (mt,mcmt) = mm Map.! m
    (rlib',cmt) <- if isJust mcmt then return (rlib,fromMaybe (error "fromJust 0") mcmt) else compMat rlib mt -- copy original material data and load texture units
    return (rlib',cmt) where
        compMat rl mat@(Material {mtTechnique=techs}) = do
            debugM "ResourceLibrary" $ "compiling material: " ++ m
            (rl',techs') <- foldM compTechnique (rl,[]) techs
            let matmap' = insert m (mat,Just cmt') (rlMaterialMap rl) 
                cmt' = mat{mtTechnique=techs'}
            return (rl'{rlMaterialMap=matmap'},cmt')
        compTechnique (rl,l) t@(Technique {tcPass=p}) = do
            excl <- excludeTechnique t
            if excl then return (rl, l) else do
                (rl',p') <- foldM compPass (rl,[]) p
                return (rl',(l ++ [t{tcPass=p'}]))
        compPass (rl,l) p = do
            (rl',tu') <- foldM compTexUnit (rl,[]) $ psTextureUnit p
            let (ProgRefName prog) = psShaderProgram p
            (rl'',prog') <- compileProgram rl' prog
            return (rl'',(l ++ [p{psTextureUnit=tu', psShaderProgram=(ProgRefObj prog')}]))
        compTexUnit (rl,l) tu = do
            (rl',texid) <- loadTexture rl $ head $ tuTexture tu
            return (rl',(l ++ [tu{tuTextureObject=Just [texid]}]))
        excludeTechnique t@(Technique {tcPass=p}) = do
            -- exclude if shaders are not supported
            version <- GL.get (GL.majorMinor GL.glVersion)
            let reqShaders = not $ null $ filter (\(Pass {psShaderProgram=(ProgRefName (vp,pp))})-> isJust vp || isJust pp) p
            if reqShaders && version < (2,0) then return True else return False
-}