-- Cally1.hs
-- Cally1 Cal3D example
module Main where
import Foreign
import Control.Monad
import Data.IORef
import Graphics.Rendering.OpenGL as GL
import Graphics.UI.SDL as SDL hiding (flip, update)
import Graphics.Animation.Cal3D
import Graphics.Animation.Cal3D.OpenGL
import CallyCommon
renderScale = 1.0
main :: IO ()
main = do
{
coreModel <- loadCallyCoreModel False
-- B. Create model instance(s)
; model <- newCallyInstance coreModel False
; initSDL initCfg
; initGL initCfg
-- Mix animations.
-- NOTE: In real life, you would not want to do these three
-- without some elapsed time!
-- Set an animation mix, reaching 100% jog after 0.5 second
; mixer <- getMixer model
; require 50 "cycle jog animation"
(blendCycle mixer (jogAnim coreModel) 1.0 0.5)
-- Use clearCycle to "fade out" the jog animation in 3 seconds
-- ; require 51 "clear jog animation cycle"
-- (clearCycle mixer (jogAnim coreModel) 3.0)
-- use executeAction to perform an action once,
-- with delayIn, delayOut, weightTarget, and autoLock arguments
-- ; require 52 "execute idle action"
-- (executeAction mixer (idleAnim coreModel) 2.5 7.5 0.95 True)
-- Initialize and render the model
; update model 0.0 -- time 0
-- ; putStrLn $ "Where is Cally? " ++ (whereIsModel model)
; renderLoop model initCfg
-- Destroy the model
-- Contrary to user guide, there is no "destroy" method.
; deleteModel model
; putStrLn "Model deleted."
; SDL.quit
-- Finish
; return ()
}
-- SDL configuration and initialization
data Config = Config {width, height :: Int32}
initCfg = Config {width = 800, height = 600}
data SDLState = SDLState {sdlWidth, sdlHeight :: Int,
sdlSurface :: Surface,
sdlFullscreen :: Bool}
-- ------------------------------------------------------------------------
-- SDL state and initialization
videoDepth = 32
videoFlags :: Bool -> [SurfaceFlag]
videoFlags fullscreen =
let baseFlags = -- [SDL.OpenGL, Resizable]
[SDL.OpenGL, SDL.SrcAlpha, HWAccel, HWSurface]
-- No effect: DoubleBuf, SDL.SrcAlpha
-- ??: HWAccel, SWSurface, HWSurface
in if fullscreen then Fullscreen : baseFlags else baseFlags
initSDL :: Config -> IO (IORef SDLState)
initSDL cfg = do
{
SDL.init [InitVideo]
; SDL.setCaption "Haskell Cal3d Demo with SDL and OpenGL"
"Cal3d Demo"
-- Set reasonable GL attributes
; glSetAttribute glDoubleBuffer 1
; glSetAttribute glDepthSize 16
; mapM_ ((flip glSetAttribute) 8)
[glRedSize, glGreenSize, glBlueSize, glAlphaSize]
; let w = fromIntegral (width cfg)
h = fromIntegral (height cfg)
; surface <-
SDL.setVideoMode w h videoDepth (videoFlags False)
-- ; enableUnicode True
-- ; enableKeyRepeat 500 30 -- delay, interval
; newIORef (SDLState { sdlWidth = w
, sdlHeight = h
, sdlSurface = surface
, sdlFullscreen = False})
}
-- ------------------------------------------------------------------------
-- OpenGL initialization
initGL :: Config -> IO ()
initGL cfg = do
{
viewport $= (Position 0 0,
Size (fromIntegral (width cfg)) (fromIntegral (height cfg)))
; clearColor $= (Color4 0 0 0.2 1 :: Color4 GLfloat)
; clearDepth $= 1
; depthFunc $= Just Less -- enables depth test
; cullFace $= Just Back
-- Projection
; matrixMode $= Projection
; loadIdentity
; perspective 45.0 -- vertical angle
(fromIntegral (width cfg) /
fromIntegral (height cfg)) -- aspect
0.2 -- near
1000.0 -- far
; matrixMode $= Modelview 0
; loadIdentity
-- Lighting
; lighting $= Enabled
; frontFace $= CCW
; shadeModel $= Smooth
; lightModelAmbient $= Color4 0.15 0.15 0.15 1.0
; colorMaterial $= -- Just (FrontAndBack, Diffuse)
Just (Front, Diffuse) -- implies enabled
-- Light 0
; light (Light 0) $= Enabled
; position (Light 0) $= lightPosition
; ambient (Light 0) $= Color4 0.3 0.3 0.3 1.0
; diffuse (Light 0) $= Color4 0.52 0.5 0.5 1.0
; specular (Light 0) $= Color4 0.1 0.1 0.1 1.0
-- Anti-aliasing
; polygonSmooth $= Enabled
; hint PolygonSmooth $= Fastest
-- Blending (alpha transparency)
; blend $= Enabled
; blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
-- Vertex arrays
; clientState VertexArray $= Enabled
; clientState NormalArray $= Enabled
}
camDist :: (Num a) => a
camDist = 250
cameraPosition :: Vertex3 GLdouble
cameraPosition = Vertex3 camDist (-camDist) (camDist / 10)
lightPosition :: Vertex4 GLfloat
lightPosition =
Vertex4 (camDist + 1) (-camDist - 1) ((camDist / 10) + 1) 1.0
-- ------------------------------------------------------------------------
-- Actual rendering
beginFrame :: Config -> IO ()
beginFrame cfg = do
{
matrixMode $= Modelview 0
; loadIdentity
; clear [ColorBuffer, DepthBuffer]
; let dist = 250
; lookAt cameraPosition (Vertex3 0 0 60) (Vector3 0 0 1)
; return ()
}
endFrame :: IO ()
endFrame = glSwapBuffers
renderLoop :: Model -> Config -> IO ()
renderLoop model cfg = do
{
beginFrame cfg
-- Update the model state, given 0.05 second elapsed time
; update model 0.005
; renderModel model renderBuffers
-- sanity pyramid
; drawPyramidArrayed
; endFrame
; event <- pollEvent
; case event of
KeyDown (Keysym {symKey = SDLK_ESCAPE}) -> return () -- quit
Quit -> return () -- quit
_ -> renderLoop model cfg -- continue
}
renderBuffers :: RenderInfo -> IO ()
renderBuffers info = do
{
materialAmbient Front $= riAmbient info
; materialDiffuse Front $= riDiffuse info
; materialSpecular Front $= riSpecular info
; materialShininess Front $= riShininess info
; renderArrays (3 * (riFaceCount info))
(riVtxBuf info)
(riNormBuf info)
(castPtr (riFaceBuf info)) -- from (Ptr CInt) to (Ptr Int)
}
-- ------------------------------------------------------------------------
-- Pyramid to check sanity
drawPyramidArrayed :: IO ()
drawPyramidArrayed =
let s = 25 -- scale
a = [-s, -s, 0]
b = [s, -s, 0]
c = [s, s, 0]
d = [-s, s, 0]
e = [0, 0, s]
face v1 v2 v3 = concat [v1, v2, v3]
-- vertex data: 6 faces x 3 vertices x 3 coords = 54 floats
vertexData :: [GLfloat]
vertexData = concat [face a b d,
face d b c,
face a b e,
face b c e,
face c d e,
face d a e]
-- normal data: 6 faces x 3 normals x 3 coords = 54 floats
m = 0.5 * sqrt 2
normals :: [[GLfloat]]
normals = [ [0.0, 0.0, (-1.0)] -- normal down
, [0.0, 0.0, (-1.0)]
, [0.0, (-m), m]
, [m, 0.0, m]
, [0.0, m, m]
, [(-m), 0.0, m]
]
normalData = concatMap (normals !!) [0, 0, 0, -- d b a
1, 1, 1, -- c b d
2, 2, 2, -- a b e
3, 3, 3, -- b c e
4, 4, 4, -- c d e
5, 5, 5] -- d a e
n = length vertexData
indexData :: [Int]
indexData = [0..n - 1]
in if (n /= length normalData ||
n /= length indexData)
then error ("vertexData, normalData, indexData: " ++
"lengths must be equal: " ++
show (length vertexData, length normalData,
length indexData))
else do
{
materialAmbientAndDiffuse Front $=
(Color4 0 0 1 0.10 :: Color4 GLfloat) -- trans-blue for debugging
-- (Color4 0 0 0 1 :: Color4 GLfloat)
; materialSpecular Front $= Color4 0 0 0 1
; withArray vertexData
(\ vtxBuf ->
(withArray normalData
(\ normBuf ->
(withArray indexData
(\ indexes ->
renderArrays n vtxBuf normBuf indexes)))))
}
-- Keep
renderArrays :: Int -> Ptr GLfloat -> Ptr GLfloat -> Ptr Int -> IO ()
renderArrays n vtxBuf normBuf indexes =
let vad nc etype stride buf =
VertexArrayDescriptor nc etype stride buf
in do
{
arrayPointer VertexArray $= vad 3 Float 0 vtxBuf
; arrayPointer NormalArray $= vad 3 Float 0 normBuf
; drawElements Triangles (fromIntegral n) UnsignedInt indexes
}