diff --git a/cabal.config b/cabal.config index 7b652c6..a48c35b 100644 --- a/cabal.config +++ b/cabal.config @@ -1,2 +1,2 @@ -constraints: affection +debug +constraints: affection +verbose profiling: True diff --git a/src/Floorplan.hs b/src/Floorplan.hs index 2e76392..a6af206 100644 --- a/src/Floorplan.hs +++ b/src/Floorplan.hs @@ -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 diff --git a/src/MainGame/MindMap.hs b/src/MainGame/MindMap.hs index 4b0202a..f88b5cf 100644 --- a/src/MainGame/MindMap.hs +++ b/src/MainGame/MindMap.hs @@ -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) diff --git a/src/MainGame/WorldMap.hs b/src/MainGame/WorldMap.hs index 1afa2b5..abd6d5f 100644 --- a/src/MainGame/WorldMap.hs +++ b/src/MainGame/WorldMap.hs @@ -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) ) diff --git a/src/NPC.hs b/src/NPC.hs index 54bd45f..0796b83 100644 --- a/src/NPC.hs +++ b/src/NPC.hs @@ -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 diff --git a/src/Types/Map.hs b/src/Types/Map.hs index efe0c12..4b1699b 100644 --- a/src/Types/Map.hs +++ b/src/Types/Map.hs @@ -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 diff --git a/src/Types/StateData.hs b/src/Types/StateData.hs index 9a1158f..3a55034 100644 --- a/src/Types/StateData.hs +++ b/src/Types/StateData.hs @@ -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 diff --git a/src/Util.hs b/src/Util.hs index baf177b..286b8f7 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -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))