justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Commit before potential Door refactor

Browse Source
This commit is contained in:
justin
2025-10-21 19:56:48 +01:00
parent fcffbd5f43
commit 2f3a00a971
8 changed files with 118 additions and 258 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/CreatureEffect.hs
+1 -1
View File
@@ -46,7 +46,7 @@ doCrAc ca = case ca of
doCrWdAc :: CrWdAc -> Creature -> World -> Action
doCrWdAc cw = case cw of
CrWdBFSThenReturn _ -> undefined
CrWdBFSThenReturn _ -> const $ const NoAction
-- CrWdBFSThenReturn t -> \cr w -> fromMaybe NoAction $ do
-- n <- walkableNodeNear w (cr ^. crPos . _xy)
-- let as = take 20 $ map PathTo $ bfsNodePoints n w
src/Dodge/Data/Block.hs
-1
View File
@@ -28,7 +28,6 @@ data Block = Block
, _blHeight :: Float
, _blMaterial :: Material
, _blDraw :: BlockDraw --Block -> SPic
-- , _blObstructs :: Set PathEdgeNodes
, _blObstructs :: [(Int,Int)]
}
deriving (Eq, Ord, Show, Read) --Generic, Flat)
src/Dodge/Data/CWorld.hs
-1
View File
@@ -25,7 +25,6 @@ data CWorld = CWorld
, _cwGen :: CWGen
, _cClock :: Int
, _cwTiles :: [Tile]
-- , _pathGraph :: Gr Point2 PathEdge
, _incGraph :: V.Vector [(Int,SimpleEdge)]
, _incNode :: UV.Vector Point2
, _incEdges :: [(Int,Int)]
src/Dodge/Layout.hs
-4
View File
@@ -45,17 +45,13 @@ generateLevelFromRoomList gr' w =
. worldToGenWorld rs'
$ w & cWorld . lWorld . walls .~ wallsFromRooms rs
& cWorld . cwGen . cwgGameRooms .~ gameRoomsFromRooms (IM.elems rs')
-- & cWorld . pathGraph .~ path
& cWorld . incNode .~ inodes
& cWorld . incGraph .~ igraph
& cWorld . incEdges .~ ipairs
-- & pnZoning .~ foldl' (flip zonePn) mempty (labNodes path)
-- & peZoning .~ foldl' (flip zonePe) mempty (map fromEdgeTuple $ labEdges path)
& incNodeZoning .~ UV.ifoldl' (\m i p -> zonePn (i,p) m) mempty inodes
& incEdgeZoning .~ foldl' (flip (zoneIncPe inodes)) mempty ipairs
where
pairs = snapToGrid $ foldMap _rmPath rs
-- (_, path) = pairsToGraph pairs
(inodes,igraph,ipairs) = pairsToIncGraph pairs
rs = map doRoomShift $ IM.elems rs'
rs' = mapM shuffleRoomPos gr' & evalState $ _randGen w
src/Dodge/Path.hs
+12 -113
View File
@@ -61,9 +61,8 @@ makePathUsing :: (Set.Set EdgeObstacle -> Bool) -> Point2 -> Point2 -> World ->
makePathUsing t s e w = do
na <- walkableNodeNear w s
nb <- walkableNodeNear w e
let f i = getes i
h i = distance (getn nb) (getn i)
(na :) . snd <$> AS.aStarAssoc f h (== nb) na
let h i = distance (getn nb) (getn i)
(na :) . snd <$> AS.aStarAssoc getes h (== nb) na
where
g (i, SimpleEdge c o)
| t o = Just (i, c)
@@ -71,22 +70,11 @@ makePathUsing t s e w = do
getes i = mapMaybe g $ w ^?! cWorld . incGraph . ix i
getn i = w ^?! cWorld . incNode . ix i
-- sp na nb . second _peDist . efilter (^. _3 . to t) $ w ^. cWorld . pathGraph
makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
makePathBetween = makePathUsing $ not . pathEdgeObstructed
--pathEdgeObstructed' :: PathEdge -> Bool
--pathEdgeObstructed' pe =
-- any
-- (`Set.member` _peObstacles pe)
-- [DoorObstacle, BlockObstacle, ChasmObstacle]
pathEdgeObstructed :: Set.Set EdgeObstacle -> Bool
pathEdgeObstructed pe =
any
(`Set.member` pe)
[DoorObstacle, BlockObstacle, ChasmObstacle]
pathEdgeObstructed pe = any (`Set.member` pe) [DoorObstacle, BlockObstacle, ChasmObstacle]
walkableNodeNear :: World -> Point2 -> Maybe Int
{-# INLINE walkableNodeNear #-}
@@ -94,12 +82,6 @@ walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
where
nodesNear = zonesExtract (w ^. incNodeZoning) . snailAround $ zoneOfPoint pnZoneSize p
--walkableNodeNear' :: World -> Point2 -> Maybe Int
--{-# INLINE walkableNodeNear' #-}
--walkableNodeNear' w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
-- where
-- nodesNear = zonesExtract (w ^. pnZoning) . snailAround $ zoneOfPoint pnZoneSize p
snailAround :: Int2 -> [Int2]
snailAround x = (x +) <$> smallSnailInt2
@@ -110,64 +92,11 @@ smallSnailInt2 =
[V2 x y | x <- [-2 .. 2], y <- [-2 .. 2]]
makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
--makePathBetweenPs a b w = mapMaybe (lab $ w ^. cWorld . pathGraph) <$> makePathBetween a b w
makePathBetweenPs a b w = mapMaybe (flip getNodePos w) <$> makePathBetween a b w
--bfsNodePoints :: Int -> World -> [Point2]
--bfsNodePoints n w = mapMaybe (lab g) $ bfs n g
-- where
-- g = w ^. cWorld . pathGraph
makePathBetweenPs a b w = traverse (flip getNodePos w) =<< makePathBetween a b w
-- assumes that pathfinding is symmetric
pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2
pointTowardsImpulse a b w =
-- (find (flip (isWalkable a) w) . reverse)
-- =<< (makePathBetweenPs a b w <&> (<> [b]))
(find (flip (isWalkable a) w) . reverse)
=<< makePathBetweenPs a b w -- <&> (<> [b]))
------ continues a walk from a list of points, without repetitions
------ supposes that the list is non-empty
--randomGraphWalk :: RandomGen g => [Int] -> Gr a b -> State g [Int]
--randomGraphWalk (n:ns) g = do
-- next' <- randomGraphStepRestricted n ns g
-- case next' of
-- Nothing -> return (n:ns)
-- Just n' -> randomGraphWalk (n':n:ns) g
--randomGraphWalk _ _ = error "Trying to walk in an empty list"
--
--randomPointXStepsFrom :: Int -> Point2 -> World -> Point2
--randomPointXStepsFrom i p w =
-- let g = _pathGraph w
-- ns = labNodes g
-- mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns
-- in case mp of
-- Nothing -> p
-- Just (n,_) -> fromJust
-- $ lab g (last $ take i $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w)
--
--randomPointsXStepsFrom :: Int -> Point2 -> World -> [Point2]
--randomPointsXStepsFrom i p w =
-- let g = _pathGraph w
-- ns = labNodes g
-- mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns
-- in case mp of
-- Nothing -> [p]
-- Just (n,_) -> mapMaybe (lab g) (take i $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w)
--
--randomGraphStep :: RandomGen g => Int -> Gr a b -> State g (Maybe Int)
--randomGraphStep n g =
-- do let ns = neighbors g n
-- i <- state $ randomR (0,length ns - 1)
-- case ns of [] -> return Nothing
-- _ -> return $ Just $ ns !! i
--randomGraphStepRestricted :: RandomGen g => Int -> [Int] -> Gr a b -> State g (Maybe Int)
--randomGraphStepRestricted n notns g = do
-- let ns = neighbors g n \\ notns
-- i <- state $ randomR (0,length ns - 1)
-- case ns of
-- [] -> return Nothing
-- _ -> return $ Just $ ns !! i
--
pointTowardsImpulse a b w = (find $ flip (isWalkable a) w) =<< makePathBetweenPs b a w
pairsToIncGraph ::
Set.Set (Point2, Point2) ->
@@ -178,49 +107,19 @@ pairsToIncGraph ::
pairsToIncGraph pairs =
( inodes
, incgraph
, Set.toList pairs & each . each %~ (\i -> pstons ^?! ix i . _head)
, Set.toList pairs & each . each %~ (\i -> pToNode ^?! ix i)
)
where
incgraph = V.generate (length im) (\i -> im ^?! ix i)
im = IM.fromListWith (<>) . fmap toedge $ Set.toList pairs
incgraph = V.generate (length im) (im IM.!)
im = IM.fromListWith (++) . fmap toedge $ Set.toList pairs
toedge (x, y) =
( pstons ^?! ix x . _head
, [(pstons ^?! ix y . _head, SimpleEdge (distance x y) mempty)]
( pToNode ^?! ix x
, [(pToNode ^?! ix y, SimpleEdge (distance x y) mempty)]
)
pstons = IM.invertIntMap . IM.fromList $ zip [0 ..] ps
pToNode = IM.invertIntMapUnique . IM.fromDistinctAscList $ zip [0 ..] ps
inodes = UV.generate (length ps) (ps !!)
ps = Set.toList $ Set.map fst pairs <> Set.map snd pairs
--pairsToGraph ::
-- Set.Set (Point2, Point2) ->
-- (Map (V2 Point2) PathEdgeNodes, Gr Point2 PathEdge)
--pairsToGraph pairs = addEdges nodemap gr pairs
-- where
-- (nodemap, _, gr) = addNodes $ Set.toList $ Set.map fst pairs <> Set.map snd pairs
--addNodes :: [Point2] -> (Map Point2 Int, Int, Gr Point2 PathEdge)
--addNodes = foldl' f (mempty, 0, Data.Graph.Inductive.empty)
-- where
-- f (nodemap, i, gr) p = case nodemap M.!? p of
-- Just _ -> (nodemap, i, gr)
-- Nothing -> (nodemap & at p ?~ i, i + 1, insNode (i, p) gr)
--addEdges ::
-- Map Point2 Int ->
-- Gr Point2 PathEdge ->
-- Set.Set (Point2, Point2) ->
-- (Map (V2 Point2) PathEdgeNodes, Gr Point2 PathEdge)
--addEdges nodemap gr = foldl' f (mempty, gr)
-- where
-- f (edgemap, gr') (a, b) =
-- ( M.insert (V2 a b) theedgedata edgemap
-- , insEdge theedgetup gr'
-- )
-- where
-- theedgetup = (g a, g b, PathEdge a b (dist a b) mempty)
-- theedgedata = PathEdgeNodes (g a) (g b) (PathEdge a b (dist a b) mempty)
-- g a = nodemap M.! a
obstructPathsCrossing ::
EdgeObstacle ->
Point2 ->
src/Dodge/Save.hs
+28 -35
View File
@@ -3,44 +3,42 @@ module Dodge.Save (
loadSaveSlot,
doQuicksave,
doQuickload,
-- saveLevelStartSlot,
-- saveLevelStartSlot,
writeSaveSlot,
readSaveSlot,
reloadLevelStart,
) where
import Dodge.Zoning.Pathing
import qualified Data.Vector.Unboxed as UV
import Control.Monad
import Data.Maybe
import Dodge.WorldLoad
--import Dodge.Path.Translate
--import Data.Graph.Inductive (labEdges, labNodes)
--import Dodge.Zoning.Pathing
import Data.Foldable
import Dodge.Wall.Zone
import Dodge.Concurrent
import Control.Lens
import Dodge.Data.SaveSlot
import Control.Monad
import Data.Aeson
--import qualified Data.Aeson.Encode.Pretty as AEP
import qualified Data.ByteString.Lazy as BS
import Data.Foldable
import Data.Maybe
import qualified Data.Vector.Unboxed as UV
import Dodge.Concurrent
import Dodge.Data.SaveSlot
--import qualified Data.ByteString as BSS
import Dodge.Data.Universe
import Dodge.Wall.Zone
import Dodge.WorldLoad
import Dodge.Zoning.Pathing
--import qualified Data.Set as S
import System.Directory
--import Data.Sequence ((|>))
--import Data.Sequence ((|>))
writeSaveSlot :: SaveSlot -> Universe -> IO (Universe -> Maybe Universe)
writeSaveSlot ss u = do
putStrLn $ "Saving " ++ saveSlotPath ss
createDirectoryIfMissing True "generated/saves"
BS.writeFile (saveSlotPath ss) $
--AEP.encodePretty'
-- (AEP.Config (AEP.Spaces 2) compare AEP.Generic False)
encode
(u ^. uvWorld . cWorld)
BS.writeFile (saveSlotPath ss) $ encode (u ^. uvWorld . cWorld)
--AEP.encodePretty' (AEP.Config (AEP.Spaces 2) compare AEP.Generic False)
return Just
readSaveSlot :: SaveSlot -> IO (Universe -> Maybe Universe)
@@ -49,23 +47,17 @@ readSaveSlot ss = do
unless fExists $ error "Tried to read non-existant save file"
mcw <- decodeFileStrict $ saveSlotPath ss
flip (maybe (error "Tried to read incorrectly encoded save file")) mcw $ \cw -> do
let inodes = cw ^. incNode
return $ \uv -> Just
$ uv & uvWorld . cWorld .~ cw
let inodes = cw ^. incNode
return $ \uv ->
Just $
uv & uvWorld . cWorld .~ cw
& uvWorld %~ initWallZoning
& uvWorld . incNodeZoning
.~ UV.ifoldl' (\m i p -> zonePn (i,p) m) mempty inodes
& uvWorld . incEdgeZoning
.~ foldl' (flip (zoneIncPe inodes)) mempty
(cw ^. incEdges)
-- & uvWorld . pnZoning .~ foldl' (flip zonePn) mempty
-- (labNodes $ path uv)
-- & uvWorld . peZoning .~ foldl' (flip zonePe) mempty
-- (map fromEdgeTuple $ labEdges $ path uv)
& uvWorld . incNodeZoning
.~ UV.ifoldl' (\m i p -> zonePn (i, p) m) mempty inodes
& uvWorld . incEdgeZoning
.~ foldl' (flip (zoneIncPe inodes)) mempty (cw ^. incEdges)
& uvScreenLayers .~ []
& postUniverseLoadSideEffect
-- where
-- path uv = uv ^. uvWorld . cWorld . pathGraph
saveSlotPath :: SaveSlot -> String
saveSlotPath (SaveSlotNum i) = "generated/saves/" ++ show i
@@ -74,17 +66,18 @@ saveSlotPath (LevelStartSlot i) = "generated/saves/LevelStart" ++ show i
saveWorldInSlot :: SaveSlot -> Universe -> Universe
saveWorldInSlot slot u = u & addSideEffect (writeSaveSlot slot u) "SAVING"
reloadLevelStart :: Universe -> Universe
reloadLevelStart = loadSaveSlot (LevelStartSlot 0)
loadSaveSlot :: SaveSlot -> Universe -> Universe
loadSaveSlot slot = blockingLoad ("DESERIALISING "++ show slot) $ readSaveSlot slot
loadSaveSlot slot = blockingLoad ("DESERIALISING " ++ show slot) $ readSaveSlot slot
doQuicksave :: Universe -> Universe
doQuicksave u = u
& uvRAMSave ?~ _uvWorld u
& saveWorldInSlot QuicksaveSlot
doQuicksave u =
u
& uvRAMSave ?~ _uvWorld u
& saveWorldInSlot QuicksaveSlot
doQuickload :: Universe -> Universe
doQuickload u = fromMaybe (loadSaveSlot QuicksaveSlot u) $ do
src/IntMapHelp.hs
+5 -4
View File
@@ -18,6 +18,7 @@ module IntMapHelp
cycleGT,
cycleLT,
invertIntMap,
invertIntMapUnique,
) where
import Control.Applicative
@@ -97,7 +98,7 @@ cycleLT :: Int -> IntMap a -> Maybe (Int, a)
cycleLT i m = lookupLT i m <|> lookupMax m
invertIntMap :: Ord a => IntMap a -> M.Map a [Int]
invertIntMap =
foldrWithKey
(\k xs -> M.insertWith (++) xs [k])
mempty
invertIntMap = foldrWithKey (\k x -> M.insertWith (++) x [k]) mempty
invertIntMapUnique :: Ord a => IntMap a -> M.Map a Int
invertIntMapUnique = foldlWithKey' (\m k x -> M.insert x k m) mempty