module Utils where
import Data.Maybe
import qualified Data.List as List
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import Foreign
import Foreign.C.Types
import Data.IORef ( IORef, newIORef )
import Control.Monad as Monad
import Control.Applicative
--import Graphics.UI.GLFW as GLFW
import Graphics.Rendering.OpenGL as GL
import FRP.Elerea
import Graphics.LambdaCube
driveNetwork network driver = do
dt <- driver
case dt of
Just dt -> do Monad.join $ superstep network dt
driveNetwork network driver
Nothing -> return ()
-- FPS measure code
data State
= State
{ frames :: IORef Int
, t0 :: IORef Double
}
fpsState = do
a <- newIORef 0
b <- newIORef 0
return $ State a b
updateFPS :: State -> Double -> IO ()
updateFPS state t1 = do
let t = 1000*t1
frames state $~! (+1)
t0' <- get (t0 state)
t0 state $= t0' + t
when (t + t0' >= 5000) $ do
f <- get (frames state)
let seconds = (t + t0') / 1000
fps = fromIntegral f / seconds
putStrLn (show f ++ " frames in " ++ show seconds ++ " seconds = "++ show fps ++ " FPS")
t0 state $= 0
frames state $= 0
drawCube = renderPrimitive Quads $ do
-- top of cube
color $ Color3 0 1 (0.0 :: GLfloat)
vertex $ Vertex3 1.0 1.0 (-1.0 :: GLfloat)
vertex $ Vertex3 (-1.0) 1.0 (-1.0 :: GLfloat)
vertex $ Vertex3 (-1.0) 1.0 ( 1.0 :: GLfloat)
vertex $ Vertex3 1.0 1.0 ( 1.0 :: GLfloat)
-- bottom of cube
color $ Color3 1 0.5 (0.0 :: GLfloat)
vertex $ Vertex3 1.0 (-1.0) ( 1.0 :: GLfloat)
vertex $ Vertex3 (-1.0) (-1.0) ( 1.0 :: GLfloat)
vertex $ Vertex3 (-1.0) (-1.0) (-1.0 :: GLfloat)
vertex $ Vertex3 1.0 (-1.0) (-1.0 :: GLfloat)
-- front of cube
color $ Color3 1 0 (0.0 :: GLfloat)
vertex $ Vertex3 1.0 1.0 ( 1.0 :: GLfloat)
vertex $ Vertex3 (-1.0) 1.0 ( 1.0 :: GLfloat)
vertex $ Vertex3 (-1.0) (-1.0) ( 1.0 :: GLfloat)
vertex $ Vertex3 1.0 (-1.0) ( 1.0 :: GLfloat)
-- back of cube.
color $ Color3 1 1 (0.0 :: GLfloat)
vertex $ Vertex3 1.0 (-1.0) (-1.0 :: GLfloat)
vertex $ Vertex3 (-1.0) (-1.0) (-1.0 :: GLfloat)
vertex $ Vertex3 (-1.0) 1.0 (-1.0 :: GLfloat)
vertex $ Vertex3 1.0 1.0 (-1.0 :: GLfloat)
-- left of cube
color $ Color3 0 0 (1.0 :: GLfloat)
vertex $ Vertex3 (-1.0) 1.0 ( 1.0 :: GLfloat)
vertex $ Vertex3 (-1.0) 1.0 (-1.0 :: GLfloat)
vertex $ Vertex3 (-1.0) (-1.0) (-1.0 :: GLfloat)
vertex $ Vertex3 (-1.0) (-1.0) ( 1.0 :: GLfloat)
-- right of cube
color $ Color3 1 0 (1.0 :: GLfloat)
vertex $ Vertex3 1.0 1.0 (-1.0 :: GLfloat)
vertex $ Vertex3 1.0 1.0 ( 1.0 :: GLfloat)
vertex $ Vertex3 1.0 (-1.0) ( 1.0 :: GLfloat)
vertex $ Vertex3 1.0 (-1.0) (-1.0 :: GLfloat)
initGL width height = do
clearColor $= Color4 0 0 0 1
clearDepth $= 1
depthFunc $= Just Less
--depthMask $= Enabled
--shadeModel $= Smooth
cullFace $= Just Back
-- lighting setup
materialAmbient Front $= Color4 0.2 0.2 0.2 1
materialDiffuse Front $= Color4 1 1 1 1
materialSpecular Front $= Color4 0 0 0 0
materialShininess Front $= 0
materialAmbient Back $= Color4 0.2 0.2 0.2 1
materialDiffuse Back $= Color4 1 1 1 1
materialSpecular Back $= Color4 0 0 0 0
materialShininess Back $= 0
GL.position (Light 0) $= Vertex4 20 80 150 1
GL.lighting $= Enabled
GL.light (Light 0) $= Enabled
polygonMode $= (Line,Line)
matrixMode $= Projection
loadIdentity
perspective 45 (width/height) 0.1 200
matrixMode $= Modelview 0
color $ Color4 1 1 1 (1::GLfloat)
resizeGLScene winSize size@(Size w h) = do
winSize (fromIntegral w,fromIntegral h)
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
perspective 45 (fromIntegral w / fromIntegral h) 0.1 1000
matrixMode $= Modelview 0
cameraSignal (sx,sy,sz) mposs keyss = createSignal $ transfer (Vec4 sx sy sz 0, Vec4 1 0 0 0, Vec4 0 1 0 0,(-pi * 50,0)) calcCam ((,) <$> mposs <*> keyss)
where
dir cx cy = (vec4xmat44 (Vec4 0 0 (-1) 0) $ rotX (cy) <> rotY (cx),vec4xmat44 (Vec4 0 1 0 0) $ rotX (cy) <> rotY (cx))
calcCam dt ((dmx,dmy),(ka,kw,ks,kd,turbo)) (p0,_,_,(mx,my)) = (p4,d,u,(mx',my'))
where
p1 = if ka then p0 `vec4addvec4` (v `vec4xscalar` t) else p0
p2 = if kw then p1 `vec4addvec4` (d `vec4xscalar` (-t)) else p1
p3 = if ks then p2 `vec4addvec4` (d `vec4xscalar` t) else p2
p4 = if kd then p3 `vec4addvec4` (v `vec4xscalar` (-t)) else p3
k = if turbo then 10 else 1
t = k * realToFrac dt
mx' = dmx + mx
my' = dmy + my
(d,u) = dir (mx' / 100) (my' / 100)
v = norm $ d `vec4crossvec4` u
--mkMesh :: String -> [(Matrix4,Mesh)] -> World -> IO World
mkMesh name ml w = do
let sml = concat [[(mat,setVD sm $ msSharedVertexData m) | sm <- msSubMeshList m] | (mat,m) <- ml]
setVD sm svd = case smVertexData sm of
{ Just _ -> sm
; Nothing -> sm { smVertexData = svd }
}
matGrp = groupSetBy (\(_,a) (_,b) -> smMaterialName a == smMaterialName b) sml
geomGrp = concat $ map (groupSetBy declCmp) matGrp
declCmp (_,a) (_,b) = sortDecl a == sortDecl b && smOperationType a == smOperationType b
where
sortDecl sm = List.sort [(veType e, veSemantic e, veIndex e) | e <- vdElementList $ vdVertexDeclaration $ fromJust $ smVertexData sm]
vcnt l = foldl (+) 0 [getNumVertices $ head $ IntMap.elems $ vbbBindingMap $ vdVertexBufferBinding $ fromJust $ smVertexData sm | (_,sm) <- l]
rl = wrResource w
rs = wrRenderSystem w
joinVD l = do
let counts = scanl (+) 0 [getNumVertices $ head $ IntMap.elems $ vbbBindingMap $ vdVertexBufferBinding $ fromJust $ smVertexData sm | (_,sm) <- l]
offs = scanl (\a b -> a + (getTypeSize $ veType b)) 0 d
d = vdElementList $ vdVertexDeclaration $ fromJust $ smVertexData $ snd $ head l
decl = VertexDeclaration [e { veSource = 0, veOffset = o } | (e,o) <- zip d offs]
--vsize = getVertexSize $ head $ IntMap.elems $ vbbBindingMap $ vdVertexBufferBinding $ fromJust $ smVertexData $ head l -- FIXME
vsize = foldl (\a b -> a + (getTypeSize $ veType b)) 0 $ vdElementList $ decl
usage = HBU_STATIC -- TODO
vcount = last counts
material = smMaterialName $ snd $ head l
operation = smOperationType $ snd $ head l
indexCounts = scanl (\a (_,b) -> a + (idIndexCount $ fromJust $ smIndexData b)) 0 l
indexCount = last indexCounts
-- indexCount' = foldl (\a b -> a + (getNumIndexes $ idIndexBuffer $ fromJust $ smIndexData b)) 0 l
idType = if vcount > 0xFFFF then IT_32BIT else IT_16BIT
sortDecl dl = List.sortBy (\a b-> (veType a, veSemantic a, veIndex a) `compare` (veType b, veSemantic b, veIndex b)) dl
sorteddecl = sortDecl $ vdElementList decl
vb <- createVertexBuffer rs vsize vcount usage True
ptr <- lock vb 0 (getSizeInBytes vb) HBL_NORMAL
-- iterate over subents
-- copy and transform vertex attributes
forM_ (zip counts l) $ \(o,(mat,sm)) -> do
-- TODO
-- filter out VES_BLEND attributes from src and dst declarations (static mesh cant be vertex blended)
-- iterate over each vertex attribute and do copy&transform
let svbs = IntMap.elems $ vbbBindingMap $ vdVertexBufferBinding $ fromJust $ smVertexData sm
srcdecl = sortDecl $ vdElementList $ vdVertexDeclaration $ fromJust $ smVertexData sm
--print sorteddecl
--print srcdecl
sptrs <- forM svbs $ \svb -> lock svb 0 (getSizeInBytes svb) HBL_NORMAL
let copyAttr se de = do
let sptr = sptrs !! (veSource se)
sstride = getVertexSize $ svbs !! (veSource se)
svcount = getNumVertices $ svbs !! (veSource se)
forM_ [0..(svcount-1)] $ \i -> copyArray (advancePtr ptr $ (o+i) * vsize + veOffset de) (advancePtr sptr $ i * vsize + veOffset se) (getTypeSize $ veType se)
rFloat3 = peekArray 3 :: Ptr CFloat -> IO [CFloat]
wFloat3 = pokeArray :: Ptr CFloat -> [CFloat] -> IO ()
transrotAttr se de = do
let sptr = sptrs !! (veSource se)
sstride = getVertexSize $ svbs !! (veSource se)
svcount = getNumVertices $ svbs !! (veSource se)
forM_ [0..(svcount-1)] $ \i -> do
[x,y,z] <- rFloat3 (castPtr $ advancePtr sptr $ i * vsize + veOffset se)
let Vec4 x' y' z' _ = vec4xmat44 (Vec4 (realToFrac x) (realToFrac y) (realToFrac z) 1) mat
wFloat3 (castPtr $ advancePtr ptr $ (o+i) * vsize + veOffset de) [realToFrac x', realToFrac y', realToFrac z']
rotAttr se de = do
let sptr = sptrs !! (veSource se)
sstride = getVertexSize $ svbs !! (veSource se)
svcount = getNumVertices $ svbs !! (veSource se)
forM_ [0..(svcount-1)] $ \i -> do
[x,y,z] <- rFloat3 (castPtr $ advancePtr sptr $ i * vsize + veOffset se)
let Vec4 x' y' z' _ = vec4xmat44 (Vec4 (realToFrac x) (realToFrac y) (realToFrac z) 0) mat
wFloat3 (castPtr $ advancePtr ptr $ (o+i) * vsize + veOffset de) [realToFrac x', realToFrac y', realToFrac z']
forM_ (zip srcdecl sorteddecl) $ \(se,de) -> case veSemantic se of
{ VES_POSITION -> transrotAttr se de
; VES_BLEND_WEIGHTS -> error "invalid semantic"
; VES_BLEND_INDICES -> error "invalid semantic"
; VES_NORMAL -> rotAttr se de
; VES_DIFFUSE -> copyAttr se de
; VES_SPECULAR -> copyAttr se de
; VES_TEXTURE_COORDINATES -> copyAttr se de
; VES_BINORMAL -> rotAttr se de
; VES_TANGENT -> rotAttr se de
}
forM_ svbs $ \svb -> unlock svb
unlock vb
ib <- createIndexBuffer rs idType indexCount usage True
-- print $ "created new index buffer: " ++ show indexCount ++ " " ++ show idType ++ " " ++ show indexCount'
print $ "created new index buffer: " ++ show indexCount ++ " " ++ show idType
-- 1. lock buffer
ptr <- lock ib 0 (getSizeInBytes ib) HBL_NORMAL
-- 2. fill buffer
forM_ (zip3 counts l indexCounts) $ \(o,(_,sm),io) -> do
let sib = idIndexBuffer $ fromJust $ smIndexData sm
cnt = getNumIndexes sib
st = getIndexType sib
r16 = peekElemOff :: Ptr Word16 -> Int -> IO Word16
r32 = peekElemOff :: Ptr Word32 -> Int -> IO Word32
w16 = pokeElemOff :: Ptr Word16 -> Int -> Word16 -> IO ()
w32 = pokeElemOff :: Ptr Word32 -> Int -> Word32 -> IO ()
sptr <- lock sib 0 (getSizeInBytes sib) HBL_NORMAL
print (o,cnt,io)
forM_ [0..(cnt-1)] $ \i -> case (idType,st) of
{ (IT_16BIT,IT_16BIT) -> do
d <- r16 (castPtr sptr) i
w16 (castPtr ptr) (io+i) $ d + fromIntegral o
; (IT_16BIT,IT_32BIT) -> do
d <- r32 (castPtr sptr) i
w16 (castPtr ptr) (io+i) $ fromIntegral d + fromIntegral o
; (IT_32BIT,IT_16BIT) -> do
d <- r16 (castPtr sptr) i
w32 (castPtr ptr) (io+i) $ fromIntegral d + fromIntegral o
; (IT_32BIT,IT_32BIT) -> do
d <- r32 (castPtr sptr) i
w32 (castPtr ptr) (io+i) $ d + fromIntegral o
}
unlock sib
-- 3. unlock buffer
unlock ib
let binding = VertexBufferBinding $ IntMap.fromList [(0,vb)]
vd = VertexData decl binding 0 vcount
idat = IndexData ib 0 indexCount
print decl
print $ "vcount " ++ show vcount ++ " indexCount " ++ show indexCount
return $ SubMesh
{ smOperationType = operation
, smVertexData = Just vd
, smIndexData = Just idat
, smExtremityPoints = undefined -- TODO
, smMaterialName = material
}
print $ "groupNum: " ++ (show $ length geomGrp)
print $ map length geomGrp
print $ foldl (+) 0 $ map length geomGrp
print $ map vcnt geomGrp
print $ foldl (+) 0 $ map vcnt geomGrp
sml' <- mapM joinVD geomGrp
let mesh = Mesh
{ msSubMeshList = sml'
, msSharedVertexData = Nothing
, msSubMeshNameMap = undefined -- TODO
, msBoundRadius = undefined -- TODO
, msSkeletonName = undefined -- TODO
, msVertexBufferUsage = undefined -- TODO
, msIndexBufferUsage = undefined -- TODO
, msVertexBufferShadowBuffer = undefined -- TODO
, msIndexBufferShadowBuffer = undefined -- TODO
}
return w { wrResource = rl { rlMeshMap = Map.insert name mesh (rlMeshMap rl) } }
mkMeshN name nl w0 = do
let f (w,l) (mt,n) = do
(m,w') <- getMesh n w
return (w',(mt,m):l)
(w1,l) <- foldM f (w0,[]) nl
mkMesh name l w1