module Graphics.LambdaCube.SceneGraph where

import Control.Applicative
import Data.List (foldl')

import Graphics.LambdaCube.Common
import Graphics.LambdaCube.Entity
import Graphics.LambdaCube.GpuProgram
import Graphics.LambdaCube.HardwareIndexBuffer
import Graphics.LambdaCube.HardwareVertexBuffer
import Graphics.LambdaCube.Light
import Graphics.LambdaCube.RenderQueue
import Graphics.LambdaCube.RenderSystem
import Graphics.LambdaCube.Texture
import Graphics.LambdaCube.Tree
import Graphics.LambdaCube.Types
import Graphics.LambdaCube.World

type MkSceneObjectAction r vb ib q t p lp e = LCM (World r vb ib q t p lp) e (SceneObject vb ib t lp)

type MkNodeAction r vb ib q t p lp e = LCM (World r vb ib q t p lp) e ((String, String), SceneNode vb ib t lp)

-- | Construct a scene object representing a camera with the given
-- specification.
camera :: RenderSystem r vb ib q t p lp => Camera -> MkSceneObjectAction r vb ib q t p lp e
camera = return . SO_Camera

-- | Construct a scene object representing a basic camera with the
-- given name.
simpleCamera :: RenderSystem r vb ib q t p lp => String -> MkSceneObjectAction r vb ib q t p lp e
simpleCamera name = return $ SO_Camera Camera
    { cmName        = name
    , cmFov         = 45
    , cmNear        = 0.1
    , cmFar         = 5000
    , cmAspectRatio = Nothing
    , cmPolygonMode = PM_SOLID
    }

-- | Construct a scene object representing a wireframe-mode camera
-- with the given name.
wireCamera :: RenderSystem r vb ib q t p lp => String -> MkSceneObjectAction r vb ib q t p lp e
wireCamera name = return $ SO_Camera Camera
    { cmName        = name
    , cmFov         = 45
    , cmNear        = 0.1
    , cmFar         = 5000
    , cmAspectRatio = Nothing
    , cmPolygonMode = PM_WIREFRAME
    }

-- | Construct a scene object representing a light source with the
-- given specification.
light :: RenderSystem r vb ib q t p lp => Light -> MkSceneObjectAction r vb ib q t p lp e
light = return . SO_Light

-- | Construct a scene object representing a basic light source.
defaultLight :: RenderSystem r vb ib q t p lp => MkSceneObjectAction r vb ib q t p lp e
defaultLight = light $ 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
    }

-- | Construct a scene object representing a polygon mesh.
mesh :: (RenderSystem rs vb ib q t p lp, Enum rqp)
     => Maybe rqp                               -- ^ Render queue priority (defaults to 'RQP_Main').
     -> Maybe [String]                          -- ^ The list of materials to overried those supplied by the original mesh.
     -> String                                  -- ^ The name of the mesh to use as the source.
     -> MkSceneObjectAction rs vb ib q t p lp e
mesh renderQueueID materials name = do
    e <- createEntity name name (maybe (fromEnum RQP_Main) fromEnum renderQueueID)
    case materials of
        Nothing -> return (SO_Entity e)
        Just mats -> SO_Entity <$> setEntityMaterial mats e

-- | Construct a scene graph node description.
node :: RenderSystem r vb ib q t p lp
     => String                                    -- ^ The name of the parent node.
     -> String                                    -- ^ The name of the node.
     -> Proj4                                     -- ^ The transformation to apply the subtree with the node in its root.
     -> [MkSceneObjectAction r vb ib q t p lp e]  -- ^ The scene objects that make up the node.
     -> MkNodeAction r vb ib q t p lp e
node parent name t objActs = do
    o <- sequence objActs
    return ((parent,name),SceneNode name o t)

-- | Add a list of new nodes to the global scene.
addScene :: RenderSystem r vb ib q t p lp => [MkNodeAction r vb ib q t p lp e] -> LCM (World r vb ib q t p lp) e ()
addScene nodes = do
    ns <- sequence nodes
    graph <- scGraph . wrScene <$> peekLCM
    let graph' = foldl' regNode graph ns
        regNode g ((parent,name),node) = case addNode parent name node g of
            Nothing -> error $ "Unknown parent node: " ++ parent
            Just g' -> g'
    updateWorld $ mapScene $ \s -> s { scGraph = graph' }

-- | Update the transformation matrices of the given nodes.
updateTransforms :: RenderSystem r vb ib q t p lp => [(String, Proj4)] -> LCM (World r vb ib q t p lp) e ()
updateTransforms l = updateWorld $ mapScene $ \s -> s { scGraph = foldl' update (scGraph s) l }
  where
    update g (name,mat) = updateNode (\sn -> sn { snTransform = mat }) name g

-- | Update the objects associated with the given nodes.
updateObjects :: RenderSystem rs vb ib q t p lp => [(String, [MkSceneObjectAction rs vb ib q t p lp e])] -> LCM (World rs vb ib q t p lp) e ()
updateObjects = mapM_ updateSceneNode
  where
    updateSceneNode (name,objActs) = do
        o <- sequence objActs
        updateWorld $ mapScene $ \s ->
            s { scGraph = updateNode (\sn -> sn {snObject = o}) name (scGraph s) }

flattenScene :: (HardwareVertexBuffer vb, HardwareIndexBuffer ib, Texture t, LinkedGpuProgram lp) => Scene vb ib t lp -> FlattenScene vb ib t lp
flattenScene scene = FlattenScene
    { fsCamera     = cs
    , fsRenderable = rs
    , fsLight      = ls
    }
  where
    pr = renderableDefaultPriority
    (cs,rs,ls) = foldr sep ([],[],[])
                 [(m,o) | (m,os) <- flattenTree trans getObj idmtx (scGraph scene)
                        , o <- os
                        ]
      where
        trans t sn = snTransform sn .*. t
        getObj t sn = (trans t sn, snObject sn)

        sep (m,SO_Camera c) (cs,rs,ls) = ((m,c):cs,rs,ls)
        sep (m,SO_Entity e) (cs,rs,ls) = (cs,(m,prepare m e,enRenderQueue e,pr):rs,ls)
        sep (m,SO_Light l)  (cs,rs,ls) = (cs,rs,(m,l):ls)

-- | Render the given target.
renderWorld :: RenderSystem r vb ib q t p lp
            => FloatType                          -- ^ The current time in seconds (needed for animation).
            -> String                             -- ^ The target to render.
            -> LCM (World r vb ib q t p lp) e ()
renderWorld time target = do
    flatScene <- flattenScene . wrScene <$> peekLCM
    renderFlatScene time target flatScene