892 lines
32 KiB
Haskell
892 lines
32 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.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
|
|
import qualified Data.Vector as V
|
|
import Data.String
|
|
|
|
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 :: UserData -> Affection ()
|
|
loadMap ud = do
|
|
ad <- get
|
|
let (Subsystems _ _ k j t) = subsystems ud
|
|
uu0 <- partSubscribe k (emitKbdActionMessage ud)
|
|
uu1 <- partSubscribe j (emitJoyActionMessage ud)
|
|
uu2 <- partSubscribe t (movePlayer2 ud)
|
|
uu3 <- partSubscribe t (playerInteract2 ud)
|
|
uu4 <- partSubscribe t (changeMaps2 ud)
|
|
void $ liftIO $ swapMVar (stateProgress ud) (0, "Ohai!")
|
|
_ <- liftIO $ forkIO $ loadMapFork ud ad (stateMVar ud) (stateProgress ud)
|
|
void $ liftIO $ swapMVar (stateData ud) None
|
|
void $ liftIO $ swapMVar (uuid ud) [ uu0, uu1, uu2, uu3, uu4 ]
|
|
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
|
|
|
|
changeMaps :: UserData -> KeyboardMessage -> Affection ()
|
|
changeMaps ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
|
| SDL.keysymKeycode sym == SDL.KeycodeF1 = do
|
|
curState <- liftIO $ readMVar (state ud)
|
|
case curState of
|
|
Main MindMap ->
|
|
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
|
|
Main WorldMap ->
|
|
void $ liftIO $ swapMVar (state ud) (Main MindMap)
|
|
_ -> return ()
|
|
| otherwise = return ()
|
|
changeMaps _ _ = return ()
|
|
|
|
changeMaps2 :: UserData -> ActionMessage -> Affection ()
|
|
changeMaps2 ud (ActionMessage ActSwitchMap _) = do
|
|
curState <- liftIO $ readMVar (state ud)
|
|
case curState of
|
|
Main MindMap ->
|
|
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
|
|
Main WorldMap ->
|
|
void $ liftIO $ swapMVar (state ud) (Main MindMap)
|
|
_ -> return ()
|
|
changeMaps2 _ _ = return ()
|
|
|
|
loadMapFork
|
|
:: UserData
|
|
-> AffectionData
|
|
-> MVar (SystemState Entity (AffectionState AffectionData 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)]
|
|
(40, 40)
|
|
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 (V.toList gr)
|
|
let !rps = ReachPoint Elevator (fcElevator fc) SE 0 : rawrps
|
|
modifyMVar_ progress (return . (\(p, _) ->
|
|
( p + increment
|
|
, "Creating WorldState"
|
|
)))
|
|
wState <- liftIO $ readMVar (worldState ud)
|
|
(nws, mmimgmat) <- evalStateT (runState (yieldSystemT wState $ 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: " <> fromString (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: " <> fromString (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: " <> fromString (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: " <> fromString (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))
|
|
police <- liftIO $ randomRIO (0 :: Int, 9 :: Int)
|
|
let room = V.head
|
|
(V.filter
|
|
((inBounds $ pointCoord cpr) . bounds)
|
|
(V.fromList $
|
|
V.toList (Types.connects (V.head gr)) ++ (V.toList (V.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 (if police == 0 then AnimPoliceM else AnimJDoeM) "standing" SE) 0 0
|
|
}
|
|
) computers
|
|
liftIO $ modifyMVar_ progress (return . (\(p, _) ->
|
|
( p + increment
|
|
, "Registering doors into WorldState"
|
|
)))
|
|
mapM_ (\door -> do
|
|
let rooms = V.foldl
|
|
(\acc coord ->
|
|
let rs = V.filter ((inBounds coord) . bounds) graph
|
|
in
|
|
if not (V.null rs)
|
|
then (coord, V.head rs) `V.cons` acc
|
|
else acc
|
|
)
|
|
V.empty
|
|
(V.fromList coords)
|
|
graph = V.fromList $
|
|
(V.toList $ Types.connects (V.head gr)) ++ (V.toList $ V.tail gr)
|
|
coords = Prelude.map (door +) deltas
|
|
deltas =
|
|
[ V2 0 1
|
|
, V2 1 0
|
|
, V2 (-1) 0
|
|
, V2 0 (-1)
|
|
]
|
|
wall = Prelude.filter
|
|
(\ddelta ->
|
|
let V2 r c = door + ddelta
|
|
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 (V.maximum $
|
|
0 `V.cons` V.map clearance (V.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)
|
|
void $ putMVar future (nws, MainData
|
|
{ mapMat = mat
|
|
, imgMat = retMat
|
|
, reachPoints = V.fromList rps
|
|
, mmImgMat = mmimgmat
|
|
, roomGraph = gr
|
|
})
|
|
|
|
movePlayerKbd :: UserData -> KeyboardMessage -> Affection ()
|
|
movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym)
|
|
| SDL.keysymKeycode sym == SDL.KeycodeW = do
|
|
wState <- liftIO $ readMVar (worldState ud)
|
|
(nws, _) <- yieldSystemT wState $
|
|
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
|
|
}
|
|
void $ liftIO $ swapMVar (worldState ud) nws
|
|
| SDL.keysymKeycode sym == SDL.KeycodeS = do
|
|
wState <- liftIO $ readMVar (worldState ud)
|
|
(nws, _) <- yieldSystemT wState $
|
|
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
|
|
}
|
|
void $ liftIO $ swapMVar (worldState ud) nws
|
|
| SDL.keysymKeycode sym == SDL.KeycodeA = do
|
|
wState <- liftIO $ readMVar (worldState ud)
|
|
(nws, _) <- yieldSystemT wState $
|
|
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
|
|
}
|
|
void $ liftIO $ swapMVar (worldState ud) nws
|
|
| SDL.keysymKeycode sym == SDL.KeycodeD = do
|
|
wState <- liftIO $ readMVar (worldState ud)
|
|
(nws, _) <- yieldSystemT wState $
|
|
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
|
|
}
|
|
void $ liftIO $ swapMVar (worldState ud) nws
|
|
| otherwise = return ()
|
|
movePlayerKbd _ _ = return ()
|
|
|
|
movePlayer2 :: UserData -> ActionMessage -> Affection ()
|
|
movePlayer2 ud (ActionMessage mov _) = do
|
|
wState <- liftIO $ readMVar (worldState ud)
|
|
(nws, _) <- yieldSystemT wState $
|
|
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
|
|
}
|
|
void $ liftIO $ swapMVar (worldState ud) nws
|
|
|
|
playerInteract2 :: UserData -> ActionMessage -> Affection ()
|
|
playerInteract2 ud (ActionMessage ActActivate _) = do
|
|
wState <- liftIO $ readMVar (worldState ud)
|
|
(nws, _) <- yieldSystemT wState $ 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: " <> fromString (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
|
|
void $ liftIO $ swapMVar (worldState ud) nws
|
|
playerInteract2 _ _ = return ()
|
|
|
|
drawMap :: UserData -> Affection ()
|
|
drawMap ud = do
|
|
sData <- liftIO $ readMVar (stateData ud)
|
|
wState <- liftIO $ readMVar (worldState ud)
|
|
let ctx = nano ud
|
|
case sData of
|
|
None -> liftIO $ do
|
|
progress <- readMVar (stateProgress ud)
|
|
drawLoadScreen ud progress
|
|
_ -> do
|
|
dt <- getDelta
|
|
(_, dat) <- yieldSystemT wState $ 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 = sData
|
|
seekGraph = V.foldl V.snoc (Types.connects (V.head gr)) (V.tail gr)
|
|
room = V.filter (inBounds (fmap floor playerPos) . bounds) seekGraph
|
|
mat = imgMat sData
|
|
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 sData)
|
|
(ncols $ mapMat sData)
|
|
((reverse . fst)
|
|
(Prelude.foldl
|
|
(\(done, proc) coord ->
|
|
let (ndone, nproc) = processList proc coord
|
|
in (ndone : done, nproc)
|
|
)
|
|
([], posanims)
|
|
((,)
|
|
<$> [1 .. (nrows $ mapMat sData)]
|
|
<*> [1 .. (ncols $ mapMat sData)]
|
|
)
|
|
)
|
|
)
|
|
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
|
|
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), _) ->
|
|
((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
|
|
-- mapM_
|
|
(\((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
|
|
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
|
|
aFonts <- readMVar (assetFonts ud)
|
|
fontFace ctx (aFonts 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 $ V.head room)
|
|
else "0"
|
|
)
|
|
<> "\nFor answers call 6350"
|
|
)
|
|
|
|
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 = do
|
|
let (bef, beh) = L.partition delimiter sorted
|
|
aImages <- readMVar (assetImages ud)
|
|
save ctx
|
|
mapM_ (flip drawAnim fact) beh
|
|
maybe (return ()) (Types.draw ud x (y - 42) 64 74
|
|
(if fromMaybe False (isWall <$> img) then fact else 1))
|
|
((aImages Map.!) <$> case img of
|
|
Just ImgEmpty -> Nothing
|
|
_ -> img
|
|
)
|
|
mapM_ (flip drawAnim fact) 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) :: Int) + ((floor $ srow * 100) :: Int)
|
|
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 pr <= fromIntegral row + (if L.null maxrs then 0.5 else minimum maxrs) &&
|
|
pc >= fromIntegral col + (if L.null mincs then 0.5 else maximum mincs)
|
|
then min 1 dist
|
|
else 1
|
|
mb = maybe [] collisionObstacle img
|
|
drawAnim (V2 nr nc, as, _) factor = do
|
|
let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32 - 32
|
|
ay = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16 - 58
|
|
Types.draw ud ax ay 64 74 (if isWallLike (aiVariation $ asId as) then factor else 1) as
|
|
|
|
updateMap :: UserData -> Double -> Affection ()
|
|
updateMap ud dt = do
|
|
osData <- liftIO $ readMVar (stateData ud)
|
|
if osData == None
|
|
then do
|
|
mstart <- liftIO $ tryTakeMVar (stateMVar ud)
|
|
case mstart of
|
|
Just (nws, mendat) -> do
|
|
void $ liftIO $ swapMVar (worldState ud) nws
|
|
void $ liftIO $ swapMVar (stateData ud) mendat
|
|
void $ liftIO $ swapMVar (state ud) (Main WorldMap)
|
|
updateMap ud 0.1
|
|
updateMap ud 0.1
|
|
updateMap ud 0.1
|
|
updateMap ud 19
|
|
liftIO $ logIO A.Debug "Loaded game data"
|
|
Nothing -> return ()
|
|
else do
|
|
wState <- liftIO $ readMVar (worldState ud)
|
|
sData <- liftIO $ readMVar (stateData ud)
|
|
aAnim <- liftIO $ readMVar (assetAnimations ud)
|
|
(nws, _) <- yieldSystemT wState $ 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' <- fromMaybe N <$> queryMaybe rot
|
|
fact' <- fromMaybe 1 <$> queryMaybe velFact
|
|
xyv2 <- queryMaybe xyvel
|
|
stat <- query anim
|
|
let an = aAnim Map.! asId stat
|
|
mat = mapMat sData
|
|
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 (fromString $ show ret) ret)
|
|
(V2 1 1)
|
|
(
|
|
nub $ concatMap
|
|
(\(dr, dc) ->
|
|
let bs = (++)
|
|
(fromMaybe [] $ collisionObstacle <$> M.unsafeGet
|
|
(min (nrows mat) $ max 1 $ fromIntegral $ floor pr + dr)
|
|
(min (ncols mat) $ max 1 $ fromIntegral $ floor pc + dc)
|
|
(imgMat sData))
|
|
(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)
|
|
}
|
|
}
|
|
_ -> 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 dt t s e
|
|
) tses
|
|
(nws2, _) <- yieldSystemT nws $ updateNPCs
|
|
(imgMat sData)
|
|
(mapMat sData)
|
|
nws
|
|
(V.filter
|
|
(\p -> pointType p /= RoomExit)
|
|
(reachPoints sData)
|
|
)
|
|
dt
|
|
void $ liftIO $ swapMVar (worldState ud) nws2
|