tracer/src/MainGame/WorldMap.hs

574 lines
19 KiB
Haskell

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module MainGame.WorldMap where
import Affection as A
import Algebra.Graph as AG
import qualified SDL
import NanoVG hiding (V2(..))
import Control.Monad (when, void)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.MVar
import Control.Concurrent (forkIO)
import Data.Map.Strict as Map
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Matrix as M
import Data.Ecstasy as E
import Data.Maybe
import Data.List as L (sortOn, partition, find)
import System.Random (randomRIO)
import Linear hiding (E)
import Foreign.C.Types (CFloat(..))
-- internal imports
import Interior
import Util
import Types
import Floorplan
import MindMap
import NPC
loadMap :: Affection UserData ()
loadMap = do
ud <- getAffection
let (Subsystems _ m k) = subsystems ud
ctx = nano ud
uu1 <- partSubscribe m movePlayer
uu2 <- partSubscribe k changeMaps
future <- liftIO $ newEmptyMVar
progress <- liftIO $ newMVar 0
_ <- liftIO $ forkIO $ loadMapFork ud future progress
putAffection ud
{ stateData = None
, uuid = [uu1, uu2]
, stateMVar = future
, stateProgress = progress
}
changeMaps :: KeyboardMessage -> Affection UserData ()
changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeF1 = do
ud <- getAffection
putAffection ud
{ state = Main WorldMap
}
| SDL.keysymKeycode sym == SDL.KeycodeF2 = do
ud <- getAffection
putAffection ud
{ state = Main MindMap
}
| otherwise = return ()
changeMaps _ = return ()
loadMapFork
:: UserData
-> MVar (SystemState Entity IO, StateData)
-> MVar Float
-> IO ()
loadMapFork ud future progress = do
let loadSteps = 18
fc = FloorConfig
(10, 10)
[(5, 5), (5, 45)]
(50, 50)
_ <- liftIO $ swapMVar progress (1 / loadSteps)
(mat, gr) <- buildHallFloorIO fc progress (1 / loadSteps)
_ <- liftIO $ swapMVar progress (11 / loadSteps)
let imgmat = convertTileToImg mat
exits = Prelude.foldl
(\acc coord@(r, c) -> if imgmat M.! coord == Just ImgEmpty
then ReachPoint RoomExit (V2 r c) NE : acc
else acc
)
[]
((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat])
_ <- liftIO $ swapMVar progress (12 / loadSteps)
(inter, rps) <- placeInteriorIO mat imgmat exits gr
_ <- liftIO $ swapMVar progress (13 / loadSteps)
logIO A.Debug ("number of reachpoints: " ++ show (length rps))
let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps
npcposs <- placeNPCs inter mat rps gr 50 -- (length nnex)
_ <- liftIO $ swapMVar progress (14 / loadSteps)
A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs)
(mmintmat, mmgraph) <- buildFloorMap <$> springField <$>
buildMindMap (length npcposs) 3
_ <- liftIO $ swapMVar progress (15 / loadSteps)
let mmimgmat = convertTileToImg $ manhattan mmgraph mmintmat
_ <- liftIO $ swapMVar progress (16 / loadSteps)
(nws, _) <- yieldSystemT (worldState ud) $ do
let pmmpos = ((+ 0.5) . fromIntegral . floor) <$> mmPos
(fromJust $ find (\a -> mmId a == 0) (vertexList mmgraph))
delta = [(0, 0)] ++
Prelude.filter (/= (0,0)) ((,) <$> [-1 .. 1] <*> [-1 .. 1]) :: [(Int, Int)]
mmpos = Prelude.foldl (\acc (dr, dc) ->
let (V2 pmr pmc) = floor <$> pmmpos
seekpos = (pmr + fromIntegral dr, pmc + fromIntegral dc)
in if mmimgmat M.! seekpos == Nothing && mmintmat M.! seekpos == 0
&& acc == Nothing
then Just (pmmpos + (fromIntegral <$> V2 dr dc))
else acc
) Nothing delta
void $ createEntity $ newEntity
{ pos = Just (V2 10.5 10.5)
, mmpos = mmpos
, vel = Just (V2 0 0)
, mmvel = Just (V2 0 0)
, player = Just ()
, rot = Just SE
, mmrot = Just SE
, anim = Just $ AnimState (AnimId 0 "standing" SE) 0 0
}
void $ liftIO $ swapMVar progress (17 / loadSteps)
void $ mapM_ (\npcpos@(V2 nr nc) -> do
fact <- liftIO $ randomRIO (0.5, 1.5)
future <- liftIO newEmptyMVar
_ <- liftIO $ forkIO $ getPath (fmap floor npcpos) future nnex inter
void $ createEntity $ newEntity
{ pos = Just (V2 (nr + 0.5) (nc + 0.5))
, vel = Just (V2 0 0)
, velFact = Just fact
, rot = Just SE
, npcMoveState = Just (NPCStanding 0 future)
, anim = Just $ AnimState (AnimId 1 "standing" SE) 0 0
}
) npcposs
void $ liftIO $ swapMVar progress (18 / loadSteps)
putMVar future (nws, MainData
{ mapMat = mat
, imgMat = M.fromList (nrows inter) (ncols inter) $
Prelude.map
(\a -> if a == Just ImgEmpty then Nothing else a)
(M.toList inter)
, reachPoints = rps
, mmImgMat = mmimgmat
})
mouseToPlayer :: V2 Int32 -> Affection UserData ()
mouseToPlayer mv2 = do
ud <- getAffection
(V2 rx ry) <- liftIO $ relativizeMouseCoords mv2
let dr = (ry / sin (atan (1/2)) / 2) + rx
dc = rx - (ry / sin (atan (1/2)) / 2)
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $
emap allEnts $ do
with player
pure $ unchanged
{ vel = Set $ 4 * V2 dr dc
}
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, _) <- liftIO $ yieldSystemT (worldState ud) $
emap allEnts $ do
with player
pure $ unchanged
{ vel = Set $ V2 0 0
}
putAffection ud
{ worldState = nws
}
movePlayer _ = return ()
drawMap :: Affection UserData ()
drawMap = do
ud <- getAffection
let ctx = nano ud
case stateData ud of
None -> liftIO $ do
progress <- readMVar (stateProgress ud)
drawLoadScreen ud progress
_ -> do
dt <- getDelta
(_, (playerPos, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do
pc <- fmap head $ efor allEnts $ do
with player
with pos
query pos
posanims <- efor allEnts $ do
with anim
with pos
stat <- query anim
pos' <- query pos
return (pos', stat)
return (pc, posanims)
let V2 pr pc = playerPos
mat = imgMat (stateData ud)
cols = fromIntegral (ncols mat)
rows = fromIntegral (nrows mat)
tileWidth = 64 :: Double
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)]
)
)
)
processList
:: [(V2 Double, AnimState)]
-> (Int, Int)
-> ([(V2 Double, AnimState)], [(V2 Double, AnimState)])
processList list coord@(r, c) =
let delimiter (V2 nr nc, _) =
floor nr == r && floor nc == c
in L.partition delimiter list
liftIO $ do -- draw floor
beginPath ctx
moveTo ctx (x + realToFrac tileWidth / 2) y
lineTo ctx
(x + cols * (realToFrac tileWidth / 2))
(y - (realToFrac tileHeight / 2) * (cols - 1))
lineTo ctx
(x + (realToFrac tileWidth / 2) * (cols + rows - 1))
(y + (rows - cols) * (realToFrac tileHeight / 2))
lineTo ctx
(x + (realToFrac tileWidth / 2) * rows)
(y + (realToFrac tileHeight / 2) * (rows - 1))
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))
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
:: UserData
-> Context
-> [(V2 Double, AnimState)]
-> Double
-> Double
-> Int
-> Int
-> 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.!) <$> img)
mapM_ drawAnim bef
restore ctx
where
delimiter (V2 nr nc, _) =
all delimit mb
where
delimit b
| nnr > fst (matmin b) && nnr < fst (matmax b) =
nnc < snd (matmin b)
| nnc > snd (matmin b) && nnc < snd (matmax b) =
nnr > fst (matmax b)
| otherwise =
True
nnr = nr - fromIntegral (floor nr)
nnc = nc - fromIntegral (floor nc)
-- any (\m -> nr < fromIntegral (floor nr :: Int) + m) maxrs &&
-- any (\m -> nc > fromIntegral (floor nc :: Int) + m) mincs
ai = assetImages ud
anims = assetAnimations ud
tileWidth = 64 :: Double
tileHeight = 32 :: Double
sorted = sortOn (\(V2 sr sc, _) -> sc + sr * fromIntegral col) posanims
minrs = Prelude.map (fst . matmin) mb
maxrs = Prelude.map (fst . matmax) mb
mincs = Prelude.map (snd . matmin) mb
maxcs = Prelude.map (snd . matmax) mb
x = realToFrac $ 640 + ((fromIntegral col - pc) +
(fromIntegral row - pr)) * (tileWidth / 2) :: CFloat
y = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) -
(fromIntegral col - pc)) * (tileHeight / 2) :: CFloat
dist = distance (V2 (fromIntegral row) (fromIntegral col))
(V2 (realToFrac pr - 1) (realToFrac pc)) / 4
fact =
if (pr <= fromIntegral row + minimum maxrs &&
pc >= fromIntegral col + maximum mincs) &&
isWall (fromJust img)
then min 1 dist
else 1
mb = maybe [] collisionObstacle img
drawAnim (V2 nr nc, as) = do
let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32 - 32
ay = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16 - 58
draw ud ax ay 64 74 1 as
updateMap :: Double -> Affection UserData ()
updateMap dt = do
ud <- getAffection
isFut <- liftIO $ isEmptyMVar (stateMVar ud)
if not isFut && stateData ud == None
then do
liftIO $ logIO A.Debug "Loaded game data"
Just (nws, mendat) <- liftIO $ tryTakeMVar (stateMVar ud)
putAffection ud
{ worldState = nws
, stateData = mendat
}
else 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'
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
emap allEnts $ do
with anim
with pos
stat <- query anim
let an = assetAnimations ud Map.! asId stat
ntime = asElapsedTime stat + dt
nstate = if ntime > fromIntegral (asCurrentFrame stat) *
(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
}
emap allEnts $ do
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'
}
}
| otherwise ->
stat
{ asId = aId
{ aiDirection = direction vel' rot'
, aiName = "standing"
}
, asCurrentFrame = 0
}
"standing"
| sqrt (vel' `dot` vel') > 0 ->
stat
{ asId = aId
{ aiDirection = direction vel' rot'
, aiName = "walking"
}
, asCurrentFrame = 0
}
| otherwise ->
stat
{ asId = aId
{ aiDirection = direction vel' rot'
}
}
x -> error ("unknown animation name" ++ x)
ent = unchanged
{ pos = Set npos
, 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'
}
}
| otherwise ->
stat
{ asId = aId
{ aiDirection = direction vel' rot'
, aiName = "standing"
}
, asCurrentFrame = 0
}
"standing"
| sqrt (colldpos `dot` colldpos) > 0 ->
stat
{ asId = aId
{ aiDirection = direction vel' rot'
, aiName = "walking"
}
, asCurrentFrame = 0
}
| otherwise ->
stat
{ asId = aId
{ aiDirection = direction vel' rot'
}
}
x -> error ("unknown animation name" ++ x)
len = sqrt (dpos `dot` dpos)
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)))
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 (direction vel' rot')
, anim = Set nstat
}
return ent
updateNPCs
(imgMat $ stateData ud)
(Prelude.filter
(\p -> pointType p /= RoomExit)
(reachPoints $ stateData ud)
)
dt
putAffection ud
{ worldState = nws
}
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 && incol = V2 0 1 * acc
| colltc < dt && inrow = V2 1 0 * acc
| otherwise = acc
where
V2 vr vc = fmap (/ dt) (nex - pre)
colltr
| vr > 0 && prr <= maxr =
((fromIntegral (floor pr :: Int) + minr - 0.15) - pr) / vr
| vr < 0 && prr >= minr =
((fromIntegral (floor pr :: Int) + maxr + 0.15) - pr) / vr
| otherwise = dt
colltc
| vc > 0 && prc <= maxc =
((fromIntegral (floor pc :: Int) + minc - 0.15) - pc) / vc
| vc < 0 && prc >= minc =
((fromIntegral (floor pc :: Int) + maxc + 0.15) - pc) / vc
| otherwise = dt
inrow = pr > minr && pr < maxr
incol = pc > minc && pc < maxc
prr = pr - fromIntegral (floor pr :: Int)
prc = pc - fromIntegral (floor pc :: Int)