diff options
12 files changed, 300 insertions, 20 deletions
diff --git a/users/glittershark/xanthous/package.yaml b/users/glittershark/xanthous/package.yaml index 5321b1fd3ce5..013c483db55a 100644 --- a/users/glittershark/xanthous/package.yaml +++ b/users/glittershark/xanthous/package.yaml @@ -54,6 +54,7 @@ dependencies: - MonadRandom - mtl - optparse-applicative +- parallel - parser-combinators - pointed - random @@ -67,6 +68,7 @@ dependencies: - stache - semigroupoids - tomland +- transformers - text - text-zipper - vector 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 diff --git a/users/glittershark/xanthous/test/Spec.hs b/users/glittershark/xanthous/test/Spec.hs index b7004b4f8948..f15c393ac917 100644 --- a/users/glittershark/xanthous/test/Spec.hs +++ b/users/glittershark/xanthous/test/Spec.hs @@ -1,11 +1,11 @@ -------------------------------------------------------------------------------- import Test.Prelude -------------------------------------------------------------------------------- +import qualified Xanthous.Data.EntitiesSpec import qualified Xanthous.Data.EntityCharSpec -import qualified Xanthous.Data.EntityMapSpec import qualified Xanthous.Data.EntityMap.GraphicsSpec +import qualified Xanthous.Data.EntityMapSpec import qualified Xanthous.Data.LevelsSpec -import qualified Xanthous.Data.EntitiesSpec import qualified Xanthous.Data.NestedMapSpec import qualified Xanthous.DataSpec import qualified Xanthous.Entities.RawsSpec @@ -14,8 +14,9 @@ import qualified Xanthous.Generators.UtilSpec import qualified Xanthous.MessageSpec import qualified Xanthous.Messages.TemplateSpec import qualified Xanthous.OrphansSpec -import qualified Xanthous.Util.GraphicsSpec +import qualified Xanthous.RandomSpec import qualified Xanthous.Util.GraphSpec +import qualified Xanthous.Util.GraphicsSpec import qualified Xanthous.Util.InflectionSpec import qualified Xanthous.UtilSpec -------------------------------------------------------------------------------- @@ -25,21 +26,22 @@ main = defaultMain test test :: TestTree test = testGroup "Xanthous" - [ Xanthous.Data.EntityCharSpec.test - , Xanthous.Data.EntityMapSpec.test + [ Xanthous.Data.EntitiesSpec.test , Xanthous.Data.EntityMap.GraphicsSpec.test - , Xanthous.Data.EntitiesSpec.test + , Xanthous.Data.EntityMapSpec.test , Xanthous.Data.LevelsSpec.test , Xanthous.Data.NestedMapSpec.test + , Xanthous.DataSpec.test , Xanthous.Entities.RawsSpec.test , Xanthous.GameSpec.test , Xanthous.Generators.UtilSpec.test , Xanthous.MessageSpec.test , Xanthous.Messages.TemplateSpec.test , Xanthous.OrphansSpec.test - , Xanthous.DataSpec.test - , Xanthous.UtilSpec.test - , Xanthous.Util.GraphicsSpec.test + , Xanthous.RandomSpec.test , Xanthous.Util.GraphSpec.test + , Xanthous.Util.GraphicsSpec.test , Xanthous.Util.InflectionSpec.test + , Xanthous.UtilSpec.test + , Xanthous.Data.EntityCharSpec.test ] diff --git a/users/glittershark/xanthous/test/Xanthous/RandomSpec.hs b/users/glittershark/xanthous/test/Xanthous/RandomSpec.hs new file mode 100644 index 000000000000..187336f08650 --- /dev/null +++ b/users/glittershark/xanthous/test/Xanthous/RandomSpec.hs @@ -0,0 +1,25 @@ +-------------------------------------------------------------------------------- +module Xanthous.RandomSpec (main, test) where +-------------------------------------------------------------------------------- +import Test.Prelude +-------------------------------------------------------------------------------- +import Control.Monad.Random +-------------------------------------------------------------------------------- +import Xanthous.Random +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain test + +test :: TestTree +test = testGroup "Xanthous.Random" + [ testGroup "chooseSubset" + [ testProperty "chooses a subset" + $ \(l :: [Int]) (Positive (r :: Double)) -> randomTest $ do + ss <- chooseSubset r l + pure $ all (`elem` l) ss + + ] + ] + where + randomTest prop = evalRandT prop . mkStdGen =<< arbitrary diff --git a/users/glittershark/xanthous/xanthous.cabal b/users/glittershark/xanthous/xanthous.cabal index 63649a89a897..653389a4c5cb 100644 --- a/users/glittershark/xanthous/xanthous.cabal +++ b/users/glittershark/xanthous/xanthous.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 88019942f93977e08b513ce6991401694c431b7b2b7b1b5d2afccb3f0afb26ed +-- hash: 5f419c8c149f045c818a2fb392b1233a0958e71e92d7a837deabc412e2b5adda name: xanthous version: 0.1.0.0 @@ -68,6 +68,7 @@ library Xanthous.Generators.Dungeon Xanthous.Generators.LevelContents Xanthous.Generators.Util + Xanthous.Generators.Village Xanthous.Messages Xanthous.Messages.Template Xanthous.Monad @@ -126,6 +127,7 @@ library , monad-control , mtl , optparse-applicative + , parallel , parser-combinators , pointed , quickcheck-instances @@ -142,6 +144,7 @@ library , text , text-zipper , tomland + , transformers , vector , vty , witherable @@ -191,6 +194,7 @@ executable xanthous Xanthous.Generators.Dungeon Xanthous.Generators.LevelContents Xanthous.Generators.Util + Xanthous.Generators.Village Xanthous.Messages Xanthous.Messages.Template Xanthous.Monad @@ -248,6 +252,7 @@ executable xanthous , monad-control , mtl , optparse-applicative + , parallel , parser-combinators , pointed , quickcheck-instances @@ -264,6 +269,7 @@ executable xanthous , text , text-zipper , tomland + , transformers , vector , vty , witherable @@ -290,6 +296,7 @@ test-suite test Xanthous.Messages.TemplateSpec Xanthous.MessageSpec Xanthous.OrphansSpec + Xanthous.RandomSpec Xanthous.Util.GraphicsSpec Xanthous.Util.GraphSpec Xanthous.Util.InflectionSpec @@ -338,6 +345,7 @@ test-suite test , monad-control , mtl , optparse-applicative + , parallel , parser-combinators , pointed , quickcheck-instances @@ -357,6 +365,84 @@ test-suite test , text , text-zipper , tomland + , transformers + , vector + , vty + , witherable + , xanthous + , yaml + , zlib + default-language: Haskell2010 + +benchmark benchmark + type: exitcode-stdio-1.0 + main-is: Bench.hs + other-modules: + Bench.Prelude + Xanthous.Generators.UtilBench + Xanthous.RandomBench + Paths_xanthous + hs-source-dirs: + bench + default-extensions: BlockArguments ConstraintKinds DataKinds DeriveAnyClass DeriveGeneric DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances FunctionalDependencies GADTSyntax GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiWayIf NoImplicitPrelude NoStarIsType OverloadedStrings PolyKinds RankNTypes ScopedTypeVariables TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + JuicyPixels + , MonadRandom + , QuickCheck + , Rasterific + , aeson + , array + , async + , base + , bifunctors + , brick + , checkers + , classy-prelude + , comonad + , comonad-extras + , constraints + , containers + , criterion + , data-default + , deepseq + , directory + , fgl + , fgl-arbitrary + , file-embed + , filepath + , generic-arbitrary + , generic-lens + , generic-monoid + , groups + , hgeometry + , hgeometry-combinatorial + , lens + , lifted-async + , linear + , megaparsec + , mmorph + , monad-control + , mtl + , optparse-applicative + , parallel + , parser-combinators + , pointed + , quickcheck-instances + , quickcheck-text + , random + , random-extras + , random-fu + , random-source + , raw-strings-qq + , reflection + , semigroupoids + , stache + , streams + , text + , text-zipper + , tomland + , transformers , vector , vty , witherable |