loading screen

This commit is contained in:
nek0 2018-06-08 00:29:46 +02:00
parent c6d4cae284
commit fd8d5d81f0
7 changed files with 321 additions and 283 deletions

View file

@ -79,7 +79,7 @@ let
f = { mkDerivation, astar, base, containers, linear f = { mkDerivation, astar, base, containers, linear
, matrix, OpenGL, random, sdl2, stdenv, stm, text, unordered-containers , matrix, OpenGL, random, sdl2, stdenv, stm, text, unordered-containers
, vector, JuicyPixels, JuicyPixels-extra, bytestring , vector, JuicyPixels, JuicyPixels-extra, bytestring, monad-loops
}: }:
mkDerivation { mkDerivation {
pname = "tracer-game"; pname = "tracer-game";

View file

@ -43,11 +43,13 @@ foreign import ccall unsafe "glewInit"
load :: IO UserData load :: IO UserData
load = do load = do
_ <- glewInit
nvg <- createGL3 (S.fromList [Antialias, StencilStrokes])
subs <- Subsystems subs <- Subsystems
<$> (Window <$> newTVarIO []) <$> (Window <$> newTVarIO [])
<*> (Mouse <$> newTVarIO []) <*> (Mouse <$> newTVarIO [])
_ <- glewInit
nvg <- createGL3 (S.fromList [Antialias, StencilStrokes])
_ <- createFont nvg "bedstead"
(FileName "assets/font/Bedstead-Semicondensed.ttf")
(ws, _) <- yieldSystemT (0, defStorage) (return ()) (ws, _) <- yieldSystemT (0, defStorage) (return ())
mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") 0 mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") 0
mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") 0 mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") 0
@ -66,10 +68,8 @@ load = do
mmisctable3 <- createImage nvg (FileName "assets/misc/table3.png") 0 mmisctable3 <- createImage nvg (FileName "assets/misc/table3.png") 0
mmisctable4 <- createImage nvg (FileName "assets/misc/table4.png") 0 mmisctable4 <- createImage nvg (FileName "assets/misc/table4.png") 0
mmisctableC <- createImage nvg (FileName "assets/misc/tableCorner.png") 0 mmisctableC <- createImage nvg (FileName "assets/misc/tableCorner.png") 0
_ <- createFont nvg "bedstead"
(FileName "assets/font/Bedstead-Semicondensed.ttf")
let mimgs = [ mwallasc, mwalldesc, let mimgs = [ mwallasc, mwalldesc,
mwallcornern, mwallcornere, mwallcorners, mwallcornerw, mwallcornern, mwallcornere, mwallcorners, mwallcornerw,
mwalltne, mwalltse, mwalltsw, mwalltnw, mwallcross, mwalltne, mwalltse, mwalltsw, mwalltnw, mwallcross,
mmiscbox1, mmiscbox1,
mmisctable1, mmisctable2, mmisctable3, mmisctable4, mmisctableC mmisctable1, mmisctable2, mmisctable3, mmisctable4, mmisctableC

View file

@ -81,21 +81,21 @@ placeNPCs
-> [ReachPoint] -> [ReachPoint]
-> [Graph] -> [Graph]
-> Int -> Int
-> Affection UserData [V2 Double] -> IO [V2 Double]
placeNPCs imgmat tilemat rp gr count = placeNPCs imgmat tilemat rp gr count =
doPlace 1 [] doPlace 1 []
where where
doPlace :: Int -> [V2 Double] -> Affection UserData [V2 Double] doPlace :: Int -> [V2 Double] -> IO [V2 Double]
doPlace nr acc = do doPlace nr acc = do
if nr <= count if nr <= count
then do then do
r <- liftIO $ randomRIO (1, M.nrows imgmat) r <- randomRIO (1, M.nrows imgmat)
c <- liftIO $ randomRIO (1, M.ncols imgmat) c <- randomRIO (1, M.ncols imgmat)
if null (imgObstacle $ imgmat M.! (r, c)) && if null (imgObstacle $ imgmat M.! (r, c)) &&
tilemat M.! (r, c) == Hall tilemat M.! (r, c) == Hall
then doPlace (nr + 1) ((V2 (fromIntegral r) (fromIntegral c)) : acc) then doPlace (nr + 1) ((V2 (fromIntegral r) (fromIntegral c)) : acc)
else do else do
i <- liftIO $ randomRIO (0, length nonexits - 1) i <- randomRIO (0, length nonexits - 1)
doPlace doPlace
(nr + 1) (nr + 1)
((fmap fromIntegral $ pointCoord (nonexits !! i)) : acc) ((fmap fromIntegral $ pointCoord (nonexits !! i)) : acc)

View file

@ -8,7 +8,7 @@ import NanoVG hiding (V2(..))
import Control.Monad (when, void) import Control.Monad (when, void)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Concurrent (forkOS) import Control.Concurrent (forkIO)
import Data.Map.Strict as Map import Data.Map.Strict as Map
import qualified Data.Set as S import qualified Data.Set as S
@ -35,12 +35,33 @@ import NPC
loadMap :: Affection UserData () loadMap :: Affection UserData ()
loadMap = do loadMap = do
ud <- getAffection ud <- getAffection
let (Subsystems _ m) = subsystems ud
ctx = nano ud
uu <- partSubscribe m movePlayer
future <- liftIO $ newEmptyMVar
_ <- liftIO $ forkIO $ loadMapFork ud future
-- liftIO $ whileM_ (isJust <$> tryTakeMVar future) $ do
-- beginFrame (nano ud) 1280 720 1
-- fontSize ctx 100
-- fontFace ctx (assetFonts ud Map.! FontBedstead)
-- textAlign ctx (S.fromList [AlignCenter,AlignTop])
-- fillColor ctx (rgb 255 128 0)
-- textBox ctx 0 300 1280 ("Loading")
-- endFrame (nano ud)
-- (nws, mendat) <- liftIO $ takeMVar future
putAffection ud
{ stateData = None
, uuid = [uu]
, menuMVar = future
}
loadMapFork :: UserData -> MVar (SystemState Entity IO, StateData) -> IO ()
loadMapFork ud future = do
let fc = FloorConfig let fc = FloorConfig
(10, 10) (10, 10)
[] []
(50, 50) (50, 50)
(Subsystems _ m) = subsystems ud (mat, gr) <- buildHallFloorIO fc
(mat, gr) <- liftIO $ buildHallFloorIO fc
let imgmat = convertTileToImg mat let imgmat = convertTileToImg mat
exits = Prelude.foldl exits = Prelude.foldl
(\acc coord@(r, c) -> if imgmat M.! coord == Just ImgEmpty (\acc coord@(r, c) -> if imgmat M.! coord == Just ImgEmpty
@ -49,12 +70,12 @@ loadMap = do
) )
[] []
((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]) ((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat])
(inter, rps) <- liftIO $ placeInteriorIO mat imgmat exits gr (inter, rps) <- placeInteriorIO mat imgmat exits gr
liftIO $ logIO A.Debug ("number of reachpoints: " ++ show (length rps)) logIO A.Debug ("number of reachpoints: " ++ show (length rps))
let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps
npcposs <- placeNPCs inter mat rps gr 50 -- (length nnex) npcposs <- placeNPCs inter mat rps gr 50 -- (length nnex)
liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs) A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs)
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do (nws, _) <- yieldSystemT (worldState ud) $ do
void $ createEntity $ newEntity void $ createEntity $ newEntity
{ pos = Just (V2 10.5 10.5) { pos = Just (V2 10.5 10.5)
, vel = Just (V2 0 0) , vel = Just (V2 0 0)
@ -65,7 +86,7 @@ loadMap = do
void $ mapM_ (\npcpos@(V2 nr nc) -> do void $ mapM_ (\npcpos@(V2 nr nc) -> do
fact <- liftIO $ randomRIO (0.5, 1.5) fact <- liftIO $ randomRIO (0.5, 1.5)
future <- liftIO newEmptyMVar future <- liftIO newEmptyMVar
_ <- liftIO $ forkOS $ getPath (fmap floor npcpos) future nnex inter _ <- liftIO $ forkIO $ getPath (fmap floor npcpos) future nnex inter
void $ createEntity $ newEntity void $ createEntity $ newEntity
{ pos = Just (V2 (nr + 0.5) (nc + 0.5)) { pos = Just (V2 (nr + 0.5) (nc + 0.5))
, vel = Just (V2 0 0) , vel = Just (V2 0 0)
@ -75,10 +96,7 @@ loadMap = do
, anim = Just $ AnimState (AnimId 0 "standing" SE) 0 0 , anim = Just $ AnimState (AnimId 0 "standing" SE) 0 0
} }
) npcposs ) npcposs
uu <- partSubscribe m movePlayer putMVar future (nws, MenuData
putAffection ud
{ worldState = nws
, stateData = MenuData
{ mapMat = mat { mapMat = mat
, imgMat = M.fromList (nrows inter) (ncols inter) $ , imgMat = M.fromList (nrows inter) (ncols inter) $
Prelude.map Prelude.map
@ -86,9 +104,7 @@ loadMap = do
(M.toList inter) (M.toList inter)
, initCoords = (0, 500) , initCoords = (0, 500)
, reachPoints = rps , reachPoints = rps
} })
, uuid = [uu]
}
mouseToPlayer :: V2 Int32 -> Affection UserData () mouseToPlayer :: V2 Int32 -> Affection UserData ()
mouseToPlayer mv2 = do mouseToPlayer mv2 = do
@ -126,76 +142,86 @@ movePlayer _ = return ()
drawMap :: Affection UserData () drawMap :: Affection UserData ()
drawMap = do drawMap = do
ud <- getAffection ud <- getAffection
dt <- getDelta let ctx = nano ud
(_, (playerPos, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do case stateData ud of
pc <- fmap head $ efor allEnts $ do None -> liftIO $ do
with player beginFrame (nano ud) 1280 720 1
with pos fontSize ctx 100
query pos fontFace ctx (assetFonts ud Map.! FontBedstead)
posanims <- efor allEnts $ do textAlign ctx (S.fromList [AlignCenter,AlignTop])
with anim fillColor ctx (rgb 255 128 0)
with pos textBox ctx 0 300 1280 ("Loading")
stat <- query anim endFrame (nano ud)
pos' <- query pos _ -> do
return (pos', stat) dt <- getDelta
return (pc, posanims) (_, (playerPos, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do
let V2 pr pc = playerPos pc <- fmap head $ efor allEnts $ do
mat = imgMat (stateData ud) with player
ctx = nano ud with pos
cols = fromIntegral (ncols mat) query pos
rows = fromIntegral (nrows mat) posanims <- efor allEnts $ do
tileWidth = 64 :: Double with anim
tileHeight = 32 :: Double with pos
x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2) stat <- query anim
y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2) pos' <- query pos
partposanims = M.fromList return (pos', stat)
(nrows $ mapMat $ stateData ud) return (pc, posanims)
(ncols $ mapMat $ stateData ud) let V2 pr pc = playerPos
((reverse . fst) mat = imgMat (stateData ud)
(Prelude.foldl cols = fromIntegral (ncols mat)
(\(done, proc) coord -> rows = fromIntegral (nrows mat)
let (ndone, nproc) = processList proc coord tileWidth = 64 :: Double
in (ndone : done, nproc) tileHeight = 32 :: Double
x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2)
y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2)
partposanims = M.fromList
(nrows $ mapMat $ stateData ud)
(ncols $ mapMat $ stateData ud)
((reverse . fst)
(Prelude.foldl
(\(done, proc) coord ->
let (ndone, nproc) = processList proc coord
in (ndone : done, nproc)
)
([], posanims)
((,)
<$> [1 .. (nrows $ mapMat $ stateData ud)]
<*> [1 .. (ncols $ mapMat $ stateData ud)]
)
)
) )
([], posanims) processList
((,) :: [(V2 Double, AnimState)]
<$> [1 .. (nrows $ mapMat $ stateData ud)] -> (Int, Int)
<*> [1 .. (ncols $ mapMat $ stateData ud)] -> ([(V2 Double, AnimState)], [(V2 Double, AnimState)])
) processList list coord@(r, c) =
) let delimiter (V2 nr nc, _) =
) floor nr == r && floor nc == c
processList in L.partition delimiter list
:: [(V2 Double, AnimState)] liftIO $ do -- draw floor
-> (Int, Int) beginPath ctx
-> ([(V2 Double, AnimState)], [(V2 Double, AnimState)]) moveTo ctx (x + realToFrac tileWidth / 2) y
processList list coord@(r, c) = lineTo ctx
let delimiter (V2 nr nc, _) = (x + cols * (realToFrac tileWidth / 2))
floor nr == r && floor nc == c (y - (realToFrac tileHeight / 2) * (cols - 1))
in L.partition delimiter list lineTo ctx
liftIO $ do -- draw floor (x + (realToFrac tileWidth / 2) * (cols + rows - 1))
beginPath ctx (y + (rows - cols) * (realToFrac tileHeight / 2))
moveTo ctx (x + realToFrac tileWidth / 2) y lineTo ctx
lineTo ctx (x + (realToFrac tileWidth / 2) * rows)
(x + cols * (realToFrac tileWidth / 2)) (y + (realToFrac tileHeight / 2) * (rows - 1))
(y - (realToFrac tileHeight / 2) * (cols - 1)) closePath ctx
lineTo ctx fillColor ctx (rgb 255 255 255)
(x + (realToFrac tileWidth / 2) * (cols + rows - 1)) fill ctx
(y + (rows - cols) * (realToFrac tileHeight / 2)) mapM_ (\(i, ls) -> mapM_
lineTo ctx (\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t)
(x + (realToFrac tileWidth / 2) * rows) (reverse $ zip [1..] ls))
(y + (realToFrac tileHeight / 2) * (rows - 1)) (zip [1..] (toLists mat))
closePath ctx fontSize ctx 20
fillColor ctx (rgb 255 255 255) fontFace ctx (assetFonts ud Map.! FontBedstead)
fill ctx textAlign ctx (S.fromList [AlignCenter,AlignTop])
mapM_ (\(i, ls) -> mapM_ fillColor ctx (rgb 255 128 0)
(\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t) textBox ctx 0 0 200 ("FPS: " `T.append` T.pack (Prelude.take 5 $ show (1/dt)))
(reverse $ zip [1..] ls))
(zip [1..] (toLists mat))
fontSize ctx 20
fontFace ctx (assetFonts ud Map.! FontBedstead)
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgb 255 128 0)
textBox ctx 0 0 200 ("FPS: " `T.append` T.pack (Prelude.take 5 $ show (1/dt)))
drawTile drawTile
:: UserData :: UserData
@ -268,203 +294,213 @@ drawTile ud ctx posanims pr pc row col img =
updateMap :: Double -> Affection UserData () updateMap :: Double -> Affection UserData ()
updateMap dt = do updateMap dt = do
let direction :: V2 Double -> Direction -> Direction
direction vel'@(V2 vr _) rot' = if sqrt (vel' `dot` vel') > 0
then
let xuu =
acos ((vel' `dot` V2 0 1) / sqrt (vel' `dot` vel')) / pi * 180
xu = if vr < 0 then 360 - xuu else xuu
d
| xu < 22.5 = NE
| xu > 22.5 && xu < 67.5 = E
| xu > 67.5 && xu < 112.5 = SE
| xu > 112.5 && xu < 157.5 = S
| xu > 157.5 && xu < 202.5 = SW
| xu > 202.5 && xu < 247.5 = W
| xu > 247.5 && xu < 292.5 = NW
| xu > 292.5 && xu < 337.5 = N
| xu > 337.5 = NE
| otherwise = NE
in d
else rot'
ud <- getAffection ud <- getAffection
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do isFut <- liftIO $ isEmptyMVar (menuMVar ud)
emap allEnts $ do if not isFut && stateData ud == None
with anim then do
stat <- query anim Just (nws, mendat) <- liftIO $ tryTakeMVar (menuMVar ud)
let an = assetAnimations ud Map.! asId stat putAffection ud
ntime = asElapsedTime stat + dt { worldState = nws
nstate = if ntime > fromIntegral (asCurrentFrame stat) * , stateData = mendat
(animDuration an / fromIntegral (length $ animSprites an)) }
then else do
let nframe = asCurrentFrame stat + 1 let direction :: V2 Double -> Direction -> Direction
in case animPlay an of direction vel'@(V2 vr _) rot' = if sqrt (vel' `dot` vel') > 0
APLoop -> then
let (nnframe, nntime) = let xuu =
if nframe >= length (animSprites an) acos ((vel' `dot` V2 0 1) /
then (0, 0) sqrt (vel' `dot` vel')) / pi * 180
else (nframe, ntime) xu = if vr < 0 then 360 - xuu else xuu
in stat d
{ asCurrentFrame = nnframe | xu < 22.5 = NE
, asElapsedTime = nntime | xu > 22.5 && xu < 67.5 = E
} | xu > 67.5 && xu < 112.5 = SE
APOnce -> | xu > 112.5 && xu < 157.5 = S
let nnframe = if nframe >= length (animSprites an) | xu > 157.5 && xu < 202.5 = SW
then nframe - 1 | xu > 202.5 && xu < 247.5 = W
else nframe | xu > 247.5 && xu < 292.5 = NW
in stat | xu > 292.5 && xu < 337.5 = N
{ asCurrentFrame = nnframe | xu > 337.5 = NE
, asElapsedTime = ntime | otherwise = NE
} in d
else else rot'
stat (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
{ asElapsedTime = ntime emap allEnts $ do
} with anim
return $ unchanged stat <- query anim
{ anim = Set nstate let an = assetAnimations ud Map.! asId stat
} ntime = asElapsedTime stat + dt
emap allEnts $ do nstate = if ntime > fromIntegral (asCurrentFrame stat) *
without player (animDuration an / fromIntegral (length $ animSprites an))
with vel then
with velFact let nframe = asCurrentFrame stat + 1
with pos in case animPlay an of
with rot APLoop ->
with anim let (nnframe, nntime) =
pos' <- query pos if nframe >= length (animSprites an)
vel' <- query vel then (0, 0)
rot' <- query rot else (nframe, ntime)
fact' <- query velFact in stat
stat <- query anim { asCurrentFrame = nnframe
let npos = pos' + fmap (* (dt * fact')) vel' , asElapsedTime = nntime
aId = asId stat }
nstat = case aiName aId of APOnce ->
"walking" let nnframe = if nframe >= length (animSprites an)
| sqrt (vel' `dot` vel') > 0 -> then nframe - 1
else nframe
in stat
{ asCurrentFrame = nnframe
, asElapsedTime = ntime
}
else
stat stat
{ asId = aId { asElapsedTime = ntime
{ aiDirection = direction vel' rot'
}
} }
| otherwise -> return $ unchanged
stat { anim = Set nstate
{ asId = aId }
{ aiDirection = direction vel' rot' emap allEnts $ do
, aiName = "standing" without player
with vel
with velFact
with pos
with rot
with anim
pos' <- query pos
vel' <- query vel
rot' <- query rot
fact' <- query velFact
stat <- query anim
let npos = pos' + fmap (* (dt * fact')) vel'
aId = asId stat
nstat = case aiName aId of
"walking"
| sqrt (vel' `dot` vel') > 0 ->
stat
{ asId = aId
{ aiDirection = direction vel' rot'
}
} }
, asCurrentFrame = 0 | otherwise ->
} stat
"standing" { asId = aId
| sqrt (vel' `dot` vel') > 0 -> { aiDirection = direction vel' rot'
stat , aiName = "standing"
{ asId = aId }
{ aiDirection = direction vel' rot' , asCurrentFrame = 0
, aiName = "walking"
} }
, asCurrentFrame = 0 "standing"
} | sqrt (vel' `dot` vel') > 0 ->
| otherwise -> stat
stat { asId = aId
{ asId = aId { aiDirection = direction vel' rot'
{ aiDirection = direction vel' rot' , aiName = "walking"
}
, asCurrentFrame = 0
} }
} | otherwise ->
x -> error ("unknown animation name" ++ x) stat
ent = unchanged { asId = aId
{ pos = Set npos { aiDirection = direction vel' rot'
, rot = Set $ direction vel' rot' }
, anim = Set nstat
}
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 = direction vel' rot'
} }
} x -> error ("unknown animation name" ++ x)
| otherwise -> ent = unchanged
stat { pos = Set npos
{ asId = aId , rot = Set $ direction vel' rot'
{ aiDirection = direction vel' rot' , anim = Set nstat
, aiName = "standing" }
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 = direction vel' rot'
}
} }
, asCurrentFrame = 0 | otherwise ->
} stat
"standing" { asId = aId
| sqrt (colldpos `dot` colldpos) > 0 -> { aiDirection = direction vel' rot'
stat , aiName = "standing"
{ asId = aId }
{ aiDirection = direction vel' rot' , asCurrentFrame = 0
, aiName = "walking"
} }
, asCurrentFrame = 0 "standing"
} | sqrt (colldpos `dot` colldpos) > 0 ->
| otherwise -> stat
stat { asId = aId
{ asId = aId { aiDirection = direction vel' rot'
{ aiDirection = direction vel' rot' , aiName = "walking"
}
, asCurrentFrame = 0
} }
} | otherwise ->
x -> error ("unknown animation name" ++ x) stat
len = sqrt (dpos `dot` dpos) { asId = aId
lll = (,) { aiDirection = direction vel' rot'
<$> ( }
if dpr < 0 }
then [(floor dpr :: Int) .. 0] x -> error ("unknown animation name" ++ x)
else [0 .. (ceiling dpr :: Int)]) len = sqrt (dpos `dot` dpos)
<*> ( lll = (,)
if dpc < 0 <$> (
then [(floor dpc :: Int) .. 0] if dpr < 0
else [0 .. (ceiling dpc :: Int)]) then [(floor dpr :: Int) .. 0]
colldpos = dpos * Prelude.foldl else [0 .. (ceiling dpr :: Int)])
(\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a <*> (
in A.log A.Verbose (show ret) ret) if dpc < 0
(V2 1 1) then [(floor dpc :: Int) .. 0]
( else [0 .. (ceiling dpc :: Int)])
concatMap colldpos = dpos * Prelude.foldl
(\(dr, dc) -> (\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a
let bs = fromMaybe [] (imgObstacle <$> M.safeGet in A.log A.Verbose (show ret) ret)
(fromIntegral $ floor pr + dr) (V2 1 1)
(fromIntegral $ floor pc + dc) (
(imgMat (stateData ud))) concatMap
in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))-> (\(dr, dc) ->
Boundaries let bs = fromMaybe [] (imgObstacle <$> M.safeGet
(minr + fromIntegral dr, minc + fromIntegral dc) (fromIntegral $ floor pr + dr)
(maxr + fromIntegral dr, maxc + fromIntegral dc) (fromIntegral $ floor pc + dc)
) bs (imgMat (stateData ud)))
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)
) )
lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll) ent = unchanged
) { pos = Set $ pos' + colldpos
ent = unchanged , rot = Set (direction vel' rot')
{ pos = Set $ pos' + colldpos , anim = Set nstat
, rot = Set (direction vel' rot') }
, anim = Set nstat return ent
} updateNPCs
return ent (imgMat $ stateData ud)
updateNPCs (Prelude.filter
(imgMat $ stateData ud) (\p -> pointType p /= RoomExit)
(Prelude.filter (reachPoints $ stateData ud)
(\p -> pointType p /= RoomExit) )
(reachPoints $ stateData ud) dt
) putAffection ud
dt { worldState = nws
putAffection ud }
{ worldState = nws
}
checkBoundsCollision2 checkBoundsCollision2
:: V2 Double :: V2 Double

View file

@ -8,7 +8,7 @@ data ReachPoint = ReachPoint
, pointCoord :: V2 Int , pointCoord :: V2 Int
, pointDir :: Direction , pointDir :: Direction
} }
deriving (Show) deriving (Eq, Show)
data PointType data PointType
= RoomExit = RoomExit

View file

@ -7,10 +7,11 @@ import Types.Map
import Types.ImgId import Types.ImgId
data StateData data StateData
= None = None
| MenuData | MenuData
{ mapMat :: Matrix TileState { mapMat :: Matrix TileState
, initCoords :: (Int, Int) , initCoords :: (Int, Int)
, imgMat :: Matrix (Maybe ImgId) , imgMat :: Matrix (Maybe ImgId)
, reachPoints :: [ReachPoint] , reachPoints :: [ReachPoint]
} }
deriving (Eq)

View file

@ -32,6 +32,7 @@ data UserData = UserData
, uuid :: [UUID] , uuid :: [UUID]
, worldState :: SystemState Entity IO , worldState :: SystemState Entity IO
, stateData :: StateData , stateData :: StateData
, menuMVar :: MVar (SystemState Entity IO, StateData)
} }
data State data State