SceneGraph.hs

module Graphics.LambdaCube.SceneGraph where

import Data.Maybe
import Data.Map as Map hiding (map)
import qualified Data.IntMap as IntMap
import Data.List as List
import Control.Monad
import System.FilePath

import Data.Graph.Inductive

import Graphics.LambdaCube.Types
import Graphics.LambdaCube.Common
import Graphics.LambdaCube.Math
import Graphics.LambdaCube.Light
import Graphics.LambdaCube.Material
import Graphics.LambdaCube.Entity
import Graphics.LambdaCube.Resource
import Graphics.LambdaCube.RenderQueue
import Graphics.LambdaCube.World
import Graphics.LambdaCube.Texture
import Graphics.LambdaCube.RenderSystem
    
--type MkSceneObjectAction = World -> IO (World, SceneObject)
--type MkNodeAction = ResourceLibrary -> IO (ResourceLibrary,(String,String),SceneNode)

--simpleCamera :: String -> MkSceneObjectAction
simpleCamera name w = return (w,cam)
  where
    cam = SO_Camera Camera
        { cmName        = name
        , cmFov         = 45
        , cmNear        = 0.1
        , cmFar         = 5000
        , cmAspectRatio = Nothing
        , cmPolygonMode = PM_SOLID
        }

--wireCamera :: String -> MkSceneObjectAction
wireCamera name w = return (w,cam)
  where
    cam = SO_Camera Camera
        { cmName        = name
        , cmFov         = 45
        , cmNear        = 0.1
        , cmFar         = 5000
        , cmAspectRatio = Nothing
        , cmPolygonMode = PM_WIREFRAME
        }

--light :: MkSceneObjectAction
light w = return (w,SO_Light $ Light {})

--camera :: Camera -> MkSceneObjectAction
camera cam w = return (w,SO_Camera cam)

--mesh :: String -> MkSceneObjectAction
mesh name w = do
    (w',e) <- createEntity w name name
    return (w', SO_Entity e)

--meshMat :: String -> [String] -> MkSceneObjectAction
meshMat name mats w0 = do
    (w1,e0) <- createEntity w0 name name
    (w2,e1) <- setEntityMaterial w1 mats e0
    return (w2, SO_Entity e1)

--mkNode :: String -> String -> Matrix4 -> [MkSceneObjectAction] -> MkNodeAction
mkNode parent name t objActs w = do
    (w',o) <- foldM mkObjs (w,[]) objActs
    return (w',(parent,name),SceneNode name o t)
  where
    mkObjs (w,l) a = do
        (w',so) <- a w
        return (w',so:l)
{-
addSkyBox :: String -> World -> IO World
addSkyBox s w@World { wrResource = rl, wrScene = scene } = do
    (rl',mat) <- compileMaterial rl s
    return w { wrResource = rl', wrScene = scene{scSky = Just $ SkyBox mat} }
-}

{-
data Scene = Scene
    { scGraph :: Gr String ()
    -- use: bytestring-trie (efficient ByteString map)
    , scMap   :: Map String SceneNode
    , scSky   :: Maybe Sky
    -- Fog settings
    }
-}
--addScene :: [MkNodeAction] -> World -> IO World
addScene nodes w@World { wrResource = rl, wrScene = scene } = do
    -- done: create scene nodes
    let mkNodes (w,pl,nl) a = do
            (w',p,sn) <- a w
            return (w',p:pl,sn:nl)
    (w',p,nodel) <- foldM mkNodes (w,[],[]) nodes
    -- done: register node ids and names to bimap
    -- done: create graph nodes 
    -- done: create graph edges
    let namel = map snName nodel
        nodeids = newNodes (length nodes) $ scGraph scene
        m' = (scMap scene) `Map.union` (Map.fromList $ zip namel $ zip nodeids nodel)
        g = insEdges (map fe p) $ insNodes (zip nodeids namel) $ scGraph scene
        fe (p,c) = (fst $ m' ! p, fst $ m' ! c,())
        scene' = scene 
               { scGraph   = g
               , scMap     = m'
               --, scSky     :: Maybe Sky
               }

    return w' { wrScene = scene' }
    
--updateTransforms :: [(String,Matrix4)] -> World -> IO World
updateTransforms l = return . mapScene (\s -> foldr updateSceneNode s l)
  where
    updateSceneNode (name,mat) scene = scene { scMap = Map.insert name (n,sn') m}
      where
        m = scMap scene
        (n,sn) = m ! name
        sn' = sn {snTransform = mat}

--flattenScene :: Scene -> FlattenScene
flattenScene s = FlattenScene
                 { fsCamera     = [(m,c) | (m,SO_Camera c) <- fs]
                 , fsRenderable = [(m,prepare m e,rq,pr) | (m,SO_Entity e) <- fs]
                 , fsLight      = [(m,l) | (m,SO_Light l) <- fs]
                 }
  where
    rq = constRenderQueueMain
    pr = constRenderableDefaultPriority
    fs = visitNode s 0 $ transl 0 0 0

    --visitNode :: Scene -> Int -> Matrix4 -> [(Matrix4,SceneObject)]
    visitNode g n t = [(lt,e) | e <- snObject ln ] ++ (concat [ visitNode g sn lt | sn <- suc (scGraph g) n ])
      where
        Just name = lab (scGraph g) n
        ln = snd $ (scMap g) ! name
        lt = (snTransform ln) <> t