nek0/tracer
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

various speed optimizations

Browse source
This commit is contained in:
nek0 2019-10-20 10:53:53 +02:00
parent 3cb28f396b
commit 7c59021aee
8 changed files with 126 additions and 104 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
cabal.config
View file

@ -1,2 +1,2 @@
constraints: affection +debug constraints: affection +verbose
profiling: True profiling: True

123
src/Floorplan.hs
View file

@ -6,6 +6,7 @@ import Data.Matrix (Matrix(..))
import qualified Data.Matrix as M import qualified Data.Matrix as M
import qualified Data.Text as T import qualified Data.Text as T
import Data.Maybe import Data.Maybe
import qualified Data.Vector as V
import Linear (V2(..)) import Linear (V2(..))
@ -24,7 +25,7 @@ buildHallFloorIO
:: FloorConfig :: FloorConfig
-> MVar (Float, T.Text) -> MVar (Float, T.Text)
-> Float -> Float
-> IO (Matrix TileState, [Graph]) -> IO (Matrix TileState, V.Vector Graph)
buildHallFloorIO fc progress increment = do buildHallFloorIO fc progress increment = do
rand <- newStdGen rand <- newStdGen
modifyMVar_ progress (return . (\(p, _) -> modifyMVar_ progress (return . (\(p, _) ->
@ -345,25 +346,30 @@ findNearestOffice mat (V2 rrr ccc) =
else acc else acc
) (fst $ head inlist) inlist ) (fst $ head inlist) inlist
buildDoorsGraph :: Matrix TileState -> IO [Graph] buildDoorsGraph :: Matrix TileState -> IO (V.Vector Graph)
buildDoorsGraph mat = buildDoorsGraph mat =
weedOut $ buildGraph mat mat [GHall []] (2, 2) weedOut (buildGraph mat mat (V.singleton (GHall V.empty)) (2, 2))
where where
weedOut (hall@(GHall _):gs) = (hall :) <$> weedOut gs weedOut vect = if V.null vect
weedOut (g@(GRoom neighs _ _ _):gs) = do then
let filtered = filter ((== Offi) . snd) neighs return V.empty
rand <- randomRIO (0, length filtered -1) :: IO Int else
let nneigh = filtered !! rand : [] case V.head vect of
rest <- weedOut gs hall@(GHall _) ->
return (g { neighbs = nneigh } : rest) (hall `V.cons`) <$> weedOut (V.tail vect)
weedOut [] = return [] g@(GRoom neighs _ _ _) -> do
let filtered = V.filter ((== Offi) . snd) neighs
rand <- randomRIO (0, length filtered -1) :: IO Int
let nneigh = filtered V.! rand `V.cons` V.empty
rest <- weedOut (V.tail vect)
return (g { neighbs = nneigh } `V.cons` rest)
buildGraph buildGraph
:: Matrix TileState :: Matrix TileState
-> Matrix TileState -> Matrix TileState
-> [Graph] -> V.Vector Graph
-> (Int, Int) -> (Int, Int)
-> [Graph] -> V.Vector Graph
buildGraph amat mat root coord@(br, bc) buildGraph amat mat root coord@(br, bc)
| bc > ncols amat - 1 = | bc > ncols amat - 1 =
buildGraph amat mat root (br + 1, 1) buildGraph amat mat root (br + 1, 1)
@ -374,29 +380,29 @@ buildGraph amat mat root coord@(br, bc)
b = Boundaries b = Boundaries
(minimum (map fst roomcoords), minimum (map snd roomcoords)) (minimum (map fst roomcoords), minimum (map snd roomcoords))
(maximum (map fst roomcoords), maximum (map snd roomcoords)) (maximum (map fst roomcoords), maximum (map snd roomcoords))
neighs = map (\(a, bx) -> (a, fromJust bx)) (filter ((/=Nothing) . snd) neighs = V.map (\(a, bx) -> (a, fromJust bx)) (V.filter ((/=Nothing) . snd)
[ (North, M.safeGet (fst (matmin b) - 2) (snd (matmin b)) amat) $ V.fromList
, (South, M.safeGet (fst (matmax b) + 2) (snd (matmin b)) amat) [ (North, M.safeGet (fst (matmin b) - 2) (snd (matmin b)) amat)
, (West, M.safeGet (fst (matmin b)) (snd (matmin b) - 2) amat) , (South, M.safeGet (fst (matmax b) + 2) (snd (matmin b)) amat)
, (East, M.safeGet (fst (matmin b)) (snd (matmax b) + 2) amat) , (West, M.safeGet (fst (matmin b)) (snd (matmin b) - 2) amat)
]) , (East, M.safeGet (fst (matmin b)) (snd (matmax b) + 2) amat)
])
in in
if Hall `elem` map snd neighs if Hall `V.elem` V.map snd neighs
then then
let nroot = let nroot =
if GRoom neighs b 0 Offi `notElem` connects (head root) if GRoom neighs b 0 Offi `V.notElem` connects (V.head root)
then then
GHall GHall
{ connects = connects (head root) ++ { connects = connects (V.head root) `V.snoc`
[GRoom neighs b 0 Offi] GRoom neighs b 0 Offi
} : tail root } `V.cons` V.tail root
else root else root
in buildGraph amat mat nroot (br, 1 + snd (matmax b)) in buildGraph amat mat nroot (br, 1 + snd (matmax b))
else else
let nroot = root ++ let nroot = if GRoom neighs b 0 Offi `V.elem` root
if GRoom neighs b 0 Offi `elem` root then root
then [] else root `V.snoc` GRoom neighs b 0 Offi
else [GRoom neighs b 0 Offi]
in buildGraph amat mat nroot (br, 1 + snd (matmax b)) in buildGraph amat mat nroot (br, 1 + snd (matmax b))
| otherwise = | otherwise =
buildGraph amat mat root (br, maxCol br (bc + 1)) buildGraph amat mat root (br, maxCol br (bc + 1))
@ -426,32 +432,32 @@ flood amat acc (fr, fc) =
else []) else [])
in foldl (flood amat) (acc ++ ncoords) ncoords in foldl (flood amat) (acc ++ ncoords) ncoords
assignClearance :: [Graph] -> M.Matrix TileState -> IO [Graph] assignClearance :: V.Vector Graph -> M.Matrix TileState -> IO (V.Vector Graph)
assignClearance graph imat = assignClearance graph imat =
foldM doAssignClearance [] graph V.foldM doAssignClearance V.empty graph
where where
doAssignClearance acc (GHall conns) = do doAssignClearance acc (GHall conns) = do
ret <- GHall <$> foldM (\facc a -> do ret <- GHall <$> V.foldM (\facc a -> do
res <- reassign True facc a res <- reassign True facc a
return (facc ++ [res]) return (facc `V.snoc` res)
) [] conns ) V.empty conns
return (ret : acc) return (ret `V.cons` acc)
doAssignClearance acc room = do doAssignClearance acc room = do
ret <- reassign False acc room ret <- reassign False acc room
return (acc ++ [ret]) return (acc `V.snoc` ret)
reassign :: Bool -> [Graph] -> Graph -> IO Graph reassign :: Bool -> V.Vector Graph -> Graph -> IO Graph
reassign p acc room@(GRoom ns b _ _) = reassign p acc room@(GRoom ns b _ _) =
if p if p
then do then do
if actualRoomType b imat == Offi if actualRoomType b imat == Offi
then do then do
let neigh = filter (all ((/= Hall) . snd) . neighbs) $ let neigh = V.filter (all ((/= Hall) . snd) . neighbs) $
catMaybes V.fromList $ catMaybes $ V.toList $
(map (V.map
(\n -> findNeighbor n b onlyrooms) (\n -> findNeighbor n b onlyrooms)
nonhalls nonhalls
) )
onlyrooms = tail graph onlyrooms = V.tail graph
nonhalls = ns -- filter ((/= Hall) . snd) ns nonhalls = ns -- filter ((/= Hall) . snd) ns
if not (null neigh) && any ((Offi /=) . flip actualRoomType imat . bounds) neigh if not (null neigh) && any ((Offi /=) . flip actualRoomType imat . bounds) neigh
then then
@ -464,16 +470,16 @@ assignClearance graph imat =
if actualRoomType b imat == Offi if actualRoomType b imat == Offi
then do then do
let neigh = let neigh =
catMaybes V.fromList $ catMaybes $ V.toList $
(map (V.map
(\n -> findNeighbor n b onlyrooms) (\n -> findNeighbor n b onlyrooms)
nonhalls nonhalls
) )
onlyrooms = connects (head acc) onlyrooms = connects (V.head acc)
nonhalls = ns -- filter ((/= Hall) . snd) ns nonhalls = ns -- filter ((/= Hall) . snd) ns
ret <- if null neigh ret <- if null neigh
then doRandomAssign room then doRandomAssign room
else doBoundedAssign room (clearance $ head neigh) else doBoundedAssign room (clearance $ V.head neigh)
return ret return ret
else else
return room return room
@ -501,7 +507,7 @@ doBoundedAssign g b = do
findNeighbor findNeighbor
:: (GraphDirection, TileState) :: (GraphDirection, TileState)
-> Boundaries Int -> Boundaries Int
-> [Graph] -> V.Vector Graph
-> Maybe Graph -> Maybe Graph
findNeighbor (dir, _) bnds ingraph findNeighbor (dir, _) bnds ingraph
| dir == North = | dir == North =
@ -522,27 +528,32 @@ findNeighbor (dir, _) bnds ingraph
in postprocess row col in postprocess row col
where where
postprocess row col = postprocess row col =
let filtered = filter let filtered = V.filter
(inBounds (V2 row col) . bounds) (inBounds (V2 row col) . bounds)
ingraph ingraph
in in
case filtered of if V.null filtered
[a@(GRoom _ _ _ _)] -> Just a then Nothing
[] -> Nothing else if V.length filtered == 1
_ -> error "findNeighbor: Non-singleton filter result" then
case V.head filtered of
a@(GRoom _ _ _ _) -> Just a
_ -> error "findNeighbor: Not a GRoom result"
else
error "findNeighbor: Non-Singleton filter result"
buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState) buildDoors :: Matrix TileState -> V.Vector Graph -> IO (Matrix TileState)
buildDoors = foldM placeDoors buildDoors = V.foldM placeDoors
placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState) placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState)
placeDoors amat (GHall conns) = placeDoors amat (GHall conns) =
foldM placeDoors amat conns foldM placeDoors amat conns
placeDoors amat (GRoom neighs bs _ _) = placeDoors amat (GRoom neighs bs _ _) =
if Hall `elem` map snd neighs if Hall `V.elem` V.map snd neighs
then do then do
let halls = filter ((== Hall) . snd) neighs let halls = V.filter ((== Hall) . snd) neighs
idx <- randomRIO (0, length halls - 1) idx <- randomRIO (0, length halls - 1)
let (dir, _) = halls !! idx let (dir, _) = halls V.! idx
case dir of case dir of
North -> North ->
inRow inRow
@ -566,7 +577,7 @@ placeDoors amat (GRoom neighs bs _ _) =
(snd (matmax bs) + 1) (snd (matmax bs) + 1)
else do else do
idx <- randomRIO (0, length neighs - 1) idx <- randomRIO (0, length neighs - 1)
let (dir, _) = neighs !! idx let (dir, _) = neighs V.! idx
case dir of case dir of
North -> North ->
inRow inRow

4
src/MainGame/MindMap.hs
View file

@ -135,10 +135,10 @@ updateMind dt = do
( (
concatMap concatMap
(\(dr, dc) -> (\(dr, dc) ->
let bs = maybe [] collisionObstacle (fromMaybe Nothing $ M.safeGet let bs = fromMaybe [] $ collisionObstacle <$> M.unsafeGet
(fromIntegral $ floor pr + dr) (fromIntegral $ floor pr + dr)
(fromIntegral $ floor pc + dc) (fromIntegral $ floor pc + dc)
(mmImgMat (stateData ud))) (mmImgMat (stateData ud))
in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))-> in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
Boundaries Boundaries
(minr + fromIntegral dr, minc + fromIntegral dc) (minr + fromIntegral dr, minc + fromIntegral dc)

44
src/MainGame/WorldMap.hs
View file

@ -24,6 +24,7 @@ import Data.Matrix as M
import Data.Ecstasy as E import Data.Ecstasy as E
import Data.Maybe import Data.Maybe
import Data.List as L import Data.List as L
import qualified Data.Vector as V
import System.Random (randomRIO) import System.Random (randomRIO)
@ -136,7 +137,7 @@ loadMapFork ud ad future progress = do
( p + increment ( p + increment
, "Placing furniture" , "Placing furniture"
))) )))
(!inter, !rawrps) <- placeInteriorIO mat imgmat exits gr (!inter, !rawrps) <- placeInteriorIO mat imgmat exits (V.toList gr)
let !rps = ReachPoint Elevator (fcElevator fc) SE 0 : rawrps let !rps = ReachPoint Elevator (fcElevator fc) SE 0 : rawrps
modifyMVar_ progress (return . (\(p, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
@ -243,10 +244,11 @@ loadMapFork ud ad future progress = do
<*> (randomRIO (0, 1)) <*> (randomRIO (0, 1))
<*> (randomRIO (0, 1)) <*> (randomRIO (0, 1))
<*> (randomRIO (0, 1)) <*> (randomRIO (0, 1))
let room = head let room = V.head
(Prelude.filter (V.filter
((inBounds $ pointCoord cpr) . bounds) ((inBounds $ pointCoord cpr) . bounds)
(Types.connects (head gr) ++ tail gr) (V.fromList $
V.toList (Types.connects (V.head gr)) ++ (V.toList (V.tail gr)))
) )
void $ createEntity $ newEntity void $ createEntity $ newEntity
{ pos = Just (fmap ((+ 0.5) . fromIntegral) (pointCoord cpr)) { pos = Just (fmap ((+ 0.5) . fromIntegral) (pointCoord cpr))
@ -266,17 +268,18 @@ loadMapFork ud ad future progress = do
, "Registering doors into WorldState" , "Registering doors into WorldState"
))) )))
mapM_ (\door -> do mapM_ (\door -> do
let rooms = Prelude.foldl let rooms = V.foldl
(\acc coord -> (\acc coord ->
let rs = Prelude.filter ((inBounds coord) . bounds) graph let rs = V.filter ((inBounds coord) . bounds) graph
in in
if not (Prelude.null rs) if not (V.null rs)
then (coord, head rs) : acc then (coord, V.head rs) `V.cons` acc
else acc else acc
) )
[] V.empty
coords (V.fromList coords)
graph = Types.connects (head gr) ++ tail gr graph = V.fromList $
(V.toList $ Types.connects (V.head gr)) ++ (V.toList $ V.tail gr)
coords = Prelude.map (door +) deltas coords = Prelude.map (door +) deltas
deltas = deltas =
[ V2 0 1 [ V2 0 1
@ -296,7 +299,8 @@ loadMapFork ud ad future progress = do
| otherwise = error ("strange wall: " ++ show wall) | otherwise = error ("strange wall: " ++ show wall)
void $ createEntity $ newEntity void $ createEntity $ newEntity
{ pos = Just (fmap ((+ 0.5) . fromIntegral) door) { pos = Just (fmap ((+ 0.5) . fromIntegral) door)
, clearanceLvl = Just (maximum $ 0 : Prelude.map clearance (Prelude.map snd rooms)) , clearanceLvl = Just (V.maximum $
0 `V.cons` V.map clearance (V.map snd rooms))
, anim = Just $ AnimState (AnimId AnimDoor0 "shut" orientation) 0 1 , anim = Just $ AnimState (AnimId AnimDoor0 "shut" orientation) 0 1
, obstacle = Just $ case orientation of , obstacle = Just $ case orientation of
NW -> Boundaries (4/9, 0) (5/9, 1) NW -> Boundaries (4/9, 0) (5/9, 1)
@ -333,7 +337,7 @@ loadMapFork ud ad future progress = do
putMVar future (nws, MainData putMVar future (nws, MainData
{ mapMat = mat { mapMat = mat
, imgMat = retMat , imgMat = retMat
, reachPoints = rps , reachPoints = V.fromList rps
, mmImgMat = mmimgmat , mmImgMat = mmimgmat
, roomGraph = gr , roomGraph = gr
}) })
@ -513,8 +517,8 @@ drawMap = do
dat dat
V2 pr pc = playerPos V2 pr pc = playerPos
MainData _ _ _ _ gr = stateData ud MainData _ _ _ _ gr = stateData ud
seekGraph = Types.connects (head gr) ++ tail gr seekGraph = V.foldl V.snoc (Types.connects (V.head gr)) (V.tail gr)
room = Prelude.filter (inBounds (fmap floor playerPos) . bounds) seekGraph room = V.filter (inBounds (fmap floor playerPos) . bounds) seekGraph
mat = imgMat (stateData ud) mat = imgMat (stateData ud)
cols = fromIntegral (ncols mat) cols = fromIntegral (ncols mat)
rows = fromIntegral (nrows mat) rows = fromIntegral (nrows mat)
@ -619,7 +623,9 @@ drawMap = do
"FPS: " "FPS: "
<> T.pack (Prelude.take 5 $ show (1/dt)) <> T.pack (Prelude.take 5 $ show (1/dt))
<> " Clearance: " <> " Clearance: "
<> if not (Prelude.null room) then T.pack (show $ clearance $ head room) else "0" <> if not (Prelude.null room)
then T.pack (show $ clearance $ V.head room)
else "0"
) )
drawTile drawTile
@ -761,10 +767,10 @@ updateMap dt = do
concatMap concatMap
(\(dr, dc) -> (\(dr, dc) ->
let bs = (++) let bs = (++)
(maybe [] collisionObstacle (fromMaybe Nothing $ M.safeGet (fromMaybe [] $ collisionObstacle <$> M.unsafeGet
(fromIntegral $ floor pr + dr) (fromIntegral $ floor pr + dr)
(fromIntegral $ floor pc + dc) (fromIntegral $ floor pc + dc)
(imgMat (stateData ud)))) (imgMat (stateData ud)))
(Prelude.map snd $ Prelude.filter (Prelude.map snd $ Prelude.filter
(\((V2 br bc), _) -> (\((V2 br bc), _) ->
floor pr + dr == floor br && floor pr + dr == floor br &&
@ -877,7 +883,7 @@ updateMap dt = do
(imgMat $ stateData ud) (imgMat $ stateData ud)
(mapMat $ stateData ud) (mapMat $ stateData ud)
nws nws
(Prelude.filter (V.filter
(\p -> pointType p /= RoomExit) (\p -> pointType p /= RoomExit)
(reachPoints $ stateData ud) (reachPoints $ stateData ud)
) )

42
src/NPC.hs
View file

@ -1,5 +1,6 @@
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module NPC where module NPC where
import Affection as A import Affection as A
@ -9,6 +10,7 @@ import Data.Ecstasy as E
import Data.Maybe import Data.Maybe
import Data.List (find) import Data.List (find)
import Data.List.Split (splitWhen) import Data.List.Split (splitWhen)
import qualified Data.Vector as V
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans (lift) import Control.Monad.Trans (lift)
@ -45,7 +47,7 @@ updateNPCs
:: M.Matrix (Maybe ImgId) :: M.Matrix (Maybe ImgId)
-> M.Matrix TileState -> M.Matrix TileState
-> SystemState Entity (AffectionState (AffectionData UserData) IO) -> SystemState Entity (AffectionState (AffectionData UserData) IO)
-> [ReachPoint] -> V.Vector ReachPoint
-> Double -> Double
-> SystemT Entity (AffectionState (AffectionData UserData) IO) () -> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
updateNPCs imgmat tsmat ws rrp dt = do updateNPCs imgmat tsmat ws rrp dt = do
@ -66,7 +68,7 @@ updateNPCs imgmat tsmat ws rrp dt = do
lvl <- query clearanceLvl lvl <- query clearanceLvl
stat <- query anim stat <- query anim
npcState' <- query npcMoveState npcState' <- query npcMoveState
let rp = filter ((lvl >=) . pointClearance) rrp let rp = V.filter ((lvl >=) . pointClearance) rrp
case npcState' of case npcState' of
NPCStanding ttl future -> do NPCStanding ttl future -> do
let nttl = ttl - dt let nttl = ttl - dt
@ -119,7 +121,7 @@ updateNPCs imgmat tsmat ws rrp dt = do
npcent <- queryEnt npcent <- queryEnt
let (oent, _, _) = objects !! rind let (oent, _, _) = objects !! rind
mdir = mdir =
pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp pointDir <$> V.find (\a -> pointCoord a == fmap floor pos') rp
return (Just (oent, npcent, Nothing), unchanged return (Just (oent, npcent, Nothing), unchanged
{ rot = Set $ fromMaybe rot' mdir { rot = Set $ fromMaybe rot' mdir
, anim = Set stat , anim = Set stat
@ -194,7 +196,7 @@ standStill
-> Direction -> Direction
-> SystemState Entity m -> SystemState Entity m
-> [(V2 Double, Boundaries Double)] -> [(V2 Double, Boundaries Double)]
-> [ReachPoint] -> V.Vector ReachPoint
-> QueryT Entity m (Maybe (Ent, Ent, Maybe (MVar [[V2 Int]])), Entity 'SetterOf) -> QueryT Entity m (Maybe (Ent, Ent, Maybe (MVar [[V2 Int]])), Entity 'SetterOf)
standStill imgmat tsmat pos' rot' ws posbounds rp = do standStill imgmat tsmat pos' rot' ws posbounds rp = do
future <- liftIO $ newEmptyMVar future <- liftIO $ newEmptyMVar
@ -202,27 +204,27 @@ standStill imgmat tsmat pos' rot' ws posbounds rp = do
as <- query npcActionState as <- query npcActionState
targetRPs <- case as of targetRPs <- case as of
ASWork -> ASWork ->
let fltrd = filter (\p -> pointType p == Copier) rp let fltrd = V.filter (\p -> pointType p == Copier) rp
in in
((fltrd ++) . replicate (5 * length fltrd)) <$> (V.foldl V.snoc fltrd . V.replicate (5 * V.length fltrd)) <$>
query npcWorkplace query npcWorkplace
ASToilet -> do ASToilet -> do
let seekRP = filter (\p -> pointType p == Toilet) rp let seekRP = V.filter (\p -> pointType p == Toilet) rp
if null seekRP if V.null seekRP
then return $ filter (\p -> pointType p == Elevator) rp then return $ V.filter (\p -> pointType p == Elevator) rp
else return seekRP else return seekRP
ASDrink -> do ASDrink -> do
let seekRP = filter (\p -> pointType p == Drink) rp let seekRP = V.filter (\p -> pointType p == Drink) rp
if null seekRP if V.null seekRP
then return $ filter (\p -> pointType p == Elevator) rp then return $ V.filter (\p -> pointType p == Elevator) rp
else return seekRP else return seekRP
ASEat -> do ASEat -> do
let seekRP = filter (\p -> pointType p == Eat) rp let seekRP = V.filter (\p -> pointType p == Eat) rp
if null seekRP if V.null seekRP
then return $ filter (\p -> pointType p == Elevator) rp then return $ V.filter (\p -> pointType p == Elevator) rp
else return seekRP else return seekRP
ASRandWalk -> ASRandWalk ->
return $ filter (\p -> pointType p /= RoomExit) rp return $ V.filter (\p -> pointType p /= RoomExit) rp
_ <- liftIO $ forkIO $ _ <- liftIO $ forkIO $
getPath (fmap floor pos') future targetRPs imgmat tsmat posbounds getPath (fmap floor pos') future targetRPs imgmat tsmat posbounds
let mdir = let mdir =
@ -318,15 +320,15 @@ getObject npos = do
getPath getPath
:: V2 Int :: V2 Int
-> MVar [[V2 Int]] -> MVar [[V2 Int]]
-> [ReachPoint] -> V.Vector ReachPoint
-> M.Matrix (Maybe ImgId) -> M.Matrix (Maybe ImgId)
-> M.Matrix TileState -> M.Matrix TileState
-> [(V2 Double, Boundaries Double)] -> [(V2 Double, Boundaries Double)]
-> IO () -> IO ()
getPath pos' mvar rp imgmat tsmat posbounds = do getPath pos' mvar rp imgmat tsmat posbounds = do
let seekRP = filter (\p -> pointType p /= RoomExit) rp let seekRP = V.filter (\p -> pointType p /= RoomExit) rp
ntargeti <- randomRIO (0, length seekRP - 1) ntargeti <- randomRIO (0, V.length seekRP - 1)
let ntarget = pointCoord (seekRP !! ntargeti) let ntarget = pointCoord (seekRP V.! ntargeti)
path = astarAppl imgmat posbounds ntarget pos' path = astarAppl imgmat posbounds ntarget pos'
logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show ntarget) logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show ntarget)
case path of case path of

6
src/Types/Map.hs
View file

@ -3,6 +3,8 @@ module Types.Map where
import Linear (V2) import Linear (V2)
import qualified Data.Vector as V
data TileState data TileState
= Wall = Wall
-- | Wind -- | Wind
@ -50,10 +52,10 @@ data GraphDirection = North | South | East | West
data Graph data Graph
= GHall = GHall
{ connects :: [Graph] { connects :: V.Vector Graph
} }
| GRoom | GRoom
{ neighbs :: [(GraphDirection, TileState)] { neighbs :: V.Vector (GraphDirection, TileState)
, bounds :: Boundaries Int , bounds :: Boundaries Int
, clearance :: Word , clearance :: Word
, roomType :: TileState , roomType :: TileState

5
src/Types/StateData.hs
View file

@ -2,6 +2,7 @@ module Types.StateData where
import Data.Matrix import Data.Matrix
import Data.Map import Data.Map
import Data.Vector as V
import NanoVG hiding (V2) import NanoVG hiding (V2)
@ -23,9 +24,9 @@ data StateData
| MainData | MainData
{ mapMat :: Matrix TileState { mapMat :: Matrix TileState
, imgMat :: Matrix (Maybe ImgId) , imgMat :: Matrix (Maybe ImgId)
, reachPoints :: [ReachPoint] , reachPoints :: V.Vector ReachPoint
, mmImgMat :: Matrix (Maybe ImgId) , mmImgMat :: Matrix (Maybe ImgId)
, roomGraph :: [Graph] , roomGraph :: V.Vector Graph
} }
| MenuData | MenuData
{ velocity :: V2 Double { velocity :: V2 Double

4
src/Util.hs
View file

@ -195,14 +195,14 @@ naviGraph imgmat animBounds (V2 r c) =
(\acc (rr, cc) -> (\acc (rr, cc) ->
if null if null
(maybe [] collisionObstacle (maybe [] collisionObstacle
(join $ M.safeGet (r + rr) (c + cc) imgmat) (M.unsafeGet (r + rr) (c + cc) imgmat)
++ ++
map snd (filter (\(V2 br bc, _) -> floor br == r + rr && floor bc == c + cc) map snd (filter (\(V2 br bc, _) -> floor br == r + rr && floor bc == c + cc)
animBounds)) animBounds))
&& all null && all null
(map (map
(\(oor, ooc) -> (maybe [] collisionObstacle (\(oor, ooc) -> (maybe [] collisionObstacle
(join $ M.safeGet (r + oor) (c + ooc) imgmat)) ++ (M.unsafeGet (r + oor) (c + ooc) imgmat)) ++
map snd (filter map snd (filter
(\(V2 br bc, _) -> floor br == r + oor && floor bc == c + ooc) (\(V2 br bc, _) -> floor br == r + oor && floor bc == c + ooc)
animBounds)) animBounds))