phew...
This commit is contained in:
parent
fc57805889
commit
46068b99ab
|
|
@ -1,2 +1,4 @@
|
|||
packages: ./
|
||||
packages:
|
||||
./
|
||||
../ecstasy/
|
||||
profiling: True
|
||||
|
|
|
|||
|
|
@ -247,6 +247,7 @@ let
|
|||
random sdl stm text unordered-containers vector pkgconfig
|
||||
];
|
||||
enableExecutableProfiling = true;
|
||||
enableLibraryProfiling = true;
|
||||
license = stdenv.lib.licenses.gpl3;
|
||||
};
|
||||
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ module Main where
|
|||
import Affection as A
|
||||
|
||||
import Data.Ecstasy
|
||||
import Data.Ecstasy.Types
|
||||
|
||||
import qualified SDL
|
||||
|
||||
|
|
@ -62,7 +63,7 @@ pre = do
|
|||
_ <- partSubscribe k toggleFullScreen
|
||||
_ <- partSubscribe k quitGame
|
||||
u <- partSubscribe j cacheJoypad
|
||||
(ws, _) <- yieldSystemT (0, defStorage) (return ())
|
||||
(ws, _) <- yieldSystemT (SystemState 0 defStorage defHooks) (return ())
|
||||
putAffection ud
|
||||
{ threadContext = Just threadCtx
|
||||
, window = Just (drawWindow ad)
|
||||
|
|
@ -84,7 +85,7 @@ quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
|||
mapM_ (partUnSubscribe j) (uuid ud)
|
||||
mapM_ (partUnSubscribe t) (uuid ud)
|
||||
SDL.glMakeCurrent (drawWindow ad) (glContext ad)
|
||||
(ws, _) <- yieldSystemT (0, defStorage) (return ())
|
||||
(ws, _) <- yieldSystemT (SystemState 0 defStorage defHooks) (return ())
|
||||
putAffection ud
|
||||
{ worldState = ws
|
||||
, state = Load
|
||||
|
|
|
|||
|
|
@ -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,7 +615,7 @@ drawMap = do
|
|||
closePath ctx
|
||||
fillColor ctx (rgb 255 255 255)
|
||||
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)
|
||||
(reverse $ zip [1..] ls))
|
||||
(zip [1..] (toLists mat))
|
||||
|
|
@ -729,8 +696,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 +709,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 +734,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 +752,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 +759,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 +806,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 +911,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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -78,6 +78,7 @@ executable tracer-game
|
|||
, bytestring
|
||||
, algebraic-graphs
|
||||
, mtl
|
||||
, parallel
|
||||
hs-source-dirs: src
|
||||
ghc-options: -Wall -threaded
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
Loading…
Reference in New Issue