diff options
Diffstat (limited to 'users/glittershark/xanthous/src/Xanthous/Generators')
5 files changed, 69 insertions, 64 deletions
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 |