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

View file

@ -247,6 +247,7 @@ let
random sdl stm text unordered-containers vector pkgconfig
];
enableExecutableProfiling = true;
enableLibraryProfiling = true;
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.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)

View file

@ -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)

View file

@ -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

View file

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