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))
(reverse $ zip [1..] ls)
)
(zip [1..] (toLists mat)) (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,9 +684,6 @@ 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) &&
((realToFrac x :: Double) < 1280 &&
(realToFrac (y - (74 - (realToFrac tileHeight :: CFloat))) :: Double) < 720)) $
do do
let (bef, beh) = L.partition delimiter sorted let (bef, beh) = L.partition delimiter sorted
save ctx save ctx
@ -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,21 +775,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 +857,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 +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