Merge pull request #2 from nek0/drawfilter

Drawfilter
This commit is contained in:
rys ostrovid 2019-03-07 15:17:32 +01:00 committed by GitHub
commit 6452804270
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
6 changed files with 148 additions and 269 deletions

View file

@ -1,2 +1,3 @@
packages: ./ packages:
./
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

@ -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,10 +615,36 @@ 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_ let coordList = concatMap
(\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t) (\(i, ls) -> Prelude.map
(reverse $ zip [1..] ls)) (\(j, t) -> ((i, j), t))
(zip [1..] (toLists mat)) (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 mapM_ (\(V2 sr sc, pa, perc) -> when pa $ do
let lx = realToFrac $ 640 + ((sc - pc) + let lx = realToFrac $ 640 + ((sc - pc) +
(sr - pr)) * (tileWidth / 2) :: CFloat (sr - pr)) * (tileWidth / 2) :: CFloat
@ -691,24 +684,21 @@ drawTile
-> Maybe ImgId -> Maybe ImgId
-> IO () -> IO ()
drawTile ud ctx posanims pr pc row col img = drawTile ud ctx posanims pr pc row col img =
when ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) && do
((realToFrac x :: Double) < 1280 && let (bef, beh) = L.partition delimiter sorted
(realToFrac (y - (74 - (realToFrac tileHeight :: CFloat))) :: Double) < 720)) $ save ctx
do mapM_ drawAnim beh
let (bef, beh) = L.partition delimiter sorted maybe (return ()) (draw ud x (y - 42) 64 74 fact)
save ctx ((assetImages ud Map.!) <$> case img of
mapM_ drawAnim beh Just ImgEmpty -> Nothing
maybe (return ()) (draw ud x (y - 42) 64 74 fact) _ -> img
((assetImages ud Map.!) <$> case img of )
Just ImgEmpty -> Nothing mapM_ drawAnim bef
_ -> img restore ctx
) -- when (floor pr == row && floor pc == col) $ do
mapM_ drawAnim bef -- A.logIO A.Debug ("sorted: " ++ show sorted)
restore ctx -- A.logIO A.Debug ("beh: " ++ show beh)
-- when (floor pr == row && floor pc == col) $ do -- A.logIO A.Debug ("bef: " ++ show bef)
-- A.logIO A.Debug ("sorted: " ++ show sorted)
-- A.logIO A.Debug ("beh: " ++ show beh)
-- A.logIO A.Debug ("bef: " ++ show bef)
where where
delimiter (V2 nr nc, as, mbnds) = delimiter (V2 nr nc, as, mbnds) =
animFloats (asId as) || animFloats (asId as) ||
@ -729,8 +719,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 +732,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 +757,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 +775,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 +782,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 +829,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 +934,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