diff --git a/cabal.project b/cabal.project index c94bffa..a74cef7 100644 --- a/cabal.project +++ b/cabal.project @@ -1,2 +1,3 @@ -packages: ./ +packages: + ./ profiling: True diff --git a/shell.nix b/shell.nix index 6fb1dfd..0551a44 100644 --- a/shell.nix +++ b/shell.nix @@ -247,6 +247,7 @@ let random sdl stm text unordered-containers vector pkgconfig ]; enableExecutableProfiling = true; + enableLibraryProfiling = true; license = stdenv.lib.licenses.gpl3; }; diff --git a/src/MainGame/WorldMap.hs b/src/MainGame/WorldMap.hs index aae85b8..df111b7 100644 --- a/src/MainGame/WorldMap.hs +++ b/src/MainGame/WorldMap.hs @@ -15,6 +15,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.State.Strict (evalStateT) import Control.Concurrent.MVar import Control.Concurrent (forkIO) +import Control.Parallel.Strategies hiding (dot) import Data.Map.Strict as Map import qualified Data.Set as S @@ -38,7 +39,6 @@ import Types import Floorplan import MindMap import NPC --- import Object import Animation import Collision @@ -236,10 +236,9 @@ loadMapFork ud ad future progress = do ))) mapM_ (\cpr -> do fact <- liftIO $ randomRIO (0.5, 1.5) - -- fut <- liftIO newEmptyMVar stats <- liftIO $ NPCStats <$> (randomRIO (0, 1)) - <*> (randomRIO (0, 1)) + <*> pure 0 <*> (randomRIO (0, 1)) <*> (randomRIO (0, 1)) <*> (randomRIO (0, 1)) @@ -266,7 +265,6 @@ loadMapFork ud ad future progress = do ( p + increment , "Registering doors into WorldState" ))) - -- let doors = Prelude.filter ((\t -> t == RoomExit || t == Elevator) . pointType) rps mapM_ (\door -> do let rooms = Prelude.foldl (\acc coord -> @@ -340,37 +338,6 @@ loadMapFork ud ad future progress = do , roomGraph = gr }) --- mouseToPlayer :: V2 Int32 -> Affection UserData () --- mouseToPlayer mv2 = do --- ud <- getAffection --- (V2 rx ry) <- liftIO $ relativizeMouseCoords mv2 --- (nws, _) <- yieldSystemT (worldState ud) $ --- emap allEnts $ do --- with player --- return $ unchanged --- { xyvel = Set $ V2 rx ry --- } --- putAffection ud --- { worldState = nws --- } --- --- movePlayer :: MouseMessage -> Affection UserData () --- movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] m _) = mouseToPlayer m --- movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) = --- mouseToPlayer m --- movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do --- ud <- getAffection --- (nws, _) <- yieldSystemT (worldState ud) $ --- emap allEnts $ do --- with player --- return $ unchanged --- { xyvel = Set $ V2 0 0 --- } --- putAffection ud --- { worldState = nws --- } --- movePlayer _ = return () - movePlayerKbd :: KeyboardMessage -> Affection UserData () movePlayerKbd (MsgKeyboardEvent _ _ press False sym) | SDL.keysymKeycode sym == SDL.KeycodeW = do @@ -648,10 +615,36 @@ drawMap = do closePath ctx fillColor ctx (rgb 255 255 255) fill ctx - mapM_ (\(i, ls) -> mapM_ - (\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t) - (reverse $ zip [1..] ls)) - (zip [1..] (toLists mat)) + let coordList = concatMap + (\(i, ls) -> Prelude.map + (\(j, t) -> ((i, j), t)) + (reverse $ zip [1..] ls) + ) + (zip [1..] (toLists mat)) + filterList = Prelude.filter + (\((frow, fcol), tile) -> + ((realToFrac (sx frow fcol) > -tileWidth && + realToFrac (sy frow fcol) > -tileHeight) && + ((realToFrac (sx frow fcol) :: Double) < 1280 && + (realToFrac ((sy frow fcol)- (74 - (realToFrac tileHeight :: CFloat))) :: Double) < 720)) + ) + coordList + !posanimList = Prelude.map + (\((row, col), tile) -> ((row, col), tile, partposanims M.! (row, col))) + filterList + sx row col = realToFrac $ 640 + ((fromIntegral col - pc) + + (fromIntegral row - pr)) * (tileWidth / 2) :: CFloat + sy row col = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) - + (fromIntegral col - pc)) * (tileHeight / 2) :: CFloat + void $ sequence $ parMap rpar + (\((row, col), tile, posanim) -> + drawTile ud ctx posanim pr pc row col tile + ) + posanimList + -- void $ sequence $ parMap rpar (\(i, ls) -> void $ sequence $ parMap rpar + -- (\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t) + -- (reverse $ zip [1..] ls)) + -- (zip [1..] (toLists mat)) mapM_ (\(V2 sr sc, pa, perc) -> when pa $ do let lx = realToFrac $ 640 + ((sc - pc) + (sr - pr)) * (tileWidth / 2) :: CFloat @@ -691,24 +684,21 @@ drawTile -> Maybe ImgId -> IO () drawTile ud ctx posanims pr pc row col img = - when ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) && - ((realToFrac x :: Double) < 1280 && - (realToFrac (y - (74 - (realToFrac tileHeight :: CFloat))) :: Double) < 720)) $ - do - let (bef, beh) = L.partition delimiter sorted - save ctx - mapM_ drawAnim beh - maybe (return ()) (draw ud x (y - 42) 64 74 fact) - ((assetImages ud Map.!) <$> case img of - Just ImgEmpty -> Nothing - _ -> img - ) - mapM_ drawAnim bef - restore ctx - -- when (floor pr == row && floor pc == col) $ do - -- A.logIO A.Debug ("sorted: " ++ show sorted) - -- A.logIO A.Debug ("beh: " ++ show beh) - -- A.logIO A.Debug ("bef: " ++ show bef) + do + let (bef, beh) = L.partition delimiter sorted + save ctx + mapM_ drawAnim beh + maybe (return ()) (draw ud x (y - 42) 64 74 fact) + ((assetImages ud Map.!) <$> case img of + Just ImgEmpty -> Nothing + _ -> img + ) + mapM_ drawAnim bef + restore ctx + -- when (floor pr == row && floor pc == col) $ do + -- A.logIO A.Debug ("sorted: " ++ show sorted) + -- A.logIO A.Debug ("beh: " ++ show beh) + -- A.logIO A.Debug ("bef: " ++ show bef) where delimiter (V2 nr nc, as, mbnds) = animFloats (asId as) || @@ -729,8 +719,6 @@ drawTile ud ctx posanims pr pc row col img = nnc = case mbnds of Just (Boundaries (_, minc) (_, _)) -> minc Nothing -> nc - fromIntegral ((floor nc) :: Int) :: Double - -- any (\m -> nr < fromIntegral (floor nr :: Int) + m) maxrs && - -- any (\m -> nc > fromIntegral (floor nc :: Int) + m) mincs tileWidth = 64 :: Double tileHeight = 32 :: Double sorted = sortOn (\(V2 sr sc, _, mbnds) -> @@ -744,7 +732,6 @@ drawTile ud ctx posanims pr pc row col img = (sr - (fromIntegral ((floor sr) :: Int))) (sc - (fromIntegral ((floor sc) :: Int))) ) posanims - -- sorted = posanims minrs = Prelude.map (fst . matmin) mb maxrs = Prelude.map (fst . matmax) mb mincs = Prelude.map (snd . matmin) mb @@ -770,8 +757,7 @@ drawTile ud ctx posanims pr pc row col img = updateMap :: Double -> Affection UserData () updateMap dt = do ud <- getAffection - -- empty <- liftIO $ isEmptyMVar (stateMVar ud) - if stateData ud == None -- && empty + if stateData ud == None then do mstart <- liftIO $ tryTakeMVar (stateMVar ud) case mstart of @@ -789,49 +775,6 @@ updateMap dt = do Nothing -> return () else do (nws, _) <- yieldSystemT (worldState ud) $ do - emap allEnts $ do - with player - with xyvel - with vel - V2 rx ry <- query xyvel - let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45) - return $ unchanged - { vel = Set $ 2 * V2 dr dc - } - emap allEnts $ do - with anim - stat <- query anim - let an = assetAnimations ud Map.! asId stat - ntime = asElapsedTime stat + dt - nstate = if ntime > fromIntegral (asCurrentFrame stat + 1) * - (animDuration an / fromIntegral (length $ animSprites an)) - then - let nframe = asCurrentFrame stat + 1 - in case animPlay an of - APLoop -> - let (nnframe, nntime) = - if nframe >= length (animSprites an) - then (0, 0) - else (nframe, ntime) - in stat - { asCurrentFrame = nnframe - , asElapsedTime = nntime - } - APOnce -> - let nnframe = if nframe >= length (animSprites an) - then nframe - 1 - else nframe - in stat - { asCurrentFrame = nnframe - , asElapsedTime = ntime - } - else - stat - { asElapsedTime = ntime - } - return $ unchanged - { anim = Set nstate - } obstacleBounds <- efor allEnts $ do with obstacle with pos @@ -839,18 +782,15 @@ updateMap dt = do pos' <- query pos return (pos', b) emap allEnts $ do - without player - with vel - with velFact - with pos - with rot - with anim pos'@(V2 pr pc) <- query pos - vel' <- query vel + vel' <- queryMaybe vel rot' <- query rot - fact' <- query velFact + fact' <- fromMaybe 1 <$> queryMaybe velFact + xyv2 <- queryMaybe xyvel stat <- query anim - let npos = pos' + fmap (* (dt * fact')) vel' + let an = assetAnimations ud Map.! asId stat + ntime = asElapsedTime stat + dt + npos = pos' + fmap (* (dt * fact')) (fromMaybe (V2 0 0) vel') dpos@(V2 dpr dpc) = npos - pos' aId = asId stat lll = (,) @@ -889,132 +829,80 @@ updateMap dt = do ) lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll) ) - nstat = case aiName aId of - "walking" - | sqrt (vel' `dot` vel') > 0 -> - stat - { asId = aId - { aiDirection = fromMaybe rot' (direction vel') - } - } - | otherwise -> - stat - { asId = aId - { aiDirection = fromMaybe rot' (direction vel') - , aiName = "standing" - } - , asCurrentFrame = 0 - } - "standing" - | sqrt (vel' `dot` vel') > 0 -> - stat - { asId = aId - { aiDirection = fromMaybe rot' (direction vel') - , aiName = "walking" - } - , asCurrentFrame = 0 - } - | otherwise -> - stat - { asId = aId - { aiDirection = fromMaybe rot' (direction vel') - } - } - x -> error ("unknown animation name" ++ x) + nstate = + let velo = fromMaybe (V2 0 0) vel' + nstat = if ntime > fromIntegral (asCurrentFrame stat + 1) * + (animDuration an / fromIntegral (length $ animSprites an)) + then + let nframe = asCurrentFrame stat + 1 + in case animPlay an of + APLoop -> + let (nnframe, nntime) = + if nframe >= length (animSprites an) + then (0, 0) + else (nframe, ntime) + in stat + { asCurrentFrame = nnframe + , asElapsedTime = nntime + } + APOnce -> + let nnframe = if nframe >= length (animSprites an) + then nframe - 1 + else nframe + in stat + { asCurrentFrame = nnframe + , asElapsedTime = ntime + } + else + stat + { asElapsedTime = ntime + } + in + case aiName aId of + "walking" + | sqrt (velo `dot` velo) > 0 -> + nstat + { asId = aId + { aiDirection = fromMaybe rot' (direction velo) + } + } + | otherwise -> + nstat + { asId = aId + { aiDirection = fromMaybe rot' (direction velo) + , aiName = "standing" + } + , asCurrentFrame = 0 + } + "standing" + | sqrt (velo `dot` velo) > 0 -> + nstat + { asId = aId + { aiDirection = fromMaybe rot' (direction velo) + , aiName = "walking" + } + , asCurrentFrame = 0 + } + | otherwise -> + nstat + { asId = aId + { aiDirection = fromMaybe rot' (direction velo) + } + } + x -> nstat ent = unchanged - { pos = Set $ pos' + colldpos - , rot = Set $ fromMaybe rot' (direction vel') - , anim = Set nstat + { pos = Set $ pos' + colldpos + , rot = Set $ fromMaybe rot' (direction (fromMaybe (V2 0 0) vel')) + , anim = Set nstate + , vel = case xyv2 of + Just (V2 rx ry) -> + let + V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45) + in + Set $ 2 * V2 dr dc + Nothing -> Keep } return ent - emap allEnts $ do - with player - with vel - with pos - with rot - with anim - pos'@(V2 pr pc) <- query pos - vel' <- query vel - rot' <- query rot - stat <- query anim - let npos = pos' + fmap (* dt) vel' - dpos@(V2 dpr dpc) = npos - pos' - aId = asId stat - nstat = case aiName aId of - "walking" - | sqrt (colldpos `dot` colldpos) > 0 -> - stat - { asId = aId - { aiDirection = fromMaybe rot' (direction vel') - } - } - | otherwise -> - stat - { asId = aId - { aiDirection = fromMaybe rot' (direction vel') - , aiName = "standing" - } - , asCurrentFrame = 0 - } - "standing" - | sqrt (colldpos `dot` colldpos) > 0 -> - stat - { asId = aId - { aiDirection = fromMaybe rot' (direction vel') - , aiName = "walking" - } - , asCurrentFrame = 0 - } - | otherwise -> - stat - { asId = aId - { aiDirection = fromMaybe rot' (direction vel') - } - } - x -> error ("unknown animation name" ++ x) - lll = (,) - <$> ( - if dpr < 0 - then [(floor dpr :: Int) .. 0] - else [0 .. (ceiling dpr :: Int)]) - <*> ( - if dpc < 0 - then [(floor dpc :: Int) .. 0] - else [0 .. (ceiling dpc :: Int)]) - colldpos = dpos * Prelude.foldl - (\acc a -> - let ret = checkBoundsCollision2 pos' npos dt acc a - in A.log A.Verbose (show ret) ret) - (V2 1 1) - ( - concatMap - (\(dr, dc) -> - let bs = (++) - (maybe [] collisionObstacle (fromMaybe Nothing $ M.safeGet - (fromIntegral $ floor pr + dr) - (fromIntegral $ floor pc + dc) - (imgMat (stateData ud)))) - (Prelude.map snd $ Prelude.filter - (\((V2 br bc), _) -> - floor pr + dr == floor br && - floor pc + dc == floor bc - ) - obstacleBounds) - in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))-> - Boundaries - (minr + fromIntegral dr, minc + fromIntegral dc) - (maxr + fromIntegral dr, maxc + fromIntegral dc) - ) bs - ) - lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll) - ) - ent = unchanged - { pos = Set $ pos' + colldpos - , rot = Set (fromMaybe rot' $ direction vel') - , anim = Set nstat - } - -- liftIO $ A.logIO A.Debug ("player position: " ++ show (pos' + colldpos)) - return ent allRelEnts <- efor allEnts $ do with pos with rot @@ -1046,33 +934,3 @@ updateMap dt = do putAffection ud { worldState = nws2 } - --- checkBoundsCollision2 --- :: V2 Double --- -> V2 Double --- -> Double --- -> V2 Double --- -> Boundaries Double --- -> V2 Double --- checkBoundsCollision2 --- pre@(V2 pr pc) nex dt acc (Boundaries (minr, minc) (maxr, maxc)) --- | colltr < dt && colltc < dt = V2 0 0 --- | colltr < dt = V2 0 0 --- | colltc < dt = V2 0 0 --- | otherwise = acc --- where --- V2 vr vc = fmap (/ dt) (nex - pre) --- colltr --- | vr > 0 && prr <= maxr && (prc + 0.15 >= minc && prc - 0.15 <= maxc) = --- ((fromIntegral (floor pr :: Int) + minr - 0.15) - pr) / vr --- | vr < 0 && prr >= minr && (prc + 0.15 >= minc && prc - 0.15 <= maxc) = --- ((fromIntegral (floor pr :: Int) + maxr + 0.15) - pr) / vr --- | otherwise = dt --- colltc --- | vc > 0 && prc <= maxc && (prr + 0.15 >= minr && prr - 0.15 <= maxr) = --- ((fromIntegral (floor pc :: Int) + minc - 0.15) - pc) / vc --- | vc < 0 && prc >= minc && (prr + 0.15 >= minr && prr - 0.15 <= maxr) = --- ((fromIntegral (floor pc :: Int) + maxc + 0.15) - pc) / vc --- | otherwise = dt --- prr = pr - fromIntegral (floor pr :: Int) --- prc = pc - fromIntegral (floor pc :: Int) diff --git a/src/NPC.hs b/src/NPC.hs index 5c7173c..7d13f17 100644 --- a/src/NPC.hs +++ b/src/NPC.hs @@ -233,7 +233,7 @@ updateStats dt = else min 1 (conc + 0.1 * dt) , statBladder = if food > 0 || drin > 0 - then min 1 (blad + 0.3 * dt) + then min 1 (blad + 0.01 * dt) else blad , statThirst = min 1 (if drin > 0 then thir else thir + 0.2 * dt) , statHunger = min 1 (if food > 0 then hung else hung + 0.1 * dt) diff --git a/src/Object/Copier.hs b/src/Object/Copier.hs index 93a1888..36aaaed 100644 --- a/src/Object/Copier.hs +++ b/src/Object/Copier.hs @@ -7,14 +7,24 @@ module Object.Copier where import Affection as A import Control.Monad (when) +import Control.Monad.IO.Class import Data.Ecstasy import Data.Maybe +import Data.String (IsString(..)) import Linear import Types +copierObjectAction + :: (Monad m, MonadIO m, ActionTime ObjType ObjState) + => [(Ent, V2 Double, Direction, Word)] + -> Double + -> ObjType + -> ObjState + -> Ent + -> SystemT Entity m () copierObjectAction _ dt t@ObjCopier s@"copying" ent = do emap (anEnt ent) $ do mtime <- queryMaybe objStateTime @@ -38,6 +48,14 @@ copierObjectAction _ dt t@ObjCopier s@"copying" ent = do copierObjectAction _ _ _ _ _ = return () +copierObjectTransition + :: (Eq a, IsString a, MonadIO m) + => ObjType + -> a + -> Bool + -> Ent + -> Maybe Ent + -> SystemT Entity m (Entity 'SetterOf) copierObjectTransition ObjCopier "idle" playerActivated ent (Just aent) = do e <- efor (anEnt ent) $ do let nstat = AnimState diff --git a/tracer-game.cabal b/tracer-game.cabal index 66e2634..c766bcc 100644 --- a/tracer-game.cabal +++ b/tracer-game.cabal @@ -78,6 +78,7 @@ executable tracer-game , bytestring , algebraic-graphs , mtl + , parallel hs-source-dirs: src ghc-options: -Wall -threaded default-language: Haskell2010