diff options
author | Griffin Smith <grfn@gws.fyi> | 2021-04-11T21·53-0400 |
---|---|---|
committer | glittershark <grfn@gws.fyi> | 2021-04-12T14·45+0000 |
commit | 6266c5d32f9ff651fcfc3a4cc0c68e89da56ca65 (patch) | |
tree | 5be3967585787c4456e17cb29423770217fdcede /users/glittershark/xanthous/src/Xanthous/Generators/Village.hs | |
parent | 968effb5dc1a4617a0dceaffc70e986abe300c6e (diff) |
refactor(users/glittershark): Rename to grfn r/2485
Rename my //users directory and all places that refer to glittershark to grfn, including nix references and documentation. This may require some extra attention inside of gerrit's database after it lands to allow me to actually push things. Change-Id: I4728b7ec2c60024392c1c1fa6e0d4a59b3e266fa Reviewed-on: https://cl.tvl.fyi/c/depot/+/2933 Tested-by: BuildkiteCI Reviewed-by: tazjin <mail@tazj.in> Reviewed-by: lukegb <lukegb@tvl.fyi> Reviewed-by: glittershark <grfn@gws.fyi>
Diffstat (limited to 'users/glittershark/xanthous/src/Xanthous/Generators/Village.hs')
-rw-r--r-- | users/glittershark/xanthous/src/Xanthous/Generators/Village.hs | 125 |
1 files changed, 0 insertions, 125 deletions
diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs deleted file mode 100644 index cc9c9d963f5c..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs +++ /dev/null @@ -1,125 +0,0 @@ -module Xanthous.Generators.Village - ( fromCave - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (any, failing, toList) --------------------------------------------------------------------------------- -import Control.Monad.Random (MonadRandom) -import Control.Monad.State (execStateT, MonadState, modify) -import Control.Monad.Trans.Maybe -import Control.Parallel.Strategies -import Data.Array.IArray -import Data.Foldable (any, toList) --------------------------------------------------------------------------------- -import Xanthous.Data -import Xanthous.Data.EntityMap (EntityMap) -import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Entities.Environment -import Xanthous.Generators.Util -import Xanthous.Game.State (SomeEntity(..)) -import Xanthous.Random --------------------------------------------------------------------------------- - -fromCave :: MonadRandom m - => Cells -- ^ The positions of all the walls - -> m (EntityMap SomeEntity) -fromCave wallPositions = execStateT (fromCave' wallPositions) mempty - -fromCave' :: forall m. (MonadRandom m, MonadState (EntityMap SomeEntity) m) - => Cells - -> m () -fromCave' wallPositions = failing (pure ()) $ do - Just villageRegion <- - choose - . (`using` parTraversable rdeepseq) - . weightedBy (\reg -> let circSize = length $ circumference reg - in if circSize == 50 - then (1.0 :: Double) - else 1.0 / (fromIntegral . abs $ circSize - 50)) - $ regions closedHallways - - let circ = setFromList . circumference $ villageRegion - - centerPoints <- chooseSubset (0.1 :: Double) $ toList circ - - roomTiles <- foldM - (flip $ const $ stepOut circ) - (map pure centerPoints) - [0 :: Int ..2] - - let roomWalls = circumference . setFromList @(Set _) <$> roomTiles - allWalls = join roomWalls - - doorPositions <- fmap join . for roomWalls $ \room -> - let candidates = filter (`notMember` circ) room - in fmap toList . choose $ ChooseElement candidates - - let entryways = - filter (\pt -> - let ncs = neighborCells pt - in any ((&&) <$> (not . (wallPositions !)) - <*> (`notMember` villageRegion)) ncs - && any ((&&) <$> (`member` villageRegion) - <*> (`notElem` allWalls)) ncs) - $ toList villageRegion - - Just entryway <- choose $ ChooseElement entryways - - for_ (filter ((&&) <$> (`notElem` doorPositions) <*> (/= entryway)) allWalls) - $ insertEntity Wall - for_ (filter (/= entryway) doorPositions) $ insertEntity unlockedDoor - insertEntity unlockedDoor entryway - - - where - insertEntity e pt = modify $ EntityMap.insertAt (ptToPos pt) $ SomeEntity e - ptToPos pt = _Position # (fromIntegral <$> pt) - - stepOut :: Set (V2 Word) -> [[V2 Word]] -> MaybeT m [[V2 Word]] - stepOut circ rooms = for rooms $ \room -> - let nextLevels = hashNub $ toList . neighborCells =<< room - in pure - . (<> room) - $ filter ((&&) <$> (`notMember` circ) <*> (`notElem` join rooms)) - nextLevels - - circumference pts = - filter (any (`notMember` pts) . neighborCells) $ toList pts - closedHallways = closeHallways livePositions - livePositions = amap not wallPositions - --------------------------------------------------------------------------------- - -closeHallways :: Cells -> Cells -closeHallways livePositions = - livePositions // mapMaybe closeHallway (assocs livePositions) - where - closeHallway (_, False) = Nothing - closeHallway (pos, _) - | isHallway pos = Just (pos, False) - | otherwise = Nothing - isHallway pos = any ((&&) <$> not . view left <*> not . view right) - . rotations - . fmap (fromMaybe False) - $ arrayNeighbors livePositions pos - -failing :: Monad m => m a -> MaybeT m a -> m a -failing result = (maybe result pure =<<) . runMaybeT - -{- - -import Xanthous.Generators.Village -import Xanthous.Generators -import Xanthous.Data -import System.Random -import qualified Data.Text -import qualified Xanthous.Generators.CaveAutomata as CA -let gi = GeneratorInput SCaveAutomata CA.defaultParams -wallPositions <- generateFromInput gi (Dimensions 80 50) <$> getStdGen -putStrLn . Data.Text.unpack $ showCells wallPositions - -import Data.Array.IArray -let closedHallways = closeHallways . amap not $ wallPositions -putStrLn . Data.Text.unpack . showCells $ amap not closedHallways - --} |