various speed optimizations

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

View File

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

View File

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

View File

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

View File

@ -24,6 +24,7 @@ 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 System.Random (randomRIO)
@ -136,7 +137,7 @@ loadMapFork ud ad future progress = do
( p + increment
, "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
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
@ -243,10 +244,11 @@ loadMapFork ud ad future progress = do
<*> (randomRIO (0, 1))
<*> (randomRIO (0, 1))
<*> (randomRIO (0, 1))
let room = head
(Prelude.filter
let room = V.head
(V.filter
((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
{ pos = Just (fmap ((+ 0.5) . fromIntegral) (pointCoord cpr))
@ -266,17 +268,18 @@ loadMapFork ud ad future progress = do
, "Registering doors into WorldState"
)))
mapM_ (\door -> do
let rooms = Prelude.foldl
let rooms = V.foldl
(\acc coord ->
let rs = Prelude.filter ((inBounds coord) . bounds) graph
let rs = V.filter ((inBounds coord) . bounds) graph
in
if not (Prelude.null rs)
then (coord, head rs) : acc
if not (V.null rs)
then (coord, V.head rs) `V.cons` acc
else acc
)
[]
coords
graph = Types.connects (head gr) ++ tail gr
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
@ -296,7 +299,8 @@ loadMapFork ud ad future progress = do
| 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))
, 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)
@ -333,7 +337,7 @@ loadMapFork ud ad future progress = do
putMVar future (nws, MainData
{ mapMat = mat
, imgMat = retMat
, reachPoints = rps
, reachPoints = V.fromList rps
, mmImgMat = mmimgmat
, roomGraph = gr
})
@ -513,8 +517,8 @@ drawMap = do
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
seekGraph = V.foldl V.snoc (Types.connects (V.head gr)) (V.tail gr)
room = V.filter (inBounds (fmap floor playerPos) . bounds) seekGraph
mat = imgMat (stateData ud)
cols = fromIntegral (ncols mat)
rows = fromIntegral (nrows mat)
@ -619,7 +623,9 @@ drawMap = do
"FPS: "
<> T.pack (Prelude.take 5 $ show (1/dt))
<> " 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
@ -761,10 +767,10 @@ updateMap dt = do
concatMap
(\(dr, dc) ->
let bs = (++)
(maybe [] collisionObstacle (fromMaybe Nothing $ M.safeGet
(fromMaybe [] $ collisionObstacle <$> M.unsafeGet
(fromIntegral $ floor pr + dr)
(fromIntegral $ floor pc + dc)
(imgMat (stateData ud))))
(imgMat (stateData ud)))
(Prelude.map snd $ Prelude.filter
(\((V2 br bc), _) ->
floor pr + dr == floor br &&
@ -877,7 +883,7 @@ updateMap dt = do
(imgMat $ stateData ud)
(mapMat $ stateData ud)
nws
(Prelude.filter
(V.filter
(\p -> pointType p /= RoomExit)
(reachPoints $ stateData ud)
)

View File

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

View File

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

View File

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

View File

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