module CallyCommon
(meshFiles
, loadCallyCoreModel
, newCallyInstance
-- , skinThread
, baseMatlSet
, logging, loggingRequire, require -- at least temporarily
, CallyCoreModel(..)
, faceStride, vtxStride, normStride
, renderModel, renderMesh, renderSubmesh
, RenderInfo(..), riNormCount, RenderAction
)
where
import Control.Monad
import Foreign
import Graphics.Rendering.OpenGL
import Graphics.Animation.Cal3D
import Graphics.Animation.Cal3D.OpenGL
import Paths_cal3d_examples (getDataDir) -- generated by Cabal
skeletonFile = "cally.csf"
meshFiles :: [FilePath]
meshFiles = ["cally_calf_left.cmf",
"cally_calf_right.cmf",
"cally_chest.cmf",
"cally_foot_left.cmf",
"cally_foot_right.cmf",
"cally_hand_left.cmf",
"cally_hand_right.cmf",
"cally_head.cmf",
"cally_lowerarm_left.cmf",
"cally_lowerarm_right.cmf",
"cally_neck.cmf",
"cally_pelvis.cmf",
"cally_ponytail.cmf",
"cally_thigh_left.cmf",
"cally_thigh_right.cmf",
"cally_upperarm_left.cmf",
"cally_upperarm_right.cmf"]
materialFiles :: [FilePath]
materialFiles = ["cally_skin.xrf"
, "cally_ponytail.xrf"
, "cally_chest.xrf"
, "cally_pelvis.xrf"]
animFiles :: [FilePath]
animFiles = ["cally_idle.caf"
, "cally_tornado_kick.caf"
, "cally_walk.caf"
, "cally_strut.caf"
, "cally_jog.caf"
, "cally_shoot_arrow.caf"
, "cally_wave.caf"]
-- skinThread = MaterialThreadId 0
baseMatlSet = MaterialSetId 0
data CallyCoreModel =
CallyCoreModel { callyCoreModel :: CoreModel
, jogAnim, idleAnim :: AnimationId
, meshes :: [MeshId]}
loadCallyCoreModel :: Bool -> IO CallyCoreModel
loadCallyCoreModel verbose = do
{
-- Find out where Cabal installed data files
dataDir <- getDataDir
; let dataFile :: FilePath -> FilePath
dataFile fileName = dataDir ++ "/data/" ++ fileName
-- A. Create core model
; coreModel <- newCoreModel "basic coreModel"
; putStrLn "Created coreModel"
-- Give it exactly one skeleton
; require 1 "load skeleton file"
(loadCoreSkeleton coreModel (dataFile skeletonFile))
-- Load some animations
; idle <- require 2 "load idle animation"
(loadCoreAnimation coreModel (dataFile "cally_idle.caf"))
; jog <- require 3 "load jog animation"
(loadCoreAnimation coreModel (dataFile "cally_jog.caf"))
-- Load some meshes.
-- *All* of these need to be loaded; otherwise we get segfault.
; coreMeshes <- (mapM (\ (n, file) ->
require n ("load " ++ file)
(loadCoreMesh coreModel (dataFile file)))
(zip [10..] meshFiles))
:: IO [MeshId]
; print ("core meshes:", coreMeshes)
-- Load a material
; materials <- (mapM (\ (n, file) ->
require n ("load " ++ file)
(loadCoreMaterial coreModel
(dataFile file)))
(zip [30..] materialFiles))
:: IO [MaterialId]
-- ***
-- Skip all textures
-- (actually, there aren't any in the data files)
-- ...
-- Create "material threads"
-- ; require 27 "create material thread"
-- (createCoreMaterialThread coreModel skinThread)
-- Assign material to thread/set pair(s)
; mapM (\ matl@(MaterialId id) -> do
{
let mthread = MaterialThreadId (fromIntegral id)
; createCoreMaterialThread coreModel mthread
; setCoreMaterialId coreModel mthread baseMatlSet matl
})
materials
-- ; setCoreMaterialId coreModel skinThread baseMatlSet skinMatl
; return CallyCoreModel { callyCoreModel = coreModel
, jogAnim = jog
, idleAnim = idle
, meshes = coreMeshes
}
}
newCallyInstance :: CallyCoreModel -> Bool -> IO Model
newCallyInstance callyCore verbose = do
{
-- B. Create model instance(s)
model <- newModel (callyCoreModel callyCore)
-- Attach meshes to model
; mapM_ (\ (n, meshId) -> require n
("attach mesh " ++ show meshId ++ " to model")
(attachMesh model meshId))
(zip [30..] (meshes callyCore))
-- Set level of detail.
-- Expensive; don't redo unless it changes significantly.
; setLodLevel model 1.0
-- Set the model's material set.
-- You should be able to do this for a particular mesh, as well,
-- but not yet implemented:
-- setMaterialSet (getMesh model leftFootMesh) baseMatlSet
; setMaterialSet model baseMatlSet
; return model
}
loggingRequire :: Bool -> Int -> String -> IO (Either String a) -> IO a
loggingRequire verbose errcode msg action = do
{
logging verbose putStr msg
; eresult <- action
; case eresult of
Left msg ->
do
{
putStrLn ": FATAL ERROR"
; error $ "error " ++ (show errcode) ++ ": " ++ msg
}
Right result ->
do
{
logging verbose putStrLn ": success"
; return result
}
}
logging :: Bool -> (a -> IO ()) -> a -> IO ()
logging verbose action arg =
when verbose (action arg)
require :: Int -> String -> IO (Either String a) -> IO a
require = loggingRequire False
data RenderInfo =
RenderInfo {riMeshId, riSubmeshId :: Int
, riAmbient, riDiffuse, riSpecular :: Color4 GLfloat
, riShininess :: Float
, riFaceCount, riVtxCount :: Int
, riFaceBuf :: Ptr CalIndex
, riVtxBuf, riNormBuf :: Ptr Float}
-- Number of normals = number of vertices
riNormCount :: RenderInfo -> Int
riNormCount = riVtxCount
type RenderAction = RenderInfo -> IO ()
-- Render the model (big jog here)
renderModel :: Model -> RenderAction -> IO (Either String ())
renderModel model renderAction = do
{
renderer <- getRenderer model
; renderAnimation renderer $ do
{
-- do here whatever per-frame initialization is needed
-- by the graphics API
-- ...
-- A model has one or more meshes; render each one
meshCount <- getMeshCount renderer
; forM_ [0 .. meshCount - 1] (renderMesh renderer model renderAction)
}
}
-- Render a single mesh
renderMesh :: Renderer -> Model -> RenderAction -> Int -> IO ()
renderMesh renderer model renderAction meshId = do
{
-- A mesh has one or more submeshes;
-- in each submesh, all faces have the same material
submeshCount <- getSubmeshCount renderer meshId
; forM_ [0 .. submeshCount - 1]
(renderSubmesh renderer model renderAction meshId)
}
faceStride, vtxStride, normStride :: Int
faceStride = 3
vtxStride = 3
normStride = 3
renderSubmesh :: Renderer -> Model -> RenderAction -> Int -> Int -> IO ()
renderSubmesh renderer model renderAction meshId submeshId = do
{
selectMeshSubmesh renderer meshId submeshId
-- read the material colors
; ambient <- getAmbientColor renderer
; diffuse <- getDiffuseColor renderer
; specular <- getSpecularColor renderer
; shininess <- getShininess renderer
-- Get face and vertex counts
; faceCount <- getFaceCount renderer
; vtxCount <- getVertexCount renderer
; let normCount = vtxCount
-- Allocate and fill face buffer
; allocaArray (faceCount * faceStride)
(\ faceBuf -> do
{
nfaces <- getFaces renderer faceBuf
-- Allocate and fill vertex buffer
; allocaArray (vtxCount * vtxStride)
(\ vtxBuf -> do
{
-- only stride = 0 works here!
nvtx <- getVertices renderer vtxBuf 0
-- Allocate and fill normal buffer
; allocaArray (normCount * normStride)
(\ normBuf -> do
{
-- only stride = 0 works here:
nNormals <- getNormals renderer normBuf 0
; renderAction RenderInfo { riMeshId = meshId
, riSubmeshId = submeshId
, riAmbient = ambient
, riDiffuse = diffuse
, riSpecular = specular
, riShininess = shininess
, riFaceCount = faceCount
, riVtxCount = vtxCount
, riFaceBuf = faceBuf
, riVtxBuf = vtxBuf
, riNormBuf = normBuf}
}
) -- ends allocated normal buffer
}
) -- ends allocated vertex buffer
}
) -- ends allocated face buffer
} -- ends renderSubmesh
{- ABOVE:
If there were any textures, then the rendering should also do this:
; rendererGetTextureCoordinates renderer 0 texCoordBuf
; textureId <- rendererGetMapUserData renderer 0
-- set the material, vertex, normal, and texture states for the
-- graphics API
-- (to do)
-- ...
-- read face (vertex index) data
; faces <- rendererGetFAces renderer indexBuf
-- call graphics API to render the faces now
-- (to do)
-- ...
-}