module Graphics.SceneGraph.Render
(
drawSceneGraph,applyTransform
) where
import Graphics.Rendering.OpenGL hiding (Red, Green,Blue,Light,light,Texture)
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.UI.GLUT hiding (Red, Green,Blue,Light,light,Texture,Text)
import Graphics.UI.GLUT.Fonts
import Data.Graph.Inductive.Graph
import Data.Array
import qualified Data.Map as M
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import System.Time
import Data.Word
import Data.List ( transpose )
import Graphics.SceneGraph.Basic
import Graphics.SceneGraph.Matrix
import Graphics.SceneGraph.Textures
import Graphics.SceneGraph.Vector as V
import Numeric.LinearAlgebra (toLists,toList)
import Foreign ( withArray )
import qualified Data.Foldable as F
drawSceneGraph :: M.Map String TextureObject -> (SceneGraph, Node) -> IO ()
drawSceneGraph texMap (gr,n) = do
let node = llab gr n
case node of
(SceneNode _ (MatrixTransform tm)) -> do
preservingMatrix $ do
(m::GLmatrix GLdouble) <- newMatrix RowMajor (concat $ toLists tm)
multMatrix m
drawSceneGraphTheRest gr n
(SceneNode _ (Switch sw) ) -> do
let children = suc gr n
drawSceneGraph texMap (gr, (children!!sw))
(SceneNode _ (Material ph)) -> do
applyPhong ph
drawSceneGraphTheRest gr n
(SceneNode _ (Texture texNameS) ) -> do
GL.texture Texture2D $= Enabled
textureFunction $= Decal
textureBinding Texture2D $= M.lookup texNameS texMap
drawSceneGraphTheRest gr n
GL.texture Texture2D $= Disabled
(SceneNode _ (Text s)) -> do
preservingMatrix $ renderString Roman s
_ -> do
drawSceneNode node
drawSceneGraphTheRest gr n
where drawSceneGraphTheRest gr n = mapM_ ( (curry (drawSceneGraph texMap) ) gr) (suc gr n)
applyPhong (Phong e a d sp ss _ _ _ _) = do
maybeIO e setMaterialEmission
maybeIO a setMaterialAmbient
maybeIO d setMaterialDiffuse
maybeIO sp setMaterialSpecular
maybeIO ss setMaterialShininess
where setMaterialEmission c = materialEmission Front $= c
setMaterialAmbient c = materialAmbient Front $= c
setMaterialDiffuse c= materialDiffuse Front $= c
setMaterialSpecular c= materialSpecular Front $= c
setMaterialShininess c= materialShininess Front $= c
applyTransform (SceneNode _ (MatrixTransform tm)) = do
(m::GLmatrix GLdouble) <- newMatrix RowMajor (concat $ toLists tm)
multMatrix m
applyTransform _ = return ()
drawSceneNode :: SceneNode -> IO ()
drawSceneNode (SceneNode (n,_) d ) = do
loadName( Name $ toEnum n)
drawSceneData d
drawSceneData (Geode geom) = drawGeometry geom
drawSceneData Light = do
(m::GLmatrix GLfloat) <- get $ matrix Nothing
mc <- getMatrixComponents ColumnMajor m
let mc' = drop 12 mc
lighting $= Enabled
position (GL.Light 0) $= Vertex4 0 0 10 1
ambient (GL.Light 0) $= Color4 1 1 1 1
diffuse (GL.Light 0) $= Color4 1 1 1 1
specular (GL.Light 0) $= Color4 1 1 1 1
GL.light (GL.Light 0) $= Enabled
drawSceneData _ = return ()
drawGeometry (GLObj o) = renderObject Solid o
drawGeometry (Mesh1 primset vs ns) = mapM_ (drawMesh1 vs ns) primset
drawGeometry (Mesh2 primset vs ) = mapM_ (drawMesh2 vs ) primset
drawGeometry (BezierMesh patch) = mapM_ drawPatch patch
ctrlPoints :: [[Vertex3 GLfloat]]
ctrlPoints = [
[ Vertex3 (1.5) (1.5) 4.0, Vertex3 (0.5) (1.5) 2.0,
Vertex3 0.5 (1.5) (1.0), Vertex3 1.5 (1.5) 2.0 ],
[ Vertex3 (1.5) (0.5) 1.0, Vertex3 (0.5) (0.5) 3.0,
Vertex3 0.5 (0.5) 0.0, Vertex3 1.5 (0.5) (1.0) ],
[ Vertex3 (1.5) 0.5 4.0, Vertex3 (0.5) 0.5 0.0,
Vertex3 0.5 0.5 3.0, Vertex3 1.5 0.5 4.0 ],
[ Vertex3 (1.5) 1.5 (2.0), Vertex3 (0.5) 1.5 (2.0),
Vertex3 0.5 1.5 0.0, Vertex3 1.5 1.5 (1.0) ]]
for :: GLfloat -> GLfloat -> (GLfloat -> IO ()) -> IO ()
for s e f = mapM_ f [ i | i <- [ s, if s <= e then s + 1 else s 1 .. e ] ]
drawPatch patch = do
m <- newMap2 (0, 1) (0, 1) patch
map2 $= Just (m :: GLmap2 Vertex3 GLfloat)
t <- newMap2 (0, 1) (0, 1) ( texPts)
map2 $= Just (t :: GLmap2 TexCoord2 GLfloat)
autoNormal $= Enabled
mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat)))
textureFunction $= Decal
textureWrapMode Texture2D S $= (Repeated, Repeat)
textureWrapMode Texture2D T $= (Repeated, Repeat)
textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
GL.texture Texture2D $= Enabled
depthFunc $= Just Less
shadeModel $= Flat
evalMesh2 Fill (0, 20) (0, 20)
where
(texPts :: [[TexCoord2 GLfloat]]) = [
[ TexCoord2 0 0, TexCoord2 0 1 ],
[ TexCoord2 1 0, TexCoord2 1 1 ]]
withImage :: (PixelData (Color3 GLubyte) -> IO ()) -> IO ()
withImage act =
withArray [ Color3 (s (sin ti)) (s (cos (2 * tj))) (s (cos (ti + tj))) |
i <- [ 0 .. fromIntegral w 1 ],
let ti = 2 * pi * i / fromIntegral w,
j <- [ 0 .. fromIntegral h 1 ],
let tj = 2 * pi * j / fromIntegral h ] $ act . PixelData RGB UnsignedByte
(TextureSize2D w h) = imageSize
s :: Double -> GLubyte
s x = truncate (127 * (1 + x))
imageSize = TextureSize2D 64 64
drawMesh1 vs ns (pmode, start, length) = do
t <- timeGetTime
unsafeRenderPrimitive pmode (F.mapM_ (\(v,n) -> do
let (x'::Int) = round x
y' = round y
[x,y,z] = toList v
[nx,ny,nz] = toList n
texCoord (TexCoord2 ((i2d $ x' `mod` 2)) ((i2d $ y' `mod` 2)))
vertex (Vertex3 x z (y))
normal (Normal3 nx nz (ny))) (zip vs ns))
t2 <- timeGetTime
return ()
drawMesh2 :: (Array Int (VectorD,VectorD,Maybe (VectorD))) -> (PrimitiveMode, Int,Int) -> IO ()
drawMesh2 vs (pmode, start, length) = do
t <- timeGetTime
unsafeRenderPrimitive pmode (F.mapM_ (\(v,n,t) -> do
let [x,y,z] = toList v
[nx,ny,nz] = toList n
normal $ Normal3 nx nz (ny)
vertex $ Vertex3 x z (y)
) vs)
t2 <- timeGetTime
return ()
i2d :: Int -> Float
i2d = fromIntegral
putStrLnD s = return ()
rootNode gr = llab gr 1
maybeIO :: Maybe a -> (a -> IO ()) -> IO ()
maybeIO x f = case x of
Nothing -> return ()
Just x' -> f x'
timeGetTime :: IO Word32
timeGetTime = do
System.Time.TOD sec psec <- System.Time.getClockTime
return (fromIntegral $ sec * 1000 + psec `div` 1000000000)