\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,
Camera(..),
LightSource(..),
SceneObject,
SceneLayer(..),
ScenicAccumulator(..),
SceneAccumulator,
null_scene_accumulator,
sceneObject,
cameraRelativeSceneObject,
lightSource,
accumulateSceneM,
accumulateSceneA,
assembleScene,
sceneToOpenGL)
where
import Data.Ord
import RSAGL.BoundingBox
import RSAGL.Vector
import RSAGL.Affine as Affine
import RSAGL.Angle as Angle
import RSAGL.Model
import RSAGL.CoordinateSystems
import Data.List
import Control.Monad.State as State
import Control.Arrow
import Control.Arrow.Operations
import RSAGL.Color as Color
import Graphics.UI.GLUT as GLUT
import Data.Maybe
import RSAGL.WrappedAffine
\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 :: Double -> (Double,Double) -> 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 (toDegrees fov)
aspect_ratio
near
far
matrixMode $= Modelview 0
lookAt (Vertex3 px py pz) (Vertex3 lx ly lz) (Vector3 ux uy uz)
infiniteCameraToOpenGL :: Double -> (Double,Double) -> Camera -> IO ()
infiniteCameraToOpenGL aspect_ratio nearfar pc =
cameraToOpenGL aspect_ratio nearfar $ Affine.translate (vectorToFrom origin_point_3d $ camera_position pc) pc
\end{code}
\subsection{Light Sources}
\begin{code}
data LightSource =
DirectionalLight { lightsource_direction :: Vector3D,
lightsource_color :: Color.RGB,
lightsource_ambient :: Color.RGB }
| PointLight { lightsource_position :: Point3D,
lightsource_radius :: Distance,
lightsource_color :: Color.RGB,
lightsource_ambient :: Color.RGB }
| NoLight
makeInfinite :: LightSource -> LightSource
makeInfinite NoLight = NoLight
makeInfinite (d@(DirectionalLight {})) = d
makeInfinite (p@PointLight {}) = DirectionalLight {
lightsource_direction = vectorToFrom origin_point_3d $ lightsource_position p,
lightsource_color = scaleRGB scale_factor $ lightsource_color p,
lightsource_ambient = scaleRGB scale_factor $ lightsource_ambient p }
where scale_factor = realToFrac $ (distance $ lightsource_radius p) / (distanceBetweenSquared origin_point_3d (lightsource_position p))
instance AffineTransformable LightSource where
transform _ NoLight = NoLight
transform m (dl@(DirectionalLight {})) = dl { lightsource_direction = transform m $ lightsource_direction dl }
transform m (pl@(PointLight {})) = pl {
lightsource_position = transform m $ lightsource_position pl,
lightsource_radius = transform m $ lightsource_radius pl }
setLightSources :: [LightSource] -> IO ()
setLightSources lss =
do max_lights <- GLUT.get maxLights
mapM_ setLightSource $ genericTake max_lights $ zip (map Light [0..]) (lss ++ repeat NoLight)
setLightSource :: (Light,LightSource) -> IO ()
setLightSource (l,NoLight) = light l $= Disabled
setLightSource (l,dl@DirectionalLight { lightsource_color = Color.RGB cr cg cb,
lightsource_ambient = Color.RGB ar ag ab }) =
do let Vector3D vx vy vz = vectorNormalize $ lightsource_direction dl
light l $= Enabled
ambient l $= (Color4 ar ag ab 1.0 :: Color4 Float)
GLUT.specular l $= (Color4 cr cg cb 1.0 :: Color4 Float)
diffuse l $= (Color4 cr cg cb 1.0 :: Color4 Float)
position l $= (Vertex4 (realToFrac vx) (realToFrac vy) (realToFrac vz) 0 :: Vertex4 Float)
attenuation l $= (1,0,0)
setLightSource (l,pl@(PointLight { lightsource_position = (Point3D px py pz),
lightsource_color = Color.RGB cr cg cb,
lightsource_ambient = Color.RGB ar ag ab })) =
do light l $= Enabled
ambient l $= (Color4 ar ag ab 1.0 :: Color4 Float)
GLUT.specular l $= (Color4 cr cg cb 1.0 :: Color4 Float)
diffuse l $= (Color4 cr cg cb 1.0 :: Color4 Float)
position l $= (Vertex4 (realToFrac px) (realToFrac py) (realToFrac pz) 1 :: Vertex4 Float)
attenuation l $= (0.01,0,recip $ realToFrac $ distanceSquared $ lightsource_radius pl)
\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 =
LightSource LightSource
| Model (Camera -> IO (WrappedAffine IntermediateModel))
instance AffineTransformable SceneObject where
transform m (LightSource ls) = LightSource $ transform m ls
transform m (Model imodel) = Model $ \c -> liftM (transform m) (imodel c)
data SceneLayer = Local | Infinite deriving (Eq)
data SceneAccumulator = SceneAccumulator {
sceneaccum_objs :: [(SceneLayer,SceneObject)],
sceneaccum_coordinate_system :: CoordinateSystem }
instance CoordinateSystemClass SceneAccumulator where
getCoordinateSystem = sceneaccum_coordinate_system
storeCoordinateSystem cs sceneaccum = sceneaccum { sceneaccum_coordinate_system = cs }
class (CoordinateSystemClass a) => ScenicAccumulator a where
accumulateScene :: SceneLayer -> SceneObject -> a -> a
instance ScenicAccumulator SceneAccumulator where
accumulateScene slayer scobj sceneaccum = sceneaccum {
sceneaccum_objs = (slayer,migrate (sceneaccum_coordinate_system sceneaccum) root_coordinate_system scobj) : sceneaccum_objs sceneaccum }
instance (ScenicAccumulator sa) => ScenicAccumulator (a,sa) where
accumulateScene slayer scobj (a,sceneaccum) = (a,accumulateScene slayer scobj sceneaccum)
null_scene_accumulator :: SceneAccumulator
null_scene_accumulator = SceneAccumulator [] root_coordinate_system
sceneObject :: IO IntermediateModel -> SceneObject
sceneObject = cameraRelativeSceneObject . const . liftM wrapAffine
cameraRelativeSceneObject :: (Camera -> IO (WrappedAffine IntermediateModel)) -> SceneObject
cameraRelativeSceneObject = Model
lightSource :: LightSource -> SceneObject
lightSource = LightSource
accumulateSceneM :: (ScenicAccumulator sa,Monad m,MonadState sa m) => SceneLayer -> SceneObject -> m ()
accumulateSceneM slayer scobj = modify (accumulateScene slayer scobj)
accumulateSceneA :: (ScenicAccumulator sa,Arrow arr,ArrowState sa arr) => arr (SceneLayer,SceneObject) ()
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 Scene = Scene {
scene_infinite_opaques :: [(WrappedAffine IntermediateModel,[LightSource])],
scene_infinite_transparents :: [(WrappedAffine IntermediateModel,[LightSource])],
scene_local_opaques :: [(WrappedAffine IntermediateModel,[LightSource])],
scene_local_transparents :: [(WrappedAffine IntermediateModel,[LightSource])],
scene_camera :: Camera }
assembleScene :: Camera -> SceneAccumulator -> IO Scene
assembleScene c sceneaccum =
do infinite_models <- liftM (map splitOpaquesWrapped . catMaybes) $ mapM toModel infinites
local_models <- liftM (map splitOpaquesWrapped . catMaybes) $ mapM toModel locals
return $ Scene {
scene_infinite_opaques = map (\m -> (fst m,infinite_light_sources)) infinite_models,
scene_infinite_transparents = map (\m -> (m,infinite_light_sources)) $ sortModels origin_point_3d $ concatMap snd infinite_models,
scene_local_opaques = map (\m -> (fst m,local_light_sources)) local_models,
scene_local_transparents = map (\m -> (m,local_light_sources)) $ sortModels (camera_position c) $ concatMap snd local_models,
scene_camera = c }
where infinites = map snd $ filter ((Infinite ==) . fst) $ sceneaccum_objs sceneaccum
locals = map snd $ filter ((Local ==) . fst) $ sceneaccum_objs sceneaccum
infinite_light_sources = mapMaybe toLightSource infinites
local_light_sources = map makeInfinite infinite_light_sources ++ mapMaybe toLightSource locals
sortModels :: Point3D -> [WrappedAffine IntermediateModel] -> [WrappedAffine IntermediateModel]
sortModels p = map fst . sortBy (comparing $ negate . minimalDistanceToBoundingBox p . snd) .
map (\(wa@(WrappedAffine cs m)) -> (wa,migrate cs root_coordinate_system $ boundingBox m))
splitOpaquesWrapped (WrappedAffine a m) =
let (opaques,transparents) = splitOpaques m
in (WrappedAffine a opaques,map (WrappedAffine a) transparents)
toLightSource so = case so of
LightSource ls -> Just ls
_ -> Nothing
toModel so = case so of
Model m -> liftM Just (m c)
_ -> return Nothing
sceneToOpenGL :: Double -> (Double,Double) -> Scene -> IO ()
sceneToOpenGL aspect_ratio nearfar scene =
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 infiniteCameraToOpenGL aspect_ratio nearfar (scene_camera scene)
mapM_ render1Object (scene_infinite_opaques scene)
depthMask $= Disabled
mapM_ render1Object (scene_infinite_transparents scene)
depthMask $= Enabled
clear [DepthBuffer]
preservingMatrix $
do cameraToOpenGL aspect_ratio nearfar (scene_camera scene)
mapM_ render1Object (scene_local_opaques scene)
depthMask $= Disabled
mapM_ render1Object (scene_local_transparents scene)
depthMask $= Enabled
lightModelAmbient $= save_light_model_ambient
lighting $= save_lighting
depthMask $= save_depth_mask
depthFunc $= save_depth_func
cullFace $= save_cull_face
rescaleNormal $= save_rescale_normal
render1Object :: (WrappedAffine IntermediateModel,[LightSource]) -> IO ()
render1Object (WrappedAffine m imodel,lss) =
do setLightSources lss
transformation (migrate m root_coordinate_system) $ intermediateModelToOpenGL imodel
\end{code}