\section{Scenes and Animation}
A \texttt{Scene} is a complete description of an image to be rendered, consisting of a camera position, light sources, and models.
\begin{code}
module RSAGL.Scene.Scene
(Scene,
Camera(..),
infiniteCameraOf,
SceneLayerInfo(..),
SceneObject,
SceneLayer,
ScenicAccumulator(..),
SceneAccumulator,
null_scene_accumulator,
sceneObject,
cameraRelativeSceneObject,
lightSource,
accumulateSceneM,
accumulateSceneA,
assembleScene,
sceneToOpenGL,
stdSceneLayerInfo,
stdSceneLayers,
std_scene_layer_hud,
std_scene_layer_cockpit,
std_scene_layer_local,
std_scene_layer_infinite,
LightSourceLayerTransform(..),
cameraLightSourceLayerTransform)
where
import Data.Ord
import RSAGL.Modeling.BoundingBox
import RSAGL.Math.Vector
import RSAGL.Math.Affine as Affine
import RSAGL.Math.Angle as Angle
import RSAGL.Modeling.Model
import RSAGL.Scene.CoordinateSystems
import Data.List
import Control.Monad.State as State
import Control.Arrow
import Control.Arrow.Operations
import Graphics.UI.GLUT as GLUT
import Data.Maybe
import RSAGL.Math.WrappedAffine
import RSAGL.Math.Orthagonal
import RSAGL.Scene.LightSource
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Monoid
import RSAGL.Auxiliary.RecombinantState
import Data.MemoCombinators
import RSAGL.Types
\end{code}
\subsection{Cameras}
\begin{code}
data Camera =
PerspectiveCamera { camera_position, camera_lookat :: Point3D,
camera_up :: Vector3D,
camera_fov :: Angle.Angle }
instance AffineTransformable Camera where
transform m (pc@(PerspectiveCamera {})) =
pc { camera_position = transform m $ camera_position pc,
camera_lookat = transform m $ camera_lookat pc,
camera_up = transform m $ camera_up pc }
cameraToOpenGL :: RSdouble -> (RSdouble,RSdouble) -> Camera -> IO ()
cameraToOpenGL aspect_ratio (near,far)
(PerspectiveCamera { camera_position = (Point3D px py pz),
camera_lookat = (Point3D lx ly lz),
camera_up = (Vector3D ux uy uz),
camera_fov = fov }) =
do matrixMode $= Projection
loadIdentity
perspective (f2f $ toDegrees fov)
(f2f aspect_ratio)
(f2f near)
(f2f far)
matrixMode $= Modelview 0
lookAt (Vertex3 (f2f px) (f2f py) (f2f pz))
(Vertex3 (f2f lx) (f2f ly) (f2f lz))
(Vector3 (f2f ux) (f2f uy) (f2f uz))
infiniteCameraOf :: Camera -> Camera
infiniteCameraOf pc = translateToFrom origin_point_3d (camera_position pc) pc
cameraOrientation :: (AffineTransformable a) => Camera -> a -> a
cameraOrientation c = modelLookAt (camera_position c) (forward $ Left $ camera_lookat c)
(up $ Right $ camera_up c)
cameraLookAt :: (AffineTransformable a) => Camera -> a -> a
cameraLookAt = inverseTransformation . cameraOrientation
\end{code}
\subsection{Scene Construction}
A \texttt{Scene} supports local and infinite scene layers. The camera moves through the local scene layer, but the infinite scene layer is fixed. Objects in the infinite scene layer never occlude objects in the local layer. All light sources in the infinite scene layer are rendered as directional light sources in the local scene layer. Local light sources are not rendered at all in the infinite layer.
Celestial objects such as the moon and sun, as well as the sky sphere, belong in the infinite subscene. Distant clouds or mountains may also belong in the infinite layer.
\begin{code}
data SceneObject m =
LightSource LightSource
| Model (Camera -> m (WrappedAffine IntermediateModel))
instance (Monad m) => AffineTransformable (SceneObject m) where
transform m (LightSource ls) = LightSource $ transform m ls
transform m (Model imodel) = Model $ \c -> liftM (transform m) (imodel c)
type SceneLayer = Integer
data SceneAccumulator m = SceneAccumulator {
sceneaccum_objs :: [(SceneLayer,SceneObject m)],
sceneaccum_coordinate_system :: CoordinateSystem }
instance CoordinateSystemClass (SceneAccumulator m) where
getCoordinateSystem = sceneaccum_coordinate_system
storeCoordinateSystem cs sceneaccum = sceneaccum { sceneaccum_coordinate_system = cs }
instance RecombinantState (SceneAccumulator m) where
type SubState (SceneAccumulator m) = SceneAccumulator m
clone orig = orig { sceneaccum_objs = [] }
recombine orig new = orig {
sceneaccum_objs = sceneaccum_objs new ++ sceneaccum_objs orig }
class (RecombinantState a,CoordinateSystemClass a,Monad m) => ScenicAccumulator a m | a -> m where
accumulateScene :: SceneLayer -> SceneObject m -> a -> a
instance (Monad m) => ScenicAccumulator (SceneAccumulator m) m where
accumulateScene slayer scobj sceneaccum = sceneaccum {
sceneaccum_objs = (slayer,migrateToFrom (sceneaccum_coordinate_system sceneaccum) root_coordinate_system scobj) : sceneaccum_objs sceneaccum }
null_scene_accumulator :: SceneAccumulator m
null_scene_accumulator = SceneAccumulator [] root_coordinate_system
sceneObject :: (Monad m,ModelType mt) => m mt -> SceneObject m
sceneObject = cameraRelativeSceneObject . const . liftM (wrapAffine . toIntermediateModel)
cameraRelativeSceneObject :: (Monad m) => (Camera -> m (WrappedAffine IntermediateModel)) -> SceneObject m
cameraRelativeSceneObject = Model
lightSource :: LightSource -> SceneObject m
lightSource = LightSource
accumulateSceneM :: (ScenicAccumulator sa a,Monad m,MonadState sa m) => SceneLayer -> SceneObject a -> m ()
accumulateSceneM slayer scobj = modify (accumulateScene slayer scobj)
accumulateSceneA :: (ScenicAccumulator sa m,Arrow arr,ArrowState sa arr) => arr (SceneLayer,SceneObject m) ()
accumulateSceneA = proc (slayer,scobj) ->
do sceneaccum <- fetch -< ()
store -< accumulateScene slayer scobj sceneaccum
\end{code}
\subsection{Scene Assembly}
Once all objects have been accumulated, the accumulation is used to generate a \texttt{Scene} object.
\begin{code}
data SceneElement = SceneElement {
scene_elem_layer :: SceneLayer,
scene_elem_opaque :: Bool,
scene_elem_model :: WrappedAffine IntermediateModel,
scene_elem_light_sources :: [LightSource] }
data Scene = Scene {
scene_elements :: Map.Map (SceneLayer,Bool) [SceneElement],
scene_layerToCamera :: (SceneLayer -> Camera) }
data SceneLayerInfo = SceneLayerInfo {
scene_layer_camera :: SceneLayer -> Camera,
scene_layer_light_source_layer_transform :: LightSourceLayerTransform }
assembleScene :: (Monad m) => SceneLayerInfo -> SceneAccumulator m -> m Scene
assembleScene (SceneLayerInfo layerToCamera light_source_layer_transform) scene_accum =
do elements <- liftM (Map.mapWithKey (\(_,opaque) -> if not opaque then sortModels else id) .
foldr (\se -> Map.alter (Just . (se:) . fromMaybe [])
(scene_elem_layer se,scene_elem_opaque se)) Map.empty . concat) $
mapM toElement $ sceneaccum_objs scene_accum
return $ Scene { scene_elements = elements,
scene_layerToCamera = layerToCamera }
where splitOpaquesWrapped :: WrappedAffine IntermediateModel -> (WrappedAffine IntermediateModel,
[WrappedAffine IntermediateModel])
splitOpaquesWrapped (WrappedAffine a m) =
let (opaques,transparents) = splitOpaques m
in (WrappedAffine a opaques,map (WrappedAffine a) transparents)
toLightSource :: SceneLayer -> (SceneLayer,SceneObject m) -> LightSource
toLightSource entering_layer (originating_layer,LightSource ls) =
lightSourceLayerTransform light_source_layer_transform entering_layer originating_layer ls
toLightSource _ _ = NoLight
sortModels :: [SceneElement] -> [SceneElement]
sortModels = map fst . sortBy (comparing $ \(se,bbox) -> negate $
minimalDistanceToBoundingBox (camera_position $ layerToCamera $ scene_elem_layer se) bbox) .
map (\(se@(SceneElement { scene_elem_model = WrappedAffine cs m })) ->
(se,migrateToFrom cs root_coordinate_system $ boundingBox m))
toElement :: (Monad m) => (SceneLayer,SceneObject m) -> m [SceneElement]
toElement (n,Model f) =
do (opaque,transparents) <- liftM splitOpaquesWrapped $ f (layerToCamera n)
let light_sources = filter (not . isNoLight) $ map (toLightSource n) (sceneaccum_objs scene_accum)
let base_element = SceneElement {
scene_elem_layer = n,
scene_elem_opaque = True,
scene_elem_model = opaque,
scene_elem_light_sources = light_sources }
return $ base_element : map (\m -> base_element { scene_elem_model = m,
scene_elem_opaque = False }) transparents
toElement _ = return []
sceneToOpenGL :: RSdouble -> (RSdouble,RSdouble) -> Scene -> IO ()
sceneToOpenGL aspect_ratio nearfar s =
do let ns = reverse $ Set.toList $ Set.map fst $ Map.keysSet $ scene_elements s
mapM_ (render1Layer aspect_ratio nearfar s) ns
render1Layer :: RSdouble -> (RSdouble,RSdouble) -> Scene -> SceneLayer -> IO ()
render1Layer aspect_ratio nearfar (Scene elems layerToCamera) n =
do save_rescale_normal <- GLUT.get rescaleNormal
save_cull_face <- GLUT.get cullFace
save_depth_func <- GLUT.get depthFunc
save_depth_mask <- GLUT.get depthMask
save_lighting <- GLUT.get lighting
save_light_model_ambient <- GLUT.get lightModelAmbient
rescaleNormal $= Enabled
cullFace $= Just Front
depthFunc $= Just Lequal
depthMask $= Enabled
lighting $= Enabled
lightModelAmbient $= (Color4 0 0 0 1)
clear [DepthBuffer]
preservingMatrix $
do cameraToOpenGL aspect_ratio nearfar (layerToCamera n)
mapM_ render1Element $ fromMaybe [] $ Map.lookup (n,True) elems
depthMask $= Disabled
mapM_ render1Element $ fromMaybe [] $ Map.lookup (n,False) elems
lightModelAmbient $= save_light_model_ambient
lighting $= save_lighting
depthMask $= save_depth_mask
depthFunc $= save_depth_func
cullFace $= save_cull_face
rescaleNormal $= save_rescale_normal
render1Element :: SceneElement -> IO ()
render1Element (SceneElement { scene_elem_light_sources = lss, scene_elem_model = (WrappedAffine m imodel)}) =
do setLightSourcesToOpenGL lss
migrateToFrom m root_coordinate_system $ intermediateModelToOpenGL imodel
\end{code}
\subsection{Standard Scene Layers}
This is an example of how to implement scene layers that should be adequate to most purposes.
\begin{code}
stdSceneLayerInfo :: Camera -> SceneLayerInfo
stdSceneLayerInfo c = SceneLayerInfo (stdSceneLayers c) (cameraLightSourceLayerTransform (stdSceneLayers c))
stdSceneLayers :: Camera -> SceneLayer -> Camera
stdSceneLayers c sl | sl <= std_scene_layer_hud = c
stdSceneLayers c sl | sl == std_scene_layer_cockpit = c {
camera_position = origin_point_3d,
camera_lookat = Point3D 0 0 (1),
camera_up = Vector3D 0 1 0 }
stdSceneLayers c sl | sl == std_scene_layer_local = c
stdSceneLayers c sl | sl >= std_scene_layer_infinite = infiniteCameraOf c
stdSceneLayers _ _ = error "stdSceneLayers: impossible case"
std_scene_layer_hud :: SceneLayer
std_scene_layer_hud = 0
std_scene_layer_cockpit :: SceneLayer
std_scene_layer_cockpit = 1
std_scene_layer_local :: SceneLayer
std_scene_layer_local = 2
std_scene_layer_infinite :: SceneLayer
std_scene_layer_infinite = 3
\end{code}
\subsection{Standard Light Layer Transforms}
\begin{code}
newtype LightSourceLayerTransform = LightSourceLayerTransform { lightSourceLayerTransform :: SceneLayer -> SceneLayer -> LightSource -> LightSource }
instance Monoid LightSourceLayerTransform where
mempty = LightSourceLayerTransform $ const $ const id
mappend (LightSourceLayerTransform f) (LightSourceLayerTransform g) = LightSourceLayerTransform $ memo2 integral integral $ \a b -> f a b . g a b
cameraLightSourceLayerTransform :: (SceneLayer -> Camera) -> LightSourceLayerTransform
cameraLightSourceLayerTransform layerToCamera = LightSourceLayerTransform $ memo2 integral integral f
where f :: SceneLayer -> SceneLayer -> LightSource -> LightSource
f entering_layer originating_layer | entering_layer == originating_layer = id
f entering_layer originating_layer | entering_layer < originating_layer =
cameraOrientation (layerToCamera entering_layer) . infiniteLightSourceOf . cameraLookAt (layerToCamera originating_layer)
f _ _ = const NoLight
\end{code}