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,21 +752,63 @@ updateMap dt = do
Nothing -> return () Nothing -> return ()
else do else do
(nws, _) <- yieldSystemT (worldState ud) $ do (nws, _) <- yieldSystemT (worldState ud) $ do
obstacleBounds <- efor allEnts $ do
with obstacle
with pos
b <- query obstacle
pos' <- query pos
return (pos', b)
emap allEnts $ do emap allEnts $ do
with player pos'@(V2 pr pc) <- query pos
with xyvel vel' <- queryMaybe vel
with vel rot' <- query rot
V2 rx ry <- query xyvel fact' <- fromMaybe 1 <$> queryMaybe velFact
let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45) xyv2 <- queryMaybe xyvel
return $ unchanged
{ vel = Set $ 2 * V2 dr dc
}
emap allEnts $ do
with anim
stat <- query anim stat <- query anim
let an = assetAnimations ud Map.! asId stat let an = assetAnimations ud Map.! asId stat
ntime = asElapsedTime stat + dt ntime = asElapsedTime stat + dt
nstate = if ntime > fromIntegral (asCurrentFrame stat + 1) * npos = pos' + fmap (* (dt * fact')) (fromMaybe (V2 0 0) vel')
dpos@(V2 dpr dpc) = npos - pos'
aId = asId stat
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)
)
nstate =
let velo = fromMaybe (V2 0 0) vel'
nstat = if ntime > fromIntegral (asCurrentFrame stat + 1) *
(animDuration an / fromIntegral (length $ animSprites an)) (animDuration an / fromIntegral (length $ animSprites an))
then then
let nframe = asCurrentFrame stat + 1 let nframe = asCurrentFrame stat + 1
@ -829,192 +834,52 @@ updateMap dt = do
stat stat
{ asElapsedTime = ntime { asElapsedTime = ntime
} }
return $ unchanged in
{ anim = Set nstate case aiName aId of
}
obstacleBounds <- efor allEnts $ do
with obstacle
with pos
b <- query obstacle
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
rot' <- query rot
fact' <- query velFact
stat <- query anim
let npos = pos' + fmap (* (dt * fact')) vel'
dpos@(V2 dpr dpc) = npos - pos'
aId = asId stat
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)
)
nstat = case aiName aId of
"walking" "walking"
| sqrt (vel' `dot` vel') > 0 -> | sqrt (velo `dot` velo) > 0 ->
stat nstat
{ asId = aId { asId = aId
{ aiDirection = fromMaybe rot' (direction vel') { aiDirection = fromMaybe rot' (direction velo)
} }
} }
| otherwise -> | otherwise ->
stat nstat
{ asId = aId { asId = aId
{ aiDirection = fromMaybe rot' (direction vel') { aiDirection = fromMaybe rot' (direction velo)
, aiName = "standing" , aiName = "standing"
} }
, asCurrentFrame = 0 , asCurrentFrame = 0
} }
"standing" "standing"
| sqrt (vel' `dot` vel') > 0 -> | sqrt (velo `dot` velo) > 0 ->
stat nstat
{ asId = aId { asId = aId
{ aiDirection = fromMaybe rot' (direction vel') { aiDirection = fromMaybe rot' (direction velo)
, aiName = "walking" , aiName = "walking"
} }
, asCurrentFrame = 0 , asCurrentFrame = 0
} }
| otherwise -> | otherwise ->
stat nstat
{ asId = aId { asId = aId
{ aiDirection = fromMaybe rot' (direction vel') { aiDirection = fromMaybe rot' (direction velo)
} }
} }
x -> error ("unknown animation name" ++ x) 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