From 9b8d3185fe6cee9231ed20a1dbf0240d0c459a39 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Fri, 3 Jul 2020 20:32:36 -0400 Subject: refactor(xan): Switch to V2 over tuples most places These are generally rather nicer to work due to some typeclass instances, and integrate better with other ecosystems for things like linear algebra etc. Change-Id: I546c8da7b17234648f3d612b28741c1fded25447 Reviewed-on: https://cl.tvl.fyi/c/depot/+/910 Tested-by: BuildkiteCI Reviewed-by: glittershark --- .../src/Xanthous/Generators/CaveAutomata.hs | 3 +- .../xanthous/src/Xanthous/Generators/Dungeon.hs | 9 +- .../src/Xanthous/Generators/LevelContents.hs | 21 +++-- .../xanthous/src/Xanthous/Generators/Util.hs | 96 +++++++++++----------- .../xanthous/src/Xanthous/Generators/Village.hs | 4 +- 5 files changed, 69 insertions(+), 64 deletions(-) (limited to 'users/glittershark/xanthous/src/Xanthous/Generators') diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs index ada201ef3d6c..be904662f3f7 100644 --- a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs +++ b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs @@ -19,6 +19,7 @@ import Xanthous.Util (between) import Xanthous.Util.Optparse import Xanthous.Data (Dimensions, width, height) import Xanthous.Generators.Util +import Linear.V2 -------------------------------------------------------------------------------- data Params = Params @@ -102,7 +103,7 @@ generate' params dims = do stepAutomata :: forall s g. MCells s -> Dimensions -> Params -> CellM g s () stepAutomata cells dims params = do origCells <- lift $ cloneMArray @_ @(STUArray s) cells - for_ (range ((0, 0), (dims ^. width, dims ^. height))) $ \pos -> do + for_ (range (0, V2 (dims ^. width) (dims ^. height))) $ \pos -> do neighs <- lift $ numAliveNeighborsM origCells pos origValue <- lift $ readArray origCells pos lift . writeArray cells pos diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs index 7fde0075e64f..f30713ce1182 100644 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs +++ b/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs @@ -159,14 +159,14 @@ fillRoom cells room = V2 dimx dimy = room ^. dimensions in for_ [posx .. posx + dimx] $ \x -> for_ [posy .. posy + dimy] $ \y -> - lift $ writeArray cells (x, y) True + lift $ writeArray cells (V2 x y) True -corridorBetween :: MonadRandom m => Room -> Room -> m [(Word, Word)] +corridorBetween :: MonadRandom m => Room -> Room -> m [V2 Word] corridorBetween originRoom destinationRoom = straightLine <$> origin <*> destination where - origin = choose . NE.fromList . map toTuple =<< originEdge - destination = choose . NE.fromList . map toTuple =<< destinationEdge + origin = choose . NE.fromList =<< originEdge + destination = choose . NE.fromList =<< destinationEdge originEdge = pickEdge originRoom originCorner destinationEdge = pickEdge destinationRoom destinationCorner pickEdge room corner = choose . over both (boxEdge room) $ cornerEdges corner @@ -188,4 +188,3 @@ corridorBetween originRoom destinationRoom (EQ, EQ) -> TopLeft -- should never happen destinationCorner = opposite originCorner - toTuple (V2 x y) = (x, y) diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs b/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs index ed4cc87e79d7..8ebcc7f4da83 100644 --- a/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs +++ b/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs @@ -14,13 +14,15 @@ import Control.Monad.Random import Data.Array.IArray (amap, bounds, rangeSize, (!)) import qualified Data.Array.IArray as Arr import Data.Foldable (any, toList) +import Linear.V2 -------------------------------------------------------------------------------- import Xanthous.Generators.Util import Xanthous.Random -import Xanthous.Data ( Position, _Position, positionFromPair - , rotations, arrayNeighbors, Neighbors(..) - , neighborPositions - ) +import Xanthous.Data + ( positionFromV2, Position, _Position + , rotations, arrayNeighbors, Neighbors(..) + , neighborPositions + ) import Xanthous.Data.EntityMap (EntityMap, _EntityMap) import Xanthous.Entities.Raws (rawsWithType, RawType) import qualified Xanthous.Entities.Item as Item @@ -49,7 +51,7 @@ randomDoors cells = do doorRatio <- getRandomR subsetRange let numDoors = floor $ doorRatio * fromIntegral (length candidateCells) doorPositions = - removeAdjacent . fmap positionFromPair . take numDoors $ candidateCells + removeAdjacent . fmap positionFromV2 . take numDoors $ candidateCells doors = zip doorPositions $ repeat unlockedDoor pure $ _EntityMap # doors where @@ -92,8 +94,9 @@ tutorialMessage cells characterPosition = do accessiblePositionsWithin :: Int -> Cells -> Position -> [Position] accessiblePositionsWithin dist valid pos = review _Position - <$> filter (\(px, py) -> not $ valid ! (fromIntegral px, fromIntegral py)) - (circle (pos ^. _Position) dist) + <$> filter + (\pt -> not $ valid ! (fromIntegral <$> pt)) + (circle (pos ^. _Position) dist) randomEntities :: forall entity raw m. (MonadRandom m, RawType raw) @@ -116,10 +119,10 @@ randomEntities newWithType sizeRange cells = pure $ _EntityMap # entities randomPosition :: MonadRandom m => Cells -> m Position -randomPosition = fmap positionFromPair . choose . impureNonNull . cellCandidates +randomPosition = fmap positionFromV2 . choose . impureNonNull . cellCandidates -- cellCandidates :: Cells -> Cells -cellCandidates :: Cells -> Set (Word, Word) +cellCandidates :: Cells -> Set (V2 Word) cellCandidates -- find the largest contiguous region of cells in the cave. = maximumBy (compare `on` length) diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs index e1e367007e65..88aadd5aadd9 100644 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs +++ b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs @@ -20,6 +20,7 @@ module Xanthous.Generators.Util ) where -------------------------------------------------------------------------------- import Xanthous.Prelude hiding (Foldable, toList, for_) +-------------------------------------------------------------------------------- import Data.Array.ST import Data.Array.Unboxed import Control.Monad.ST @@ -28,13 +29,14 @@ import Data.Monoid import Data.Foldable (Foldable, toList, for_) import qualified Data.Set as Set import Data.Semigroup.Foldable +import Linear.V2 -------------------------------------------------------------------------------- import Xanthous.Util (foldlMapM', maximum1, minimum1) import Xanthous.Data (Dimensions, width, height) -------------------------------------------------------------------------------- -type MCells s = STUArray s (Word, Word) Bool -type Cells = UArray (Word, Word) Bool +type MCells s = STUArray s (V2 Word) Bool +type Cells = UArray (V2 Word) Bool type CellM g s a = RandT g (ST s) a randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (MCells s) @@ -43,28 +45,28 @@ randInitialize dims aliveChance = do for_ [0..dims ^. width] $ \i -> for_ [0..dims ^. height] $ \j -> do val <- (>= aliveChance) <$> getRandomR (0, 1) - lift $ writeArray res (i, j) val + lift $ writeArray res (V2 i j) val pure res initializeEmpty :: RandomGen g => Dimensions -> CellM g s (MCells s) initializeEmpty dims = - lift $ newArray ((0, 0), (dims ^. width, dims ^. height)) False + lift $ newArray (0, V2 (dims ^. width) (dims ^. height)) False numAliveNeighborsM - :: forall a i j m - . (MArray a Bool m, Ix (i, j), Integral i, Integral j) - => a (i, j) Bool - -> (i, j) + :: forall a i m + . (MArray a Bool m, Ix i, Integral i) + => a (V2 i) Bool + -> V2 i -> m Word -numAliveNeighborsM cells (x, y) = do +numAliveNeighborsM cells (V2 x y) = do cellBounds <- getBounds cells getSum <$> foldlMapM' (fmap (Sum . fromIntegral . fromEnum) . boundedGet cellBounds) neighborPositions where - boundedGet :: ((i, j), (i, j)) -> (Int, Int) -> m Bool - boundedGet ((minX, minY), (maxX, maxY)) (i, j) + boundedGet :: (V2 i, V2 i) -> (Int, Int) -> m Bool + boundedGet (V2 minX minY, V2 maxX maxY) (i, j) | x <= minX || y <= minY || x >= maxX @@ -73,23 +75,23 @@ numAliveNeighborsM cells (x, y) = do | otherwise = let nx = fromIntegral $ fromIntegral x + i ny = fromIntegral $ fromIntegral y + j - in readArray cells (nx, ny) + in readArray cells $ V2 nx ny numAliveNeighbors - :: forall a i j - . (IArray a Bool, Ix (i, j), Integral i, Integral j) - => a (i, j) Bool - -> (i, j) + :: forall a i + . (IArray a Bool, Ix i, Integral i) + => a (V2 i) Bool + -> V2 i -> Word -numAliveNeighbors cells (x, y) = +numAliveNeighbors cells (V2 x y) = let cellBounds = bounds cells in getSum $ foldMap (Sum . fromIntegral . fromEnum . boundedGet cellBounds) neighborPositions where - boundedGet :: ((i, j), (i, j)) -> (Int, Int) -> Bool - boundedGet ((minX, minY), (maxX, maxY)) (i, j) + boundedGet :: (V2 i, V2 i) -> (Int, Int) -> Bool + boundedGet (V2 minX minY, V2 maxX maxY) (i, j) | x <= minX || y <= minY || x >= maxX @@ -98,20 +100,20 @@ numAliveNeighbors cells (x, y) = | otherwise = let nx = fromIntegral $ fromIntegral x + i ny = fromIntegral $ fromIntegral y + j - in cells ! (nx, ny) + in cells ! V2 nx ny neighborPositions :: [(Int, Int)] neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)] -fillOuterEdgesM :: (MArray a Bool m, Ix i, Ix j) => a (i, j) Bool -> m () +fillOuterEdgesM :: (MArray a Bool m, Ix i) => a (V2 i) Bool -> m () fillOuterEdgesM arr = do - ((minX, minY), (maxX, maxY)) <- getBounds arr + (V2 minX minY, V2 maxX maxY) <- getBounds arr for_ (range (minX, maxX)) $ \x -> do - writeArray arr (x, minY) True - writeArray arr (x, maxY) True + writeArray arr (V2 x minY) True + writeArray arr (V2 x maxY) True for_ (range (minY, maxY)) $ \y -> do - writeArray arr (minX, y) True - writeArray arr (maxX, y) True + writeArray arr (V2 minX y) True + writeArray arr (V2 maxX y) True cloneMArray :: forall a a' i e m. @@ -128,20 +130,20 @@ cloneMArray = thaw @_ @UArray <=< freeze -- | Flood fill a cell array starting at a point, returning a list of all the -- (true) cell locations reachable from that point -floodFill :: forall a i j. +floodFill :: forall a i. ( IArray a Bool - , Ix (i, j) - , Enum i , Enum j - , Bounded i , Bounded j - , Eq i , Eq j + , Ix i + , Enum i + , Bounded i + , Eq i ) - => a (i, j) Bool -- ^ array - -> (i, j) -- ^ position - -> Set (i, j) + => a (V2 i) Bool -- ^ array + -> (V2 i) -- ^ position + -> Set (V2 i) floodFill = go mempty where - go :: Set (i, j) -> a (i, j) Bool -> (i, j) -> Set (i, j) - go res arr@(bounds -> arrBounds) idx@(x, y) + go :: Set (V2 i) -> a (V2 i) Bool -> (V2 i) -> Set (V2 i) + go res arr@(bounds -> arrBounds) idx@(V2 x y) | not (inRange arrBounds idx) = res | not (arr ! idx) = res | otherwise = @@ -149,7 +151,7 @@ floodFill = go mempty = filter (inRange arrBounds) . filter (/= idx) . filter (`notMember` res) - $ (,) + $ V2 <$> [(if x == minBound then x else pred x) .. (if x == maxBound then x else succ x)] @@ -162,19 +164,19 @@ floodFill = go mempty in r' `seq` go r' arr idx') else r) (res & contains idx .~ True) neighbors -{-# SPECIALIZE floodFill :: UArray (Word, Word) Bool -> (Word, Word) -> Set (Word, Word) #-} +{-# SPECIALIZE floodFill :: UArray (V2 Word) Bool -> (V2 Word) -> Set (V2 Word) #-} -- | Gives a list of all the disconnected regions in a cell array, represented -- each as lists of points -regions :: forall a i j. +regions :: forall a i. ( IArray a Bool - , Ix (i, j) - , Enum i , Enum j - , Bounded i , Bounded j - , Eq i , Eq j + , Ix i + , Enum i + , Bounded i + , Eq i ) - => a (i, j) Bool - -> [Set (i, j)] + => a (V2 i) Bool + -> [Set (V2 i)] regions arr | Just firstPoint <- findFirstPoint arr = let region = floodFill arr firstPoint @@ -182,9 +184,9 @@ regions arr in region : regions arr' | otherwise = [] where - findFirstPoint :: a (i, j) Bool -> Maybe (i, j) + findFirstPoint :: a (V2 i) Bool -> Maybe (V2 i) findFirstPoint = fmap fst . headMay . filter snd . assocs -{-# SPECIALIZE regions :: UArray (Word, Word) Bool -> [Set (Word, Word)] #-} +{-# SPECIALIZE regions :: UArray (V2 Word) Bool -> [Set (V2 Word)] #-} fillAll :: (IArray a Bool, Ix i, Foldable f) => f i -> a i Bool -> a i Bool fillAll ixes a = accum (const fst) a $ (, (False, ())) <$> toList ixes diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs index 614170d0c4f1..cc9c9d963f5c 100644 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs +++ b/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs @@ -73,9 +73,9 @@ fromCave' wallPositions = failing (pure ()) $ do where insertEntity e pt = modify $ EntityMap.insertAt (ptToPos pt) $ SomeEntity e - ptToPos pt = _Position # (pt & both %~ fromIntegral) + ptToPos pt = _Position # (fromIntegral <$> pt) - stepOut :: Set (Word, Word) -> [[(Word, Word)]] -> MaybeT m [[(Word, Word)]] + stepOut :: Set (V2 Word) -> [[V2 Word]] -> MaybeT m [[V2 Word]] stepOut circ rooms = for rooms $ \room -> let nextLevels = hashNub $ toList . neighborCells =<< room in pure -- cgit 1.4.1