diff options
Diffstat (limited to 'users/glittershark/xanthous/src')
8 files changed, 175 insertions, 10 deletions
diff --git a/users/glittershark/xanthous/src/Xanthous/App.hs b/users/glittershark/xanthous/src/Xanthous/App.hs index 672aa93f6b32..e20c5d97b854 100644 --- a/users/glittershark/xanthous/src/Xanthous/App.hs +++ b/users/glittershark/xanthous/src/Xanthous/App.hs @@ -15,7 +15,6 @@ import Control.Monad.State (get, gets) import Control.Monad.State.Class (modify) import Data.Aeson (object, ToJSON) import qualified Data.Aeson as A -import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Vector as V import System.Exit import System.Directory (doesFileExist) diff --git a/users/glittershark/xanthous/src/Xanthous/Data.hs b/users/glittershark/xanthous/src/Xanthous/Data.hs index 67173cc89646..031815b8fba4 100644 --- a/users/glittershark/xanthous/src/Xanthous/Data.hs +++ b/users/glittershark/xanthous/src/Xanthous/Data.hs @@ -79,8 +79,17 @@ module Xanthous.Data , edges , neighborDirections , neighborPositions + , neighborCells , arrayNeighbors , rotations + , HasTopLeft(..) + , HasTop(..) + , HasTopRight(..) + , HasLeft(..) + , HasRight(..) + , HasBottomLeft(..) + , HasBottom(..) + , HasBottomRight(..) -- * , Hitpoints(..) @@ -439,6 +448,9 @@ neighborDirections = Neighbors neighborPositions :: Num a => Position' a -> Neighbors (Position' a) neighborPositions pos = (`move` pos) <$> neighborDirections +neighborCells :: Num a => (a, a) -> Neighbors (a, a) +neighborCells = map (view _Position) . neighborPositions . review _Position + arrayNeighbors :: (IArray a e, Ix i, Num i) => a (i, i) e diff --git a/users/glittershark/xanthous/src/Xanthous/Generators.hs b/users/glittershark/xanthous/src/Xanthous/Generators.hs index 9b2b90e300c7..5bc8bcf03582 100644 --- a/users/glittershark/xanthous/src/Xanthous/Generators.hs +++ b/users/glittershark/xanthous/src/Xanthous/Generators.hs @@ -6,7 +6,7 @@ module Xanthous.Generators ( generate , Generator(..) , SGenerator(..) - , GeneratorInput + , GeneratorInput(..) , generateFromInput , parseGeneratorInput , showCells @@ -17,6 +17,7 @@ module Xanthous.Generators , levelDoors , levelCharacterPosition , levelTutorialMessage + , levelExtra , generateLevel , levelToEntityMap ) where @@ -31,6 +32,7 @@ import qualified Xanthous.Generators.CaveAutomata as CaveAutomata import qualified Xanthous.Generators.Dungeon as Dungeon import Xanthous.Generators.Util import Xanthous.Generators.LevelContents +import Xanthous.Generators.Village as Village import Xanthous.Data (Dimensions, Position'(Position), Position) import Xanthous.Data.EntityMap (EntityMap, _EntityMap) import qualified Xanthous.Data.EntityMap as EntityMap @@ -118,6 +120,7 @@ data Level = Level , _levelCreatures :: !(EntityMap Creature) , _levelTutorialMessage :: !(EntityMap GroundMessage) , _levelStaircases :: !(EntityMap Staircase) + , _levelExtra :: !(EntityMap SomeEntity) -- ^ TODO this is a bit of a hack... , _levelCharacterPosition :: !Position } deriving stock (Generic) @@ -134,6 +137,8 @@ generateLevel gen ps dims = do rand <- mkStdGen <$> getRandom let cells = generate gen ps dims rand _levelWalls = cellsToWalls cells + village <- generateVillage cells gen + let _levelExtra = village _levelItems <- randomItems cells _levelCreatures <- randomCreatures cells _levelDoors <- randomDoors cells @@ -152,3 +157,12 @@ levelToEntityMap level <> (SomeEntity <$> level ^. levelCreatures) <> (SomeEntity <$> level ^. levelTutorialMessage) <> (SomeEntity <$> level ^. levelStaircases) + <> (level ^. levelExtra) + +generateVillage + :: MonadRandom m + => Cells -- ^ Wall positions + -> SGenerator gen + -> m (EntityMap SomeEntity) +generateVillage wallPositions SCaveAutomata = Village.fromCave wallPositions +generateVillage _ _ = pure mempty diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs index 83740fe4b73d..ada201ef3d6c 100644 --- a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs +++ b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs @@ -70,6 +70,7 @@ parseParams = Params <> Opt.help "Number of generations to run the automata for" <> Opt.metavar "STEPS" ) + <**> Opt.helper where parseChance = readWithGuard (between 0 1) diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs index 70d94860dc68..e1e367007e65 100644 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs +++ b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs @@ -75,9 +75,6 @@ numAliveNeighborsM cells (x, y) = do ny = fromIntegral $ fromIntegral y + j in readArray cells (nx, ny) - neighborPositions :: [(Int, Int)] - neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)] - numAliveNeighbors :: forall a i j . (IArray a Bool, Ix (i, j), Integral i, Integral j) @@ -103,8 +100,8 @@ numAliveNeighbors cells (x, y) = ny = fromIntegral $ fromIntegral y + j in cells ! (nx, ny) - neighborPositions :: [(Int, Int)] - neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)] +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 arr = do @@ -137,7 +134,6 @@ floodFill :: forall a i j. , Enum i , Enum j , Bounded i , Bounded j , Eq i , Eq j - , Show i, Show j ) => a (i, j) Bool -- ^ array -> (i, j) -- ^ position @@ -145,7 +141,6 @@ floodFill :: forall a i j. floodFill = go mempty where go :: Set (i, j) -> a (i, j) Bool -> (i, j) -> Set (i, j) - -- TODO pass result in rather than passing seen in, return result go res arr@(bounds -> arrBounds) idx@(x, y) | not (inRange arrBounds idx) = res | not (arr ! idx) = res @@ -177,7 +172,6 @@ regions :: forall a i j. , Enum i , Enum j , Bounded i , Bounded j , Eq i , Eq j - , Show i, Show j ) => a (i, j) Bool -> [Set (i, j)] diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs new file mode 100644 index 000000000000..52f26dcde018 --- /dev/null +++ b/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE PartialTypeSignatures #-} +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 # (pt & both %~ fromIntegral) + + stepOut :: Set (Word, Word) -> [[(Word, Word)]] -> MaybeT m [[(Word, 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 + +-} diff --git a/users/glittershark/xanthous/src/Xanthous/Random.hs b/users/glittershark/xanthous/src/Xanthous/Random.hs index 41c80ab73c4c..6d34109df7f8 100644 --- a/users/glittershark/xanthous/src/Xanthous/Random.hs +++ b/users/glittershark/xanthous/src/Xanthous/Random.hs @@ -10,6 +10,7 @@ module Xanthous.Random , weightedBy , subRand , chance + , chooseSubset ) where -------------------------------------------------------------------------------- import Xanthous.Prelude @@ -17,6 +18,7 @@ import Xanthous.Prelude import Data.List.NonEmpty (NonEmpty(..)) import Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom)) import Control.Monad.Random (Rand, evalRand, mkStdGen, StdGen) +import Data.Functor.Compose import Data.Random.Shuffle.Weighted import Data.Random.Distribution import Data.Random.Distribution.Uniform @@ -66,10 +68,16 @@ instance Choose (a, a) where choose (x, y) = choose (x :| [y]) newtype Weighted w t a = Weighted (t (w, a)) + deriving (Functor, Foldable) via (t `Compose` (,) w) + +instance Traversable t => Traversable (Weighted w t) where + traverse f (Weighted twa) = Weighted <$> (traverse . traverse) f twa evenlyWeighted :: [a] -> Weighted Int [] a evenlyWeighted = Weighted . itoList +-- | Weight the elements of some functor by a function. Larger values of 'w' per +-- its 'Ord' instance will be more likely to be generated weightedBy :: Functor t => (a -> w) -> t a -> Weighted w t a weightedBy weighting xs = Weighted $ (weighting &&& id) <$> xs @@ -96,6 +104,14 @@ chance -> m Bool chance n = choose $ weightedBy (bool 1 (n * 2)) bools +-- | Choose a random subset of *about* @w@ of the elements of the given +-- 'Witherable' structure +chooseSubset :: ( Num w, Ord w, Distribution Uniform w, Excludable w + , Witherable t + , MonadRandom m + ) => w -> t a -> m (t a) +chooseSubset = filterA . const . chance + -------------------------------------------------------------------------------- bools :: NonEmpty Bool diff --git a/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs b/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs index 5f7432f4c7e2..1b8b79164397 100644 --- a/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs +++ b/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs @@ -128,6 +128,8 @@ line pa@(xa, ya) pb@(xb, yb) (newY, newError) = if (2 * tempError) >= δx then (yTemp + ystep, tempError - δx) else (yTemp, tempError) +{-# SPECIALIZE line :: (Int, Int) -> (Int, Int) -> [(Int, Int)] #-} +{-# SPECIALIZE line :: (Word, Word) -> (Word, Word) -> [(Word, Word)] #-} straightLine :: (Num i, Ord i) => (i, i) -> (i, i) -> [(i, i)] straightLine pa@(xa, _) pb@(_, yb) = line pa midpoint ++ line midpoint pb |