tracer/src/MainGame/WorldMap.hs
2019-03-07 16:43:00 +01:00

919 lines
31 KiB
Haskell

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE BangPatterns #-}
module MainGame.WorldMap where
import Affection as A
import Algebra.Graph as AG hiding (Context(..))
import qualified SDL
import NanoVG hiding (V2(..))
import Control.Monad (when, void)
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
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
import Animation
import Collision
loadMap :: Affection UserData ()
loadMap = do
ud <- getAffection
ad <- get
let (Subsystems _ m k j t) = subsystems ud
uu0 <- partSubscribe k emitKbdActionMessage
uu1 <- partSubscribe j emitJoyActionMessage
uu2 <- partSubscribe t movePlayer2
uu3 <- partSubscribe t playerInteract2
uu4 <- partSubscribe t changeMaps2
future <- liftIO newEmptyMVar
progress <- liftIO $ newMVar (0, "Ohai!")
_ <- liftIO $ forkIO $ loadMapFork ud ad future progress
putAffection ud
{ stateData = None
, uuid = [ uu0, uu1, uu2, uu3, uu4 ]
, stateMVar = future
, stateProgress = progress
, state = Main WorldMap
}
changeMaps :: KeyboardMessage -> Affection UserData ()
changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeF1 = do
ud <- getAffection
case state ud of
Main MindMap ->
putAffection ud
{ state = Main WorldMap
}
Main WorldMap ->
putAffection ud
{ state = Main MindMap
}
_ -> return ()
| otherwise = return ()
changeMaps _ = return ()
changeMaps2 :: ActionMessage -> Affection UserData ()
changeMaps2 (ActionMessage ActSwitchMap _) = do
ud <- getAffection
case state ud of
Main MindMap ->
putAffection ud
{ state = Main WorldMap
}
Main WorldMap ->
putAffection ud
{ state = Main MindMap
}
_ -> return ()
changeMaps2 _ = return ()
loadMapFork
:: UserData
-> AffectionData UserData
-> MVar (SystemState Entity (AffectionState (AffectionData UserData) IO), StateData)
-> MVar (Float, T.Text)
-> IO ()
loadMapFork ud ad future progress = do
let loadSteps = 23
increment = 1 / loadSteps
fc = FloorConfig
(V2 10 10)
[(V2 5 5), (V2 5 20)]
(50, 50)
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Building floor"
)))
(mat, gr) <- buildHallFloorIO fc progress increment -- 11 increments inside
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Converting to images"
)))
let !imgmat = convertTileToImg mat
!doors = Prelude.foldl
(\acc coord@(r, c) -> if mat M.! coord == Door
then V2 r c : acc
else acc
)
[]
((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat])
!exits = Prelude.foldl
(\acc coord@(r, c) -> if imgmat M.! coord == Just ImgEmpty
then ReachPoint RoomExit (V2 r c) NE 0 : acc
else acc
)
[]
((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat])
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Placing furniture"
)))
(!inter, !rawrps) <- placeInteriorIO mat imgmat exits gr
let !rps = ReachPoint Elevator (fcElevator fc) SE 0 : rawrps
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Creating WorldState"
)))
(nws, mmimgmat) <- evalStateT (runState (yieldSystemT (worldState ud) $ do
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Registering copiers into WorldState"
)))
let !copiers = Prelude.filter (\a -> pointType a == Copier) rps
mapM_ (\(ReachPoint _ icoord _ _) -> do
let reachCoord = fmap ((+ 0.5) . fromIntegral) icoord
void $ createEntity $ newEntity
{ pos = Just $ reachCoord - V2 1 0
, obstacle = Just $ Boundaries (10/36, 8/36) (28/36, 30/36)
, anim = Just $ AnimState (AnimId AnimCopier "open" N) 0 0
, objAccess = Just [(V2 1 0, NW)]
, objType = Just ObjCopier
, objState = Just "idle"
}
) (A.log A.Debug ("number of copiers: " ++ show (length copiers)) copiers)
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Registering computers into WorldState"
)))
let !computers = Prelude.filter ((Computer ==) . pointType) rps
mapM_ (\(ReachPoint _ icoord dir _) -> do
let reachCoord = fmap ((+ 0.5) . fromIntegral) icoord
access = case dir of
N -> V2 1 (-1)
NE -> V2 0 (-1)
NW -> V2 1 0
x -> error ("computer placement " ++ show x ++ " not defined")
void $ createEntity $ newEntity
{ pos = Just $ reachCoord - fmap fromIntegral access
, anim = Just $ AnimState (AnimId AnimComputer "off" dir) 0 0
, rot = Just dir
, objAccess = Just [(access, dir)]
, objType = Just ObjComputer
, objState = Just "off"
}
) (A.log A.Debug ("number of computers: " ++ show (length computers)) computers)
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Registering toilets into WorldState"
)))
let !toilets = Prelude.filter (\a -> pointType a == Toilet) rps
mapM_ (\(ReachPoint _ icoord dir _) -> do
let reachCoord = fmap ((+ 0.5) . fromIntegral) icoord
void $ createEntity $ newEntity
{ pos = Just $ reachCoord - V2 0 (-1)
, obstacle = Just $ Boundaries (0, 0) (1, 1)
, anim = Just $ AnimState (AnimId AnimToilet "free" N) 0 0
, objAccess = Just [(V2 0 (-1), dir)]
, objType = Just ObjToilet
}
) (A.log A.Debug ("number of toilets: " ++ show (length toilets)) toilets)
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Preparing MindMap graph"
)))
(mmintmat, mmgraph) <- liftIO $ buildFloorMap . springField <$>
buildMindMap (length computers) 2
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Unfolding and Converting MindMap to images"
)))
let !mmimgmat = convertTileToImg $ manhattan mmgraph mmintmat
!pmmpos = (+ 0.5) . (fromIntegral :: Int -> Double) . floor <$> mmPos
(fromJust $ find (\a -> mmId a == 0) (vertexList mmgraph))
!delta = (0, 0) :
Prelude.filter (/= (0,0)) ((,) <$> [-1 .. 1] <*> [-1 .. 1]) :: [(Int, Int)]
!mmmpos = Prelude.foldl (\acc (dr, dc) ->
let (V2 pmr pmc) = floor <$> pmmpos
seekpos = (pmr + fromIntegral dr, pmc + fromIntegral dc)
in if isNothing (mmimgmat M.! seekpos) && mmintmat M.! seekpos == 0
&& isNothing acc
then Just (pmmpos + (fromIntegral <$> V2 dr dc))
else acc
) Nothing delta
void $ createEntity $ newEntity
{ pos = Just (V2 10.5 10.5)
, mmpos = mmmpos
, vel = Just (V2 0 0)
, xyvel = Just (V2 0 0)
, mmvel = Just (V2 0 0)
, player = Just ()
, rot = Just SE
, clearanceLvl = Just 0
, anim = Just $ AnimState (AnimId AnimIntruder "standing" SE) 0 0
}
liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length computers)
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Registering NPCs into WorldState"
)))
mapM_ (\cpr -> do
fact <- liftIO $ randomRIO (0.5, 1.5)
stats <- liftIO $ NPCStats
<$> (randomRIO (0, 1))
<*> pure 0
<*> (randomRIO (0, 1))
<*> (randomRIO (0, 1))
<*> (randomRIO (0, 1))
<*> (randomRIO (0, 1))
let room = head
(Prelude.filter
((inBounds $ pointCoord cpr) . bounds)
(Types.connects (head gr) ++ tail gr)
)
void $ createEntity $ newEntity
{ pos = Just (fmap ((+ 0.5) . fromIntegral) (pointCoord cpr))
, vel = Just (V2 0 0)
, velFact = Just fact
, rot = Just SE
, npcMoveState = Just (NPCWalking [pointCoord cpr])
, npcWorkplace = Just cpr
, npcActionState = Just ASWork
, npcStats = Just stats
, clearanceLvl = Just (clearance room)
, anim = Just $ AnimState (AnimId AnimJDoeM "standing" SE) 0 0
}
) computers
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Registering doors into WorldState"
)))
mapM_ (\door -> do
let rooms = Prelude.foldl
(\acc coord ->
let rs = Prelude.filter ((inBounds coord) . bounds) graph
in
if not (Prelude.null rs)
then (coord, head rs) : acc
else acc
)
[]
coords
graph = Types.connects (head gr) ++ tail gr
coords = Prelude.map (door +) deltas
deltas =
[ V2 0 1
, V2 1 0
, V2 (-1) 0
, V2 0 (-1)
]
wall = Prelude.filter
(\delta ->
let V2 r c = door + delta
in
fromMaybe False (isWall <$> imgmat M.! (r, c)))
deltas
orientation
| head wall == V2 0 1 || head wall == V2 0 (-1) = NW
| head wall == V2 1 0 || head wall == V2 (-1) 0 = NE
| otherwise = error ("strange wall: " ++ show wall)
void $ createEntity $ newEntity
{ pos = Just (fmap ((+ 0.5) . fromIntegral) door)
, clearanceLvl = Just (maximum $ 0 : Prelude.map clearance (Prelude.map snd rooms))
, anim = Just $ AnimState (AnimId AnimDoor0 "shut" orientation) 0 1
, obstacle = Just $ case orientation of
NW -> Boundaries (4/9, 0) (5/9, 1)
NE -> Boundaries (0, 4/9) (1, 5/9)
_ -> error "strange orientation for door"
, ignoreObstacle = Just ()
, rot = Just orientation
, objAccess = Just $ case orientation of
NW ->
[ ((V2 (-1) 0), SE)
, ((V2 1 0), NW)
]
NE ->
[ ((V2 0 1), SW)
, ((V2 0 (-1)), NE)
]
_ -> error "strange orientation for door"
, objType = Just ObjDoor
, objState = Just "shut"
}
) doors
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Handing over"
)))
return mmimgmat
)) ad
let !retMat = M.fromList (nrows inter) (ncols inter) $
Prelude.map
(\a -> if a == Just ImgEmpty || a == Just ImgEmptyNoWalk
then Nothing
else a)
(M.toList inter)
putMVar future (nws, MainData
{ mapMat = mat
, imgMat = retMat
, reachPoints = rps
, mmImgMat = mmimgmat
, roomGraph = gr
})
movePlayerKbd :: KeyboardMessage -> Affection UserData ()
movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
| SDL.keysymKeycode sym == SDL.KeycodeW = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
(V2 vx _) <- query xyvel
let ry = if (press == SDL.Pressed)
then 1
else 0
return $ unchanged
{ xyvel = Set $ V2 vx ry
}
putAffection ud
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeS = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
(V2 vx _) <- query xyvel
let ry = if (press == SDL.Pressed)
then -1
else 0
return $ unchanged
{ xyvel = Set $ V2 vx ry
}
putAffection ud
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeA = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
(V2 _ vy) <- query xyvel
let rx = if (press == SDL.Pressed)
then -1
else 0
return $ unchanged
{ xyvel = Set $ V2 rx vy
}
putAffection ud
{ worldState = nws
}
| SDL.keysymKeycode sym == SDL.KeycodeD = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
(V2 _ vy) <- query xyvel
let rx = if (press == SDL.Pressed)
then 1
else 0
return $ unchanged
{ xyvel = Set $ V2 rx vy
}
putAffection ud
{ worldState = nws
}
| otherwise = return ()
movePlayerKbd _ = return ()
movePlayer2 :: ActionMessage -> Affection UserData ()
movePlayer2 (ActionMessage mov _) = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $
emap allEnts $ do
with player
V2 vx vy <- query xyvel
return $ unchanged
{ xyvel = Set $ case mov of
ActUp f -> V2 vx (-f)
ActDown f -> V2 vx f
ActLeft f -> V2 (-f) vy
ActRight f -> V2 f vy
_ -> V2 vx vy
}
putAffection ud
{ worldState = nws
}
movePlayer2 _ = return ()
playerInteract :: MouseMessage -> Affection UserData ()
playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
ud <- getAffection
(V2 rx ry) <- liftIO $ (* V2 640 360) <$> relativizeMouseCoords m
let dr = ((ry / 32) / sin (atan 0.5) / 2) + (rx / 64)
dc = (rx / 64) - ((ry / 32) / sin (atan 0.5) / 2)
(nws, _) <- yieldSystemT (worldState ud) $ do
emap allEnts $ do
with player
with rot
rot' <- query rot
let ndir = direction (V2 dr dc)
return $ unchanged
{ rot = Set $ fromMaybe rot' ndir
}
pdata <- efor allEnts $ do
with player
with pos
with rot
pos' <- query pos
rot' <- query rot
ent <- queryEnt
return (pos', rot', ent)
let (ppos, pdir, pent) = head pdata
mrelEnts <- efor allEnts $ do
with pos
with objAccess
with objType
with objState
reldirs <- query objAccess
pos' <- query pos
otype <- query objType
ostate <- query objState
ent <- queryEnt
if any (\(rel, dir) -> ((fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) ||
(fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) + rel) &&
(fmap floor (ppos + V2 dr dc) :: V2 Int) == (fmap floor pos' ::V2 Int) &&
pdir == dir) reldirs
then return $ Just (otype, ostate, ent)
else return Nothing
let relEnts = catMaybes mrelEnts
liftIO $ A.logIO A.Debug ("relEnts: " ++ show relEnts)
-- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc))
mapM_ (\(t, s, e) ->
setEntity e =<< objectTransition t s True e (Just pent)
) relEnts
putAffection ud
{ worldState = nws
}
playerInteract _ = return ()
playerInteract2 :: ActionMessage -> Affection UserData ()
playerInteract2 (ActionMessage ActActivate _) = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $ do
pdata <- efor allEnts $ do
with player
with pos
with rot
pos' <- query pos
rot' <- query rot
ent <- queryEnt
return (pos', rot', ent)
let (ppos, pdir, pent) = head pdata
mrelEnts <- efor allEnts $ do
with pos
with objAccess
with objType
with objState
reldirs <- query objAccess
pos' <- query pos
otype <- query objType
ostate <- query objState
ent <- queryEnt
if any (\(rel, dir) -> ((fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) ||
(fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) + rel) &&
pdir == dir) reldirs
then return $ Just (otype, ostate, ent)
else return Nothing
let relEnts = catMaybes mrelEnts
liftIO $ A.logIO A.Debug ("relEnts: " ++ show relEnts)
-- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc))
mapM_ (\(t, s, e) ->
setEntity e =<< objectTransition t s True e (Just pent)
) relEnts
putAffection ud
{ worldState = nws
}
playerInteract2 _ = 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
(_, dat) <- yieldSystemT (worldState ud) $ do
efor allEnts $ do
with pos
pos' <- query pos
player <- queryMaybe player
stat <- queryMaybe anim
mbnds <- queryMaybe obstacle
t <- queryMaybe objType
s <- queryMaybe objState
pa <- queryMaybe objPlayerActivated
ttl <- queryMaybe objStateTime
let maxt = fromMaybe 1 (actionTime <$> t <*> s)
first = if isJust player
then Just
pos'
else Nothing
secnd = if isJust stat
then Just
( pos'
, fromJust stat
, mbnds
)
else Nothing
third = if isJust t && isJust s
then Just
( pos'
, fromMaybe False pa
, realToFrac (1 - fromMaybe 0 ttl / maxt)
)
else Nothing
return (first, secnd, third)
let ((playerPos:_), posanims, posActions) = Prelude.foldl
(\(amppo, ampan, ampac) (mppo, mpan, mpac) ->
( if isJust mppo then fromJust mppo : amppo else amppo
, if isJust mpan then fromJust mpan : ampan else ampan
, if isJust mpac then fromJust mpac : ampac else ampac
)
)
([], [], [])
dat
V2 pr pc = playerPos
MainData _ _ _ _ gr = stateData ud
seekGraph = Types.connects (head gr) ++ tail gr
room = Prelude.filter (inBounds (fmap floor playerPos) . bounds) seekGraph
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, Maybe (Boundaries Double))]
-> (Int, Int)
-> ( [(V2 Double, AnimState, Maybe (Boundaries Double))]
, [(V2 Double, AnimState, Maybe (Boundaries Double))]
)
processList list (r, c) =
let delimiter (V2 nr nc, _, _) =
floor nr == r && floor nc == c
in L.partition delimiter list
liftIO $ do
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
-- void $ sequence $ parMap rpar
mapM_
(\(i, ls) ->
-- void $ sequence $ parMap rpar
mapM_
(\(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
ly = realToFrac $ 360 - (tileHeight / 2) + ((sr - pr) -
(sc - pc)) * (tileHeight / 2) :: CFloat
fillColor ctx (rgb 0 255 0)
strokeColor ctx (rgb 0 255 0)
strokeWidth ctx 2
beginPath ctx
rect ctx (lx - 25) (ly - 50) 50 10
stroke ctx
closePath ctx
beginPath ctx
rect ctx (lx - 25 * perc) (ly - 50) (50 * perc) 10
fill ctx
closePath ctx
) posActions
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.pack (Prelude.take 5 $ show (1/dt))
<> " Clearance: "
<> if not (Prelude.null room) then T.pack (show $ clearance $ head room) else "0"
)
drawTile
:: UserData
-> Context
-> [(V2 Double, AnimState, Maybe (Boundaries Double))]
-> 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.!) <$> 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) ||
all delimit mb
where
delimit b
| nnr > fst (matmax b) || nnc < snd (matmin b) =
True
| 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 =
False
nnr = case mbnds of
Just (Boundaries (_, _) (maxr, _)) -> maxr
Nothing -> nr - fromIntegral ((floor nr) :: Int) :: Double
nnc = case mbnds of
Just (Boundaries (_, minc) (_, _)) -> minc
Nothing -> nc - fromIntegral ((floor nc) :: Int) :: Double
tileWidth = 64 :: Double
tileHeight = 32 :: Double
sorted = sortOn (\(V2 sr sc, _, mbnds) ->
let comp srow scol = (floor $ (1 - scol) * 100) + (floor $ srow * 100)
in
case mbnds of
Just (Boundaries (minr, minc) (maxr, maxc)) ->
comp (minr + ((maxr - minr) / 2)) (minc + (maxc - minc) / 2)
_ ->
comp
(sr - (fromIntegral ((floor sr) :: Int)))
(sc - (fromIntegral ((floor sc) :: Int)))
) 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 isWall (fromJust img) &&
(pr <= fromIntegral row + minimum maxrs &&
pc >= fromIntegral col + maximum mincs)
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
if stateData ud == None
then do
mstart <- liftIO $ tryTakeMVar (stateMVar ud)
case mstart of
Just (nws, mendat) -> do
putAffection ud
{ worldState = nws
, stateData = mendat
, state = Main WorldMap
}
updateMap 0.1
updateMap 0.1
updateMap 0.1
updateMap 19
liftIO $ logIO A.Debug "Loaded game data"
Nothing -> return ()
else 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
pos'@(V2 pr pc) <- query pos
vel' <- queryMaybe vel
rot' <- query rot
fact' <- fromMaybe 1 <$> queryMaybe velFact
xyv2 <- queryMaybe xyvel
stat <- query anim
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 = (,)
<$> (
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))
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 (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
allRelEnts <- efor allEnts $ do
with pos
with rot
with clearanceLvl
without objType
pos' <- query pos
rot' <- query rot
clvl <- query clearanceLvl
entn <- queryEnt
return (entn, pos', rot', clvl)
tses <- efor allEnts $ do
with objType
with objState
t <- query objType
s <- query objState
e <- queryEnt
return (t, s, e)
mapM_ (\(t, s, e) ->
objectAction allRelEnts dt t s e
) tses
(nws2, _) <- yieldSystemT nws $ updateNPCs
(imgMat $ stateData ud)
nws
(Prelude.filter
(\p -> pointType p /= RoomExit)
(reachPoints $ stateData ud)
)
dt
putAffection ud
{ worldState = nws2
}