Add dungeon level generation
Add a dungeon level generator, which: 1. generates an infinite sequence of rectangular rooms within the dimensions of the level 2. removes any duplicates from that sequence 3. Generates a graph from the delaunay triangulation of the centerpoints of those rooms 4. Generates the minimum-spanning-tree of that delaunay triangulation, with weights given by line length in points 5. Adds back a subset (default 10-15%) of edges from the delaunay triangulation to the graph 6. Uses the resulting graph to draw corridors between the rooms, using a random point on the near edge of each room to pick the points of the corridors
This commit is contained in:
Griffin Smith
parent
6f427fe4d6
commit
e76567b9e7
20 changed files with 680 additions and 103 deletions
25
src/Main.hs
25
src/Main.hs
|
|
@ -47,19 +47,22 @@ parseRunParams = RunParams
|
|||
data Command
|
||||
= Run RunParams
|
||||
| Load FilePath
|
||||
| Generate GeneratorInput Dimensions
|
||||
| Generate GeneratorInput Dimensions (Maybe Int)
|
||||
|
||||
parseDimensions :: Opt.Parser Dimensions
|
||||
parseDimensions = Dimensions
|
||||
<$> Opt.option Opt.auto
|
||||
( Opt.short 'w'
|
||||
<> Opt.long "width"
|
||||
<> Opt.metavar "TILES"
|
||||
)
|
||||
<*> Opt.option Opt.auto
|
||||
( Opt.short 'h'
|
||||
<> Opt.long "height"
|
||||
<> Opt.metavar "TILES"
|
||||
)
|
||||
|
||||
|
||||
parseCommand :: Opt.Parser Command
|
||||
parseCommand = (<|> Run <$> parseRunParams) $ Opt.subparser
|
||||
$ Opt.command "run"
|
||||
|
|
@ -75,6 +78,8 @@ parseCommand = (<|> Run <$> parseRunParams) $ Opt.subparser
|
|||
(Generate
|
||||
<$> parseGeneratorInput
|
||||
<*> parseDimensions
|
||||
<*> optional
|
||||
(Opt.option Opt.auto (Opt.long "seed"))
|
||||
<**> Opt.helper
|
||||
)
|
||||
(Opt.progDesc "Generate a sample level"))
|
||||
|
|
@ -91,6 +96,9 @@ runGame :: RunParams -> IO ()
|
|||
runGame rparams = do
|
||||
app <- makeApp
|
||||
gameSeed <- maybe getRandom pure $ seed rparams
|
||||
when (isNothing $ seed rparams)
|
||||
. putStrLn
|
||||
$ "Seed: " <> tshow gameSeed
|
||||
let initialState = Game.initialStateFromSeed gameSeed &~ do
|
||||
for_ (characterName rparams) $ \cn ->
|
||||
Game.character . Character.characterName ?= cn
|
||||
|
|
@ -112,11 +120,16 @@ loadGame saveFile = do
|
|||
pure ()
|
||||
|
||||
|
||||
runGenerate :: GeneratorInput -> Dimensions -> IO ()
|
||||
runGenerate input dims = do
|
||||
randGen <- getStdGen
|
||||
let res = generateFromInput input dims randGen
|
||||
runGenerate :: GeneratorInput -> Dimensions -> Maybe Int -> IO ()
|
||||
runGenerate input dims mSeed = do
|
||||
putStrLn "Generating..."
|
||||
genSeed <- maybe getRandom pure mSeed
|
||||
let randGen = mkStdGen genSeed
|
||||
res = generateFromInput input dims randGen
|
||||
rs = regions $ amap not res
|
||||
when (isNothing mSeed)
|
||||
. putStrLn
|
||||
$ "Seed: " <> tshow genSeed
|
||||
putStr "num regions: "
|
||||
print $ length rs
|
||||
putStr "region lengths: "
|
||||
|
|
@ -128,7 +141,7 @@ runGenerate input dims = do
|
|||
runCommand :: Command -> IO ()
|
||||
runCommand (Run runParams) = runGame runParams
|
||||
runCommand (Load saveFile) = loadGame saveFile
|
||||
runCommand (Generate input dims) = runGenerate input dims
|
||||
runCommand (Generate input dims mSeed) = runGenerate input dims mSeed
|
||||
|
||||
main :: IO ()
|
||||
main = runCommand =<< Opt.execParser optParser
|
||||
|
|
|
|||
|
|
@ -1,23 +1,27 @@
|
|||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE RoleAnnotations #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE NoTypeSynonymInstances #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE RoleAnnotations #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE NoTypeSynonymInstances #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Common data types for Xanthous
|
||||
--------------------------------------------------------------------------------
|
||||
module Xanthous.Data
|
||||
( -- *
|
||||
Position'(..)
|
||||
( Opposite(..)
|
||||
|
||||
-- *
|
||||
, Position'(..)
|
||||
, Position
|
||||
, x
|
||||
, y
|
||||
|
||||
-- **
|
||||
, Positioned(..)
|
||||
, _Positioned
|
||||
, position
|
||||
|
|
@ -30,6 +34,18 @@ module Xanthous.Data
|
|||
, stepTowards
|
||||
, isUnit
|
||||
|
||||
-- * Boxes
|
||||
, Box(..)
|
||||
, topLeftCorner
|
||||
, bottomRightCorner
|
||||
, setBottomRightCorner
|
||||
, dimensions
|
||||
, inBox
|
||||
, boxIntersects
|
||||
, boxCenter
|
||||
, boxEdge
|
||||
, module Linear.V2
|
||||
|
||||
-- *
|
||||
, Per(..)
|
||||
, invertRate
|
||||
|
|
@ -49,11 +65,15 @@ module Xanthous.Data
|
|||
|
||||
-- *
|
||||
, Direction(..)
|
||||
, opposite
|
||||
, move
|
||||
, asPosition
|
||||
, directionOf
|
||||
|
||||
-- *
|
||||
, Corner(..)
|
||||
, Edge(..)
|
||||
, cornerEdges
|
||||
|
||||
-- *
|
||||
, Neighbors(..)
|
||||
, edges
|
||||
|
|
@ -65,6 +85,9 @@ module Xanthous.Data
|
|||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude hiding (Left, Down, Right, (.=))
|
||||
--------------------------------------------------------------------------------
|
||||
import Linear.V2 hiding (_x, _y)
|
||||
import qualified Linear.V2 as L
|
||||
import Test.QuickCheck (Arbitrary, CoArbitrary, Function)
|
||||
import Test.QuickCheck.Arbitrary.Generic
|
||||
import Data.Group
|
||||
|
|
@ -74,11 +97,18 @@ import Data.Aeson.Generic.DerivingVia
|
|||
import Data.Aeson
|
||||
( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject)
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Util (EqEqProp(..), EqProp)
|
||||
import Xanthous.Util (EqEqProp(..), EqProp, between)
|
||||
import Xanthous.Util.QuickCheck (GenericArbitrary(..))
|
||||
import Xanthous.Orphans ()
|
||||
import Xanthous.Util.Graphics
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | opposite ∘ opposite ≡ id
|
||||
class Opposite x where
|
||||
opposite :: x -> x
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- fromScalar ∘ scalar ≡ id
|
||||
class Scalar a where
|
||||
scalar :: a -> Double
|
||||
|
|
@ -109,7 +139,10 @@ data Position' a where
|
|||
deriving (ToJSON, FromJSON)
|
||||
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
|
||||
(Position' a)
|
||||
makeLenses ''Position'
|
||||
|
||||
x, y :: Lens' (Position' a) a
|
||||
x = lens (\(Position xx _) -> xx) (\(Position _ yy) xx -> Position xx yy)
|
||||
y = lens (\(Position _ yy) -> yy) (\(Position xx _) yy -> Position xx yy)
|
||||
|
||||
type Position = Position' Int
|
||||
|
||||
|
|
@ -236,16 +269,16 @@ instance Arbitrary Direction where
|
|||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
opposite :: Direction -> Direction
|
||||
opposite Up = Down
|
||||
opposite Down = Up
|
||||
opposite Left = Right
|
||||
opposite Right = Left
|
||||
opposite UpLeft = DownRight
|
||||
opposite UpRight = DownLeft
|
||||
opposite DownLeft = UpRight
|
||||
opposite DownRight = UpLeft
|
||||
opposite Here = Here
|
||||
instance Opposite Direction where
|
||||
opposite Up = Down
|
||||
opposite Down = Up
|
||||
opposite Left = Right
|
||||
opposite Right = Left
|
||||
opposite UpLeft = DownRight
|
||||
opposite UpRight = DownLeft
|
||||
opposite DownLeft = UpRight
|
||||
opposite DownRight = UpLeft
|
||||
opposite Here = Here
|
||||
|
||||
move :: Direction -> Position -> Position
|
||||
move Up = y -~ 1
|
||||
|
|
@ -295,6 +328,40 @@ stepTowards (view _Position -> p₁) (view _Position -> p₂)
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Corner
|
||||
= TopLeft
|
||||
| TopRight
|
||||
| BottomLeft
|
||||
| BottomRight
|
||||
deriving stock (Show, Eq, Ord, Enum, Bounded, Generic)
|
||||
|
||||
instance Opposite Corner where
|
||||
opposite TopLeft = BottomRight
|
||||
opposite TopRight = BottomLeft
|
||||
opposite BottomLeft = TopRight
|
||||
opposite BottomRight = TopLeft
|
||||
|
||||
data Edge
|
||||
= TopEdge
|
||||
| LeftEdge
|
||||
| RightEdge
|
||||
| BottomEdge
|
||||
deriving stock (Show, Eq, Ord, Enum, Bounded, Generic)
|
||||
|
||||
instance Opposite Edge where
|
||||
opposite TopEdge = BottomEdge
|
||||
opposite BottomEdge = TopEdge
|
||||
opposite LeftEdge = RightEdge
|
||||
opposite RightEdge = LeftEdge
|
||||
|
||||
cornerEdges :: Corner -> (Edge, Edge)
|
||||
cornerEdges TopLeft = (TopEdge, LeftEdge)
|
||||
cornerEdges TopRight = (TopEdge, RightEdge)
|
||||
cornerEdges BottomLeft = (BottomEdge, LeftEdge)
|
||||
cornerEdges BottomRight = (BottomEdge, RightEdge)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Neighbors a = Neighbors
|
||||
{ _topLeft
|
||||
, _top
|
||||
|
|
@ -307,7 +374,7 @@ data Neighbors a = Neighbors
|
|||
}
|
||||
deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
|
||||
deriving anyclass (NFData)
|
||||
makeLenses ''Neighbors
|
||||
makeFieldsNoPrefix ''Neighbors
|
||||
|
||||
instance Applicative Neighbors where
|
||||
pure α = Neighbors
|
||||
|
|
@ -403,3 +470,57 @@ newtype Hitpoints = Hitpoints Word
|
|||
via Word
|
||||
deriving (Semigroup, Monoid) via Sum Word
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Box a = Box
|
||||
{ _topLeftCorner :: V2 a
|
||||
, _dimensions :: V2 a
|
||||
}
|
||||
deriving stock (Show, Eq, Ord, Functor, Generic)
|
||||
deriving Arbitrary via GenericArbitrary (Box a)
|
||||
makeFieldsNoPrefix ''Box
|
||||
|
||||
bottomRightCorner :: Num a => Box a -> V2 a
|
||||
bottomRightCorner box =
|
||||
V2 (box ^. topLeftCorner . L._x + box ^. dimensions . L._x)
|
||||
(box ^. topLeftCorner . L._y + box ^. dimensions . L._y)
|
||||
|
||||
setBottomRightCorner :: (Num a, Ord a) => Box a -> V2 a -> Box a
|
||||
setBottomRightCorner box br@(V2 brx bry)
|
||||
| brx < box ^. topLeftCorner . L._x || bry < box ^. topLeftCorner . L._y
|
||||
= box & topLeftCorner .~ br
|
||||
& dimensions . L._x .~ ((box ^. topLeftCorner . L._x) - brx)
|
||||
& dimensions . L._y .~ ((box ^. topLeftCorner . L._y) - bry)
|
||||
| otherwise
|
||||
= box & dimensions . L._x .~ (brx - (box ^. topLeftCorner . L._x))
|
||||
& dimensions . L._y .~ (bry - (box ^. topLeftCorner . L._y))
|
||||
|
||||
inBox :: (Ord a, Num a) => Box a -> V2 a -> Bool
|
||||
inBox box pt = flip all [L._x, L._y] $ \component ->
|
||||
between (box ^. topLeftCorner . component)
|
||||
(box ^. to bottomRightCorner . component)
|
||||
(pt ^. component)
|
||||
|
||||
boxIntersects :: (Ord a, Num a) => Box a -> Box a -> Bool
|
||||
boxIntersects box₁ box₂
|
||||
= any (inBox box₁) [box₂ ^. topLeftCorner, bottomRightCorner box₂]
|
||||
|
||||
boxCenter :: (Fractional a) => Box a -> V2 a
|
||||
boxCenter box = V2 cx cy
|
||||
where
|
||||
cx = box ^. topLeftCorner . L._x + (box ^. dimensions . L._x / 2)
|
||||
cy = box ^. topLeftCorner . L._y + (box ^. dimensions . L._y / 2)
|
||||
|
||||
boxEdge :: (Enum a, Num a) => Box a -> Edge -> [V2 a]
|
||||
boxEdge box LeftEdge =
|
||||
V2 (box ^. topLeftCorner . L._x)
|
||||
<$> [box ^. topLeftCorner . L._y .. box ^. to bottomRightCorner . L._y]
|
||||
boxEdge box RightEdge =
|
||||
V2 (box ^. to bottomRightCorner . L._x)
|
||||
<$> [box ^. to bottomRightCorner . L._y .. box ^. to bottomRightCorner . L._y]
|
||||
boxEdge box TopEdge =
|
||||
flip V2 (box ^. topLeftCorner . L._y)
|
||||
<$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x]
|
||||
boxEdge box BottomEdge =
|
||||
flip V2 (box ^. to bottomRightCorner . L._y)
|
||||
<$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x]
|
||||
|
|
|
|||
|
|
@ -25,6 +25,7 @@ import qualified Options.Applicative as Opt
|
|||
import Control.Monad.Random
|
||||
--------------------------------------------------------------------------------
|
||||
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
|
||||
import qualified Xanthous.Generators.Dungeon as Dungeon
|
||||
import Xanthous.Generators.Util
|
||||
import Xanthous.Generators.LevelContents
|
||||
import Xanthous.Data (Dimensions, Position'(Position), Position)
|
||||
|
|
@ -35,14 +36,18 @@ import Xanthous.Entities.Item (Item)
|
|||
import Xanthous.Entities.Creature (Creature)
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Generator = CaveAutomata
|
||||
data Generator
|
||||
= CaveAutomata
|
||||
| Dungeon
|
||||
deriving stock (Show, Eq)
|
||||
|
||||
data SGenerator (gen :: Generator) where
|
||||
SCaveAutomata :: SGenerator 'CaveAutomata
|
||||
SDungeon :: SGenerator 'Dungeon
|
||||
|
||||
type family Params (gen :: Generator) :: Type where
|
||||
Params 'CaveAutomata = CaveAutomata.Params
|
||||
Params 'Dungeon = Dungeon.Params
|
||||
|
||||
generate
|
||||
:: RandomGen g
|
||||
|
|
@ -52,6 +57,7 @@ generate
|
|||
-> g
|
||||
-> Cells
|
||||
generate SCaveAutomata = CaveAutomata.generate
|
||||
generate SDungeon = Dungeon.generate
|
||||
|
||||
data GeneratorInput where
|
||||
GeneratorInput :: forall gen. SGenerator gen -> Params gen -> GeneratorInput
|
||||
|
|
@ -60,10 +66,23 @@ generateFromInput :: RandomGen g => GeneratorInput -> Dimensions -> g -> Cells
|
|||
generateFromInput (GeneratorInput sg ps) = generate sg ps
|
||||
|
||||
parseGeneratorInput :: Opt.Parser GeneratorInput
|
||||
parseGeneratorInput = Opt.subparser $
|
||||
Opt.command "cave" (Opt.info
|
||||
(GeneratorInput <$> pure SCaveAutomata <*> CaveAutomata.parseParams)
|
||||
(Opt.progDesc "cellular-automata based cave generator"))
|
||||
parseGeneratorInput = Opt.subparser
|
||||
$ generatorCommand SCaveAutomata
|
||||
"cave"
|
||||
"Cellular-automata based cave generator"
|
||||
CaveAutomata.parseParams
|
||||
<> generatorCommand SDungeon
|
||||
"dungeon"
|
||||
"Classic dungeon map generator"
|
||||
Dungeon.parseParams
|
||||
where
|
||||
generatorCommand sgen name desc parseParams =
|
||||
Opt.command name
|
||||
(Opt.info
|
||||
(GeneratorInput <$> pure sgen <*> parseParams)
|
||||
(Opt.progDesc desc)
|
||||
)
|
||||
|
||||
|
||||
showCells :: Cells -> Text
|
||||
showCells arr =
|
||||
|
|
|
|||
|
|
@ -2,23 +2,25 @@
|
|||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
module Xanthous.Generators.CaveAutomata
|
||||
( Params(..)
|
||||
, defaultParams
|
||||
, parseParams
|
||||
, generate
|
||||
) where
|
||||
|
||||
import Xanthous.Prelude
|
||||
import Control.Monad.Random (RandomGen, runRandT)
|
||||
import Data.Array.ST
|
||||
import Data.Array.Unboxed
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude
|
||||
import Control.Monad.Random (RandomGen, runRandT)
|
||||
import Data.Array.ST
|
||||
import Data.Array.Unboxed
|
||||
import qualified Options.Applicative as Opt
|
||||
|
||||
import Xanthous.Util (between)
|
||||
import Xanthous.Data (Dimensions, width, height)
|
||||
import Xanthous.Generators.Util
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Util (between)
|
||||
import Xanthous.Util.Optparse
|
||||
import Xanthous.Data (Dimensions, width, height)
|
||||
import Xanthous.Generators.Util
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Params = Params
|
||||
{ _aliveStartChance :: Double
|
||||
|
|
@ -70,13 +72,6 @@ parseParams = Params
|
|||
<> Opt.metavar "STEPS"
|
||||
)
|
||||
where
|
||||
readWithGuard predicate errmsg = do
|
||||
res <- Opt.auto
|
||||
unless (predicate res)
|
||||
$ Opt.readerError
|
||||
$ errmsg res
|
||||
pure res
|
||||
|
||||
parseChance = readWithGuard
|
||||
(between 0 1)
|
||||
$ \res -> "Chance must be in the range [0,1], got: " <> show res
|
||||
|
|
@ -85,7 +80,7 @@ parseParams = Params
|
|||
(between 0 8)
|
||||
$ \res -> "Neighbors must be in the range [0,8], got: " <> show res
|
||||
|
||||
generate :: RandomGen g => Params -> Dimensions -> g -> UArray (Word, Word) Bool
|
||||
generate :: RandomGen g => Params -> Dimensions -> g -> Cells
|
||||
generate params dims gen
|
||||
= runSTUArray
|
||||
$ fmap fst
|
||||
|
|
|
|||
192
src/Xanthous/Generators/Dungeon.hs
Normal file
192
src/Xanthous/Generators/Dungeon.hs
Normal file
|
|
@ -0,0 +1,192 @@
|
|||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
--------------------------------------------------------------------------------
|
||||
module Xanthous.Generators.Dungeon
|
||||
( Params(..)
|
||||
, defaultParams
|
||||
, parseParams
|
||||
, generate
|
||||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude hiding ((:>))
|
||||
--------------------------------------------------------------------------------
|
||||
import Control.Monad.Random
|
||||
import Data.Array.ST
|
||||
import Data.Array.IArray (amap)
|
||||
import Data.Stream.Infinite (Stream(..))
|
||||
import qualified Data.Stream.Infinite as Stream
|
||||
import qualified Data.Graph.Inductive.Graph as Graph
|
||||
import Data.Graph.Inductive.PatriciaTree
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.Maybe (fromJust)
|
||||
import Linear.V2
|
||||
import Linear.Metric
|
||||
import qualified Options.Applicative as Opt
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Random
|
||||
import Xanthous.Data hiding (x, y, _x, _y, edges)
|
||||
import Xanthous.Generators.Util
|
||||
import Xanthous.Util.Graphics (delaunay, straightLine)
|
||||
import Xanthous.Util.Graph (mstSubGraph)
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Params = Params
|
||||
{ _numRoomsRange :: (Word, Word)
|
||||
, _roomDimensionRange :: (Word, Word)
|
||||
, _connectednessRatioRange :: (Double, Double)
|
||||
}
|
||||
deriving stock (Show, Eq, Ord, Generic)
|
||||
makeLenses ''Params
|
||||
|
||||
defaultParams :: Params
|
||||
defaultParams = Params
|
||||
{ _numRoomsRange = (6, 8)
|
||||
, _roomDimensionRange = (3, 12)
|
||||
, _connectednessRatioRange = (0.1, 0.15)
|
||||
}
|
||||
|
||||
parseParams :: Opt.Parser Params
|
||||
parseParams = Params
|
||||
<$> parseRange
|
||||
"num-rooms"
|
||||
"number of rooms to generate in the dungeon"
|
||||
"ROOMS"
|
||||
(defaultParams ^. numRoomsRange)
|
||||
<*> parseRange
|
||||
"room-size"
|
||||
"size in tiles of one of the sides of a room"
|
||||
"TILES"
|
||||
(defaultParams ^. roomDimensionRange)
|
||||
<*> parseRange
|
||||
"connectedness-ratio"
|
||||
( "ratio of edges from the delaunay triangulation to re-add to the "
|
||||
<> "minimum-spanning-tree")
|
||||
"RATIO"
|
||||
(defaultParams ^. connectednessRatioRange)
|
||||
<**> Opt.helper
|
||||
where
|
||||
parseRange name desc metavar (defMin, defMax) =
|
||||
(,)
|
||||
<$> Opt.option Opt.auto
|
||||
( Opt.long ("min-" <> name)
|
||||
<> Opt.value defMin
|
||||
<> Opt.showDefault
|
||||
<> Opt.help ("Minimum " <> desc)
|
||||
<> Opt.metavar metavar
|
||||
)
|
||||
<*> Opt.option Opt.auto
|
||||
( Opt.long ("max-" <> name)
|
||||
<> Opt.value defMax
|
||||
<> Opt.showDefault
|
||||
<> Opt.help ("Maximum " <> desc)
|
||||
<> Opt.metavar metavar
|
||||
)
|
||||
|
||||
generate :: RandomGen g => Params -> Dimensions -> g -> Cells
|
||||
generate params dims gen
|
||||
= amap not
|
||||
$ runSTUArray
|
||||
$ fmap fst
|
||||
$ flip runRandT gen
|
||||
$ generate' params dims
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s)
|
||||
generate' params dims = do
|
||||
cells <- initializeEmpty dims
|
||||
rooms <- genRooms params dims
|
||||
for_ rooms $ fillRoom cells
|
||||
|
||||
let fullRoomGraph = delaunayRoomGraph rooms
|
||||
mst = mstSubGraph fullRoomGraph
|
||||
mstEdges = Graph.edges mst
|
||||
nonMSTEdges = filter (\(n₁, n₂, _) -> (n₁, n₂) `notElem` mstEdges)
|
||||
$ Graph.labEdges fullRoomGraph
|
||||
|
||||
reintroEdgeCount <- floor . (* fromIntegral (length nonMSTEdges))
|
||||
<$> getRandomR (params ^. connectednessRatioRange)
|
||||
let reintroEdges = take reintroEdgeCount nonMSTEdges
|
||||
corridorGraph = Graph.insEdges reintroEdges mst
|
||||
|
||||
corridors <- traverse
|
||||
( uncurry corridorBetween
|
||||
. over both (fromJust . Graph.lab corridorGraph)
|
||||
) $ Graph.edges corridorGraph
|
||||
|
||||
for_ (join corridors) $ \pt -> lift $ writeArray cells pt True
|
||||
|
||||
pure cells
|
||||
|
||||
type Room = Box Word
|
||||
|
||||
genRooms :: MonadRandom m => Params -> Dimensions -> m [Room]
|
||||
genRooms params dims = do
|
||||
numRooms <- fromIntegral <$> getRandomR (params ^. numRoomsRange)
|
||||
subRand . fmap (Stream.take numRooms . removeIntersecting []) . infinitely $ do
|
||||
roomWidth <- getRandomR $ params ^. roomDimensionRange
|
||||
roomHeight <- getRandomR $ params ^. roomDimensionRange
|
||||
xPos <- getRandomR (0, dims ^. width - roomWidth)
|
||||
yPos <- getRandomR (0, dims ^. height - roomHeight)
|
||||
pure Box
|
||||
{ _topLeftCorner = V2 xPos yPos
|
||||
, _dimensions = V2 roomWidth roomHeight
|
||||
}
|
||||
where
|
||||
removeIntersecting seen (room :> rooms)
|
||||
| any (boxIntersects room) seen
|
||||
= removeIntersecting seen rooms
|
||||
| otherwise
|
||||
= room :> removeIntersecting (room : seen) rooms
|
||||
streamRepeat x = x :> streamRepeat x
|
||||
infinitely = sequence . streamRepeat
|
||||
|
||||
delaunayRoomGraph :: [Room] -> Gr Room Double
|
||||
delaunayRoomGraph rooms =
|
||||
Graph.insEdges edges . Graph.insNodes nodes $ Graph.empty
|
||||
where
|
||||
edges = map (\((n₁, room₁), (n₂, room₂)) -> (n₁, n₂, roomDist room₁ room₂))
|
||||
. over (mapped . both) snd
|
||||
. delaunay @Double
|
||||
. NE.fromList
|
||||
. map (\p@(_, room) -> (boxCenter $ fromIntegral <$> room, p))
|
||||
$ nodes
|
||||
nodes = zip [0..] rooms
|
||||
roomDist = distance `on` (boxCenter . fmap fromIntegral)
|
||||
|
||||
fillRoom :: MCells s -> Room -> CellM g s ()
|
||||
fillRoom cells room =
|
||||
let V2 posx posy = room ^. topLeftCorner
|
||||
V2 dimx dimy = room ^. dimensions
|
||||
in for_ [posx .. posx + dimx] $ \x ->
|
||||
for_ [posy .. posy + dimy] $ \y ->
|
||||
lift $ writeArray cells (x, y) True
|
||||
|
||||
corridorBetween :: MonadRandom m => Room -> Room -> m [(Word, Word)]
|
||||
corridorBetween originRoom destinationRoom
|
||||
= straightLine <$> origin <*> destination
|
||||
where
|
||||
origin = choose . NE.fromList . map toTuple =<< originEdge
|
||||
destination = choose . NE.fromList . map toTuple =<< destinationEdge
|
||||
originEdge = pickEdge originRoom originCorner
|
||||
destinationEdge = pickEdge destinationRoom destinationCorner
|
||||
pickEdge room corner = choose . over both (boxEdge room) $ cornerEdges corner
|
||||
originCorner =
|
||||
case ( compare (originRoom ^. topLeftCorner . _x)
|
||||
(destinationRoom ^. topLeftCorner . _x)
|
||||
, compare (originRoom ^. topLeftCorner . _y)
|
||||
(destinationRoom ^. topLeftCorner . _y)
|
||||
) of
|
||||
(LT, LT) -> BottomRight
|
||||
(LT, GT) -> TopRight
|
||||
(GT, LT) -> BottomLeft
|
||||
(GT, GT) -> TopLeft
|
||||
|
||||
(EQ, LT) -> BottomLeft
|
||||
(EQ, GT) -> TopRight
|
||||
(GT, EQ) -> TopLeft
|
||||
(LT, EQ) -> BottomRight
|
||||
(EQ, EQ) -> TopLeft -- should never happen
|
||||
|
||||
destinationCorner = opposite originCorner
|
||||
toTuple (V2 x y) = (x, y)
|
||||
|
|
@ -7,6 +7,7 @@ module Xanthous.Generators.Util
|
|||
, Cells
|
||||
, CellM
|
||||
, randInitialize
|
||||
, initializeEmpty
|
||||
, numAliveNeighborsM
|
||||
, numAliveNeighbors
|
||||
, fillOuterEdgesM
|
||||
|
|
@ -39,13 +40,17 @@ type CellM g s a = RandT g (ST s) a
|
|||
|
||||
randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (MCells s)
|
||||
randInitialize dims aliveChance = do
|
||||
res <- lift $ newArray ((0, 0), (dims ^. width, dims ^. height)) False
|
||||
res <- initializeEmpty dims
|
||||
for_ [0..dims ^. width] $ \i ->
|
||||
for_ [0..dims ^. height] $ \j -> do
|
||||
val <- (>= aliveChance) <$> getRandomR (0, 1)
|
||||
lift $ writeArray res (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
|
||||
|
||||
numAliveNeighborsM
|
||||
:: forall a i j m
|
||||
. (MArray a Bool m, Ix (i, j), Integral i, Integral j)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,9 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE UndecidableInstances, PatternSynonyms #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
--------------------------------------------------------------------------------
|
||||
module Xanthous.Orphans
|
||||
|
|
@ -13,21 +15,23 @@ import Xanthous.Prelude hiding (elements, (.=))
|
|||
import Data.Aeson
|
||||
import Data.Aeson.Types (typeMismatch)
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Text.Arbitrary ()
|
||||
import Graphics.Vty.Attributes
|
||||
import Brick.Widgets.Edit
|
||||
import Data.Text.Zipper.Generic (GenericTextZipper)
|
||||
import Brick.Widgets.Core (getName)
|
||||
import System.Random (StdGen)
|
||||
import Test.QuickCheck
|
||||
import "quickcheck-instances" Test.QuickCheck.Instances ()
|
||||
import Text.Megaparsec (errorBundlePretty)
|
||||
import Text.Megaparsec.Pos
|
||||
import Text.Mustache
|
||||
import Text.Mustache.Type ( showKey )
|
||||
import Control.Monad.State
|
||||
import Linear
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Util.JSON
|
||||
import Xanthous.Util.QuickCheck
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
instance forall s a.
|
||||
( Cons s s a a
|
||||
|
|
@ -130,18 +134,6 @@ instance Function Template where
|
|||
parseTemplatePartial txt
|
||||
= compileMustacheText "template" txt ^?! _Right
|
||||
|
||||
instance Arbitrary a => Arbitrary (NonEmpty a) where
|
||||
arbitrary = do
|
||||
x <- arbitrary
|
||||
xs <- arbitrary
|
||||
pure $ x :| xs
|
||||
|
||||
instance CoArbitrary a => CoArbitrary (NonEmpty a) where
|
||||
coarbitrary = coarbitrary . toList
|
||||
|
||||
instance Function a => Function (NonEmpty a) where
|
||||
function = functionMap toList NonEmpty.fromList
|
||||
|
||||
ppNode :: Map PName [Node] -> Node -> Text
|
||||
ppNode _ (TextBlock txt) = txt
|
||||
ppNode _ (EscapedVar k) = "{{" <> showKey k <> "}}"
|
||||
|
|
@ -169,12 +161,6 @@ instance FromJSON Template where
|
|||
$ either (fail . errorBundlePretty) pure
|
||||
. compileMustacheText "template"
|
||||
|
||||
instance CoArbitrary Text where
|
||||
coarbitrary = coarbitrary . unpack
|
||||
|
||||
instance Function Text where
|
||||
function = functionMap unpack pack
|
||||
|
||||
deriving anyclass instance NFData Node
|
||||
deriving anyclass instance NFData Template
|
||||
|
||||
|
|
@ -353,3 +339,8 @@ instance CoArbitrary StdGen where
|
|||
deriving newtype instance (Arbitrary s, CoArbitrary (m (a, s)))
|
||||
=> CoArbitrary (StateT s m a)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
deriving via (GenericArbitrary (V2 a)) instance Arbitrary a => Arbitrary (V2 a)
|
||||
instance CoArbitrary a => CoArbitrary (V2 a)
|
||||
instance Function a => Function (V2 a)
|
||||
|
|
|
|||
|
|
@ -8,17 +8,19 @@ module Xanthous.Random
|
|||
, Weighted(..)
|
||||
, evenlyWeighted
|
||||
, weightedBy
|
||||
, subRand
|
||||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude
|
||||
--------------------------------------------------------------------------------
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom))
|
||||
import Data.Random.Shuffle.Weighted
|
||||
import Data.Random.Distribution
|
||||
import Data.Random.Distribution.Uniform
|
||||
import Data.Random.Distribution.Uniform.Exclusive
|
||||
import Data.Random.Sample
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom))
|
||||
import Control.Monad.Random (Rand, evalRand, mkStdGen, StdGen)
|
||||
import Data.Random.Shuffle.Weighted
|
||||
import Data.Random.Distribution
|
||||
import Data.Random.Distribution.Uniform
|
||||
import Data.Random.Distribution.Uniform.Exclusive
|
||||
import Data.Random.Sample
|
||||
import qualified Data.Random.Source as DRS
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -58,6 +60,10 @@ instance Choose (NonEmpty a) where
|
|||
type RandomResult (NonEmpty a) = a
|
||||
choose = choose . fromNonEmpty @[_]
|
||||
|
||||
instance Choose (a, a) where
|
||||
type RandomResult (a, a) = a
|
||||
choose (x, y) = choose (x :| [y])
|
||||
|
||||
newtype Weighted w t a = Weighted (t (w, a))
|
||||
|
||||
evenlyWeighted :: [a] -> Weighted Int [] a
|
||||
|
|
@ -76,3 +82,6 @@ instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighte
|
|||
sample
|
||||
$ fromMaybe (error "unreachable") . headMay
|
||||
<$> weightedSample 1 (toList ws)
|
||||
|
||||
subRand :: MonadRandom m => Rand StdGen a -> m a
|
||||
subRand sub = evalRand sub . mkStdGen <$> getRandom
|
||||
|
|
|
|||
|
|
@ -29,6 +29,9 @@ module Xanthous.Util
|
|||
, maximum1
|
||||
, minimum1
|
||||
|
||||
-- * Combinators
|
||||
, times, times_
|
||||
|
||||
-- * Type-level programming utils
|
||||
, KnownBool(..)
|
||||
) where
|
||||
|
|
@ -228,6 +231,12 @@ maximum1 = getMax . foldMap1 Max
|
|||
minimum1 :: (Ord a, Foldable1 f) => f a -> a
|
||||
minimum1 = getMin . foldMap1 Min
|
||||
|
||||
times :: (Applicative f, Num n, Enum n) => n -> (n -> f b) -> f [b]
|
||||
times n f = traverse f [1..n]
|
||||
|
||||
times_ :: (Applicative f, Num n, Enum n) => n -> f a -> f [a]
|
||||
times_ n fa = times n (const fa)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | This class gives a boolean associated with a type-level bool, a'la
|
||||
|
|
|
|||
33
src/Xanthous/Util/Graph.hs
Normal file
33
src/Xanthous/Util/Graph.hs
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
--------------------------------------------------------------------------------
|
||||
module Xanthous.Util.Graph where
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude
|
||||
--------------------------------------------------------------------------------
|
||||
import Data.Graph.Inductive.Query.MST (msTree)
|
||||
import qualified Data.Graph.Inductive.Graph as Graph
|
||||
import Data.Graph.Inductive.Graph
|
||||
import Data.Graph.Inductive.Basic (undir)
|
||||
import Data.Set (isSubsetOf)
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
mstSubGraph
|
||||
:: forall gr node edge. (DynGraph gr, Real edge, Show edge)
|
||||
=> gr node edge -> gr node edge
|
||||
mstSubGraph graph = insEdges mstEdges . insNodes (labNodes graph) $ Graph.empty
|
||||
where
|
||||
mstEdges = ordNub $ do
|
||||
LP path <- msTree $ undir graph
|
||||
case path of
|
||||
[] -> []
|
||||
[_] -> []
|
||||
((n₂, edgeWeight) : (n₁, _) : _) ->
|
||||
pure (n₁, n₂, edgeWeight)
|
||||
|
||||
isSubGraphOf
|
||||
:: (Graph gr1, Graph gr2, Ord node, Ord edge)
|
||||
=> gr1 node edge
|
||||
-> gr2 node edge
|
||||
-> Bool
|
||||
isSubGraphOf graph₁ graph₂
|
||||
= setFromList (labNodes graph₁) `isSubsetOf` setFromList (labNodes graph₂)
|
||||
&& setFromList (labEdges graph₁) `isSubsetOf` setFromList (labEdges graph₂)
|
||||
|
|
@ -4,16 +4,26 @@ module Xanthous.Util.Graphics
|
|||
( circle
|
||||
, filledCircle
|
||||
, line
|
||||
, straightLine
|
||||
, delaunay
|
||||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude
|
||||
--------------------------------------------------------------------------------
|
||||
import qualified Algorithms.Geometry.DelaunayTriangulation.DivideAndConquer
|
||||
as Geometry
|
||||
import qualified Algorithms.Geometry.DelaunayTriangulation.Types as Geometry
|
||||
import Codec.Picture (imagePixels)
|
||||
import qualified Data.Geometry.Point as Geometry
|
||||
import Data.Ext ((:+)(..))
|
||||
import Data.List (unfoldr)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Ix (range, Ix)
|
||||
import Data.Word (Word8)
|
||||
import qualified Graphics.Rasterific as Raster
|
||||
import Graphics.Rasterific hiding (circle, line)
|
||||
import Graphics.Rasterific hiding (circle, line, V2(..))
|
||||
import Graphics.Rasterific.Texture (uniformTexture)
|
||||
import Codec.Picture (imagePixels)
|
||||
import Linear.V2
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
||||
|
|
@ -24,7 +34,7 @@ circle :: (Num i, Integral i, Ix i)
|
|||
circle (ox, oy) radius
|
||||
= pointsFromRaster (ox + radius) (oy + radius)
|
||||
$ stroke 1 JoinRound (CapRound, CapRound)
|
||||
$ Raster.circle (V2 (fromIntegral ox) (fromIntegral oy))
|
||||
$ Raster.circle (Raster.V2 (fromIntegral ox) (fromIntegral oy))
|
||||
$ fromIntegral radius
|
||||
|
||||
filledCircle :: (Num i, Integral i, Ix i)
|
||||
|
|
@ -34,7 +44,7 @@ filledCircle :: (Num i, Integral i, Ix i)
|
|||
filledCircle (ox, oy) radius
|
||||
= pointsFromRaster (ox + radius) (oy + radius)
|
||||
$ fill
|
||||
$ Raster.circle (V2 (fromIntegral ox) (fromIntegral oy))
|
||||
$ Raster.circle (Raster.V2 (fromIntegral ox) (fromIntegral oy))
|
||||
$ fromIntegral radius
|
||||
|
||||
-- showCells . fromPoints . NE.fromList $ filledCircle (15, 15) 7
|
||||
|
|
@ -83,3 +93,21 @@ line pa@(xa, ya) pb@(xb, yb)
|
|||
(newY, newError) = if (2 * tempError) >= δx
|
||||
then (yTemp + ystep, tempError - δx)
|
||||
else (yTemp, tempError)
|
||||
|
||||
straightLine :: (Num i, Ord i) => (i, i) -> (i, i) -> [(i, i)]
|
||||
straightLine pa@(xa, _) pb@(_, yb) = line pa midpoint ++ line midpoint pb
|
||||
where midpoint = (xa, yb)
|
||||
|
||||
|
||||
delaunay
|
||||
:: (Ord n, Fractional n)
|
||||
=> NonEmpty (V2 n, p)
|
||||
-> [((V2 n, p), (V2 n, p))]
|
||||
delaunay
|
||||
= map (over both fromPoint)
|
||||
. Geometry.triangulationEdges
|
||||
. Geometry.delaunayTriangulation
|
||||
. map toPoint
|
||||
where
|
||||
toPoint (V2 px py, pid) = Geometry.Point2 px py :+ pid
|
||||
fromPoint (Geometry.Point2 px py :+ pid) = (V2 px py, pid)
|
||||
|
|
|
|||
21
src/Xanthous/Util/Optparse.hs
Normal file
21
src/Xanthous/Util/Optparse.hs
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
--------------------------------------------------------------------------------
|
||||
module Xanthous.Util.Optparse
|
||||
( readWithGuard
|
||||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude
|
||||
--------------------------------------------------------------------------------
|
||||
import qualified Options.Applicative as Opt
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
readWithGuard
|
||||
:: Read b
|
||||
=> (b -> Bool)
|
||||
-> (b -> String)
|
||||
-> Opt.ReadM b
|
||||
readWithGuard predicate errmsg = do
|
||||
res <- Opt.auto
|
||||
unless (predicate res)
|
||||
$ Opt.readerError
|
||||
$ errmsg res
|
||||
pure res
|
||||
Loading…
Add table
Add a link
Reference in a new issue