This commit is contained in:
nek0 2019-03-07 01:33:51 +01:00
parent fc57805889
commit 46068b99ab
7 changed files with 108 additions and 250 deletions

View file

@ -1,2 +1,4 @@
packages: ./ packages:
./
../ecstasy/
profiling: True profiling: True

View file

@ -247,6 +247,7 @@ let
random sdl stm text unordered-containers vector pkgconfig random sdl stm text unordered-containers vector pkgconfig
]; ];
enableExecutableProfiling = true; enableExecutableProfiling = true;
enableLibraryProfiling = true;
license = stdenv.lib.licenses.gpl3; license = stdenv.lib.licenses.gpl3;
}; };

View file

@ -4,6 +4,7 @@ module Main where
import Affection as A import Affection as A
import Data.Ecstasy import Data.Ecstasy
import Data.Ecstasy.Types
import qualified SDL import qualified SDL
@ -62,7 +63,7 @@ pre = do
_ <- partSubscribe k toggleFullScreen _ <- partSubscribe k toggleFullScreen
_ <- partSubscribe k quitGame _ <- partSubscribe k quitGame
u <- partSubscribe j cacheJoypad u <- partSubscribe j cacheJoypad
(ws, _) <- yieldSystemT (0, defStorage) (return ()) (ws, _) <- yieldSystemT (SystemState 0 defStorage defHooks) (return ())
putAffection ud putAffection ud
{ threadContext = Just threadCtx { threadContext = Just threadCtx
, window = Just (drawWindow ad) , window = Just (drawWindow ad)
@ -84,7 +85,7 @@ quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym)
mapM_ (partUnSubscribe j) (uuid ud) mapM_ (partUnSubscribe j) (uuid ud)
mapM_ (partUnSubscribe t) (uuid ud) mapM_ (partUnSubscribe t) (uuid ud)
SDL.glMakeCurrent (drawWindow ad) (glContext ad) SDL.glMakeCurrent (drawWindow ad) (glContext ad)
(ws, _) <- yieldSystemT (0, defStorage) (return ()) (ws, _) <- yieldSystemT (SystemState 0 defStorage defHooks) (return ())
putAffection ud putAffection ud
{ worldState = ws { worldState = ws
, state = Load , state = Load

View file

@ -15,6 +15,7 @@ import Control.Monad.IO.Class (liftIO)
import Control.Monad.State.Strict (evalStateT) import Control.Monad.State.Strict (evalStateT)
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Concurrent (forkIO) import Control.Concurrent (forkIO)
import Control.Parallel.Strategies hiding (dot)
import Data.Map.Strict as Map import Data.Map.Strict as Map
import qualified Data.Set as S import qualified Data.Set as S
@ -38,7 +39,6 @@ import Types
import Floorplan import Floorplan
import MindMap import MindMap
import NPC import NPC
-- import Object
import Animation import Animation
import Collision import Collision
@ -236,10 +236,9 @@ loadMapFork ud ad future progress = do
))) )))
mapM_ (\cpr -> do mapM_ (\cpr -> do
fact <- liftIO $ randomRIO (0.5, 1.5) fact <- liftIO $ randomRIO (0.5, 1.5)
-- fut <- liftIO newEmptyMVar
stats <- liftIO $ NPCStats stats <- liftIO $ NPCStats
<$> (randomRIO (0, 1)) <$> (randomRIO (0, 1))
<*> (randomRIO (0, 1)) <*> pure 0
<*> (randomRIO (0, 1)) <*> (randomRIO (0, 1))
<*> (randomRIO (0, 1)) <*> (randomRIO (0, 1))
<*> (randomRIO (0, 1)) <*> (randomRIO (0, 1))
@ -266,7 +265,6 @@ loadMapFork ud ad future progress = do
( p + increment ( p + increment
, "Registering doors into WorldState" , "Registering doors into WorldState"
))) )))
-- let doors = Prelude.filter ((\t -> t == RoomExit || t == Elevator) . pointType) rps
mapM_ (\door -> do mapM_ (\door -> do
let rooms = Prelude.foldl let rooms = Prelude.foldl
(\acc coord -> (\acc coord ->
@ -340,37 +338,6 @@ loadMapFork ud ad future progress = do
, roomGraph = gr , 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 :: KeyboardMessage -> Affection UserData ()
movePlayerKbd (MsgKeyboardEvent _ _ press False sym) movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
| SDL.keysymKeycode sym == SDL.KeycodeW = do | SDL.keysymKeycode sym == SDL.KeycodeW = do
@ -648,7 +615,7 @@ drawMap = do
closePath ctx closePath ctx
fillColor ctx (rgb 255 255 255) fillColor ctx (rgb 255 255 255)
fill ctx fill ctx
mapM_ (\(i, ls) -> mapM_ void $ sequence $ parMap rpar (\(i, ls) -> void $ sequence $ parMap rpar
(\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t) (\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t)
(reverse $ zip [1..] ls)) (reverse $ zip [1..] ls))
(zip [1..] (toLists mat)) (zip [1..] (toLists mat))
@ -729,8 +696,6 @@ drawTile ud ctx posanims pr pc row col img =
nnc = case mbnds of nnc = case mbnds of
Just (Boundaries (_, minc) (_, _)) -> minc Just (Boundaries (_, minc) (_, _)) -> minc
Nothing -> nc - fromIntegral ((floor nc) :: Int) :: Double 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 tileWidth = 64 :: Double
tileHeight = 32 :: Double tileHeight = 32 :: Double
sorted = sortOn (\(V2 sr sc, _, mbnds) -> sorted = sortOn (\(V2 sr sc, _, mbnds) ->
@ -744,7 +709,6 @@ drawTile ud ctx posanims pr pc row col img =
(sr - (fromIntegral ((floor sr) :: Int))) (sr - (fromIntegral ((floor sr) :: Int)))
(sc - (fromIntegral ((floor sc) :: Int))) (sc - (fromIntegral ((floor sc) :: Int)))
) posanims ) posanims
-- sorted = posanims
minrs = Prelude.map (fst . matmin) mb minrs = Prelude.map (fst . matmin) mb
maxrs = Prelude.map (fst . matmax) mb maxrs = Prelude.map (fst . matmax) mb
mincs = Prelude.map (snd . matmin) mb mincs = Prelude.map (snd . matmin) mb
@ -770,8 +734,7 @@ drawTile ud ctx posanims pr pc row col img =
updateMap :: Double -> Affection UserData () updateMap :: Double -> Affection UserData ()
updateMap dt = do updateMap dt = do
ud <- getAffection ud <- getAffection
-- empty <- liftIO $ isEmptyMVar (stateMVar ud) if stateData ud == None
if stateData ud == None -- && empty
then do then do
mstart <- liftIO $ tryTakeMVar (stateMVar ud) mstart <- liftIO $ tryTakeMVar (stateMVar ud)
case mstart of case mstart of
@ -789,49 +752,6 @@ updateMap dt = do
Nothing -> return () Nothing -> return ()
else do else do
(nws, _) <- yieldSystemT (worldState ud) $ 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 obstacleBounds <- efor allEnts $ do
with obstacle with obstacle
with pos with pos
@ -839,18 +759,15 @@ updateMap dt = do
pos' <- query pos pos' <- query pos
return (pos', b) return (pos', b)
emap allEnts $ do emap allEnts $ do
without player
with vel
with velFact
with pos
with rot
with anim
pos'@(V2 pr pc) <- query pos pos'@(V2 pr pc) <- query pos
vel' <- query vel vel' <- queryMaybe vel
rot' <- query rot rot' <- query rot
fact' <- query velFact fact' <- fromMaybe 1 <$> queryMaybe velFact
xyv2 <- queryMaybe xyvel
stat <- query anim 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' dpos@(V2 dpr dpc) = npos - pos'
aId = asId stat aId = asId stat
lll = (,) lll = (,)
@ -889,132 +806,80 @@ updateMap dt = do
) )
lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll) lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll)
) )
nstat = case aiName aId of nstate =
"walking" let velo = fromMaybe (V2 0 0) vel'
| sqrt (vel' `dot` vel') > 0 -> nstat = if ntime > fromIntegral (asCurrentFrame stat + 1) *
stat (animDuration an / fromIntegral (length $ animSprites an))
{ asId = aId then
{ aiDirection = fromMaybe rot' (direction vel') let nframe = asCurrentFrame stat + 1
} in case animPlay an of
} APLoop ->
| otherwise -> let (nnframe, nntime) =
stat if nframe >= length (animSprites an)
{ asId = aId then (0, 0)
{ aiDirection = fromMaybe rot' (direction vel') else (nframe, ntime)
, aiName = "standing" in stat
} { asCurrentFrame = nnframe
, asCurrentFrame = 0 , asElapsedTime = nntime
} }
"standing" APOnce ->
| sqrt (vel' `dot` vel') > 0 -> let nnframe = if nframe >= length (animSprites an)
stat then nframe - 1
{ asId = aId else nframe
{ aiDirection = fromMaybe rot' (direction vel') in stat
, aiName = "walking" { asCurrentFrame = nnframe
} , asElapsedTime = ntime
, asCurrentFrame = 0 }
} else
| otherwise -> stat
stat { asElapsedTime = ntime
{ asId = aId }
{ aiDirection = fromMaybe rot' (direction vel') in
} case aiName aId of
} "walking"
x -> error ("unknown animation name" ++ x) | 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 ent = unchanged
{ pos = Set $ pos' + colldpos { pos = Set $ pos' + colldpos
, rot = Set $ fromMaybe rot' (direction vel') , rot = Set $ fromMaybe rot' (direction (fromMaybe (V2 0 0) vel'))
, anim = Set nstat , 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 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 allRelEnts <- efor allEnts $ do
with pos with pos
with rot with rot
@ -1046,33 +911,3 @@ updateMap dt = do
putAffection ud putAffection ud
{ worldState = nws2 { 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)

View file

@ -233,7 +233,7 @@ updateStats dt =
else min 1 (conc + 0.1 * dt) else min 1 (conc + 0.1 * dt)
, statBladder = , statBladder =
if food > 0 || drin > 0 if food > 0 || drin > 0
then min 1 (blad + 0.3 * dt) then min 1 (blad + 0.01 * dt)
else blad else blad
, statThirst = min 1 (if drin > 0 then thir else thir + 0.2 * dt) , 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) , statHunger = min 1 (if food > 0 then hung else hung + 0.1 * dt)

View file

@ -7,14 +7,24 @@ module Object.Copier where
import Affection as A import Affection as A
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.IO.Class
import Data.Ecstasy import Data.Ecstasy
import Data.Maybe import Data.Maybe
import Data.String (IsString(..))
import Linear import Linear
import Types 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 copierObjectAction _ dt t@ObjCopier s@"copying" ent = do
emap (anEnt ent) $ do emap (anEnt ent) $ do
mtime <- queryMaybe objStateTime mtime <- queryMaybe objStateTime
@ -38,6 +48,14 @@ copierObjectAction _ dt t@ObjCopier s@"copying" ent = do
copierObjectAction _ _ _ _ _ = return () 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 copierObjectTransition ObjCopier "idle" playerActivated ent (Just aent) = do
e <- efor (anEnt ent) $ do e <- efor (anEnt ent) $ do
let nstat = AnimState let nstat = AnimState

View file

@ -78,6 +78,7 @@ executable tracer-game
, bytestring , bytestring
, algebraic-graphs , algebraic-graphs
, mtl , mtl
, parallel
hs-source-dirs: src hs-source-dirs: src
ghc-options: -Wall -threaded ghc-options: -Wall -threaded
default-language: Haskell2010 default-language: Haskell2010