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