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
13
build/hgeometry-fix-haddock.patch
Normal file
13
build/hgeometry-fix-haddock.patch
Normal file
|
|
@ -0,0 +1,13 @@
|
|||
diff --git a/src/Data/Geometry/PlanarSubdivision/Merge.hs b/src/Data/Geometry/PlanarSubdivision/Merge.hs
|
||||
index 1136114..3f4e7bb 100644
|
||||
--- a/src/Data/Geometry/PlanarSubdivision/Merge.hs
|
||||
+++ b/src/Data/Geometry/PlanarSubdivision/Merge.hs
|
||||
@@ -153,7 +153,7 @@ mergeWith' mergeFaces p1 p2 = PlanarSubdivision cs vd rd rf
|
||||
-- we have to shift the number of the *Arcs*. Since every dart
|
||||
-- consists of two arcs, we have to shift by numDarts / 2
|
||||
-- Furthermore, we take numFaces - 1 since we want the first
|
||||
- -- *internal* face of p2 (the one with FaceId 1) to correspond with the first free
|
||||
+ -- /internal/ face of p2 (the one with FaceId 1) to correspond with the first free
|
||||
-- position (at index numFaces)
|
||||
|
||||
cs = p1^.components <> p2'^.components
|
||||
|
|
@ -1,7 +1,32 @@
|
|||
{ nixpkgs ? import ./nixpkgs.nix {} }:
|
||||
let inherit (nixpkgs) pkgs;
|
||||
in self: super: rec {
|
||||
generic-arbitrary = pkgs.haskell.lib.appendPatch
|
||||
in self: super: with pkgs.haskell.lib; rec {
|
||||
generic-arbitrary = appendPatch
|
||||
super.generic-arbitrary
|
||||
[ ./build/generic-arbitrary-export-garbitrary.patch ];
|
||||
|
||||
hgeometry =
|
||||
appendPatch
|
||||
(self.callHackageDirect {
|
||||
pkg = "hgeometry";
|
||||
ver = "0.9.0.0";
|
||||
sha256 = "02hyvbqm57lr47w90vdgl71cfbd6lvwpqdid9fcnmxkdjbq4kv6b";
|
||||
} {}) [ ./build/hgeometry-fix-haddock.patch ];
|
||||
|
||||
hgeometry-combinatorial =
|
||||
self.callHackageDirect {
|
||||
pkg = "hgeometry-combinatorial";
|
||||
ver = "0.9.0.0";
|
||||
sha256 = "12k41wd9fd1y3jd5djwcpwg2s1cva87wh14i0m1yn49zax9wl740";
|
||||
} {};
|
||||
|
||||
vinyl = pkgs.haskell.lib.overrideSrc
|
||||
(pkgs.haskell.lib.markUnbroken super.vinyl)
|
||||
rec {
|
||||
src = nixpkgs.fetchzip {
|
||||
url = "mirror://hackage/vinyl-${version}/vinyl-${version}.tar.gz";
|
||||
sha256 = "190ffrmm76fh8fi9afkcda2vldf89y7dxj10434h28mbpq55kgsx";
|
||||
};
|
||||
version = "0.12.0";
|
||||
};
|
||||
}
|
||||
|
|
|
|||
|
|
@ -30,14 +30,19 @@ dependencies:
|
|||
- containers
|
||||
- data-default
|
||||
- deepseq
|
||||
- fgl
|
||||
- fgl-arbitrary
|
||||
- file-embed
|
||||
- filepath
|
||||
- generic-arbitrary
|
||||
- generic-monoid
|
||||
- generic-lens
|
||||
- groups
|
||||
- hgeometry
|
||||
- hgeometry-combinatorial
|
||||
- JuicyPixels
|
||||
- lens
|
||||
- linear
|
||||
- megaparsec
|
||||
- MonadRandom
|
||||
- mtl
|
||||
|
|
@ -49,6 +54,7 @@ dependencies:
|
|||
- raw-strings-qq
|
||||
- reflection
|
||||
- Rasterific
|
||||
- streams
|
||||
- stache
|
||||
- semigroupoids
|
||||
- tomland
|
||||
|
|
|
|||
|
|
@ -18,11 +18,7 @@ let
|
|||
overrides = (self: super: {
|
||||
ghc = super.ghc // { withPackages = super.ghc.withHoogle; };
|
||||
ghcWithPackages = self.ghc.withPackages;
|
||||
# eww https://github.com/NixOS/nixpkgs/issues/16394
|
||||
generic-arbitrary = pkgs.haskell.lib.appendPatch
|
||||
super.generic-arbitrary
|
||||
[ ./build/generic-arbitrary-export-garbitrary.patch ];
|
||||
});
|
||||
} // (import ./haskell-overlay.nix { inherit nixpkgs; }) self super);
|
||||
}
|
||||
else packageSet
|
||||
);
|
||||
|
|
|
|||
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
|
||||
|
|
@ -9,6 +9,7 @@ import qualified Xanthous.Generators.UtilSpec
|
|||
import qualified Xanthous.MessageSpec
|
||||
import qualified Xanthous.OrphansSpec
|
||||
import qualified Xanthous.Util.GraphicsSpec
|
||||
import qualified Xanthous.Util.GraphSpec
|
||||
import qualified Xanthous.Util.InflectionSpec
|
||||
import qualified Xanthous.UtilSpec
|
||||
|
||||
|
|
@ -28,5 +29,6 @@ test = testGroup "Xanthous"
|
|||
, Xanthous.DataSpec.test
|
||||
, Xanthous.UtilSpec.test
|
||||
, Xanthous.Util.GraphicsSpec.test
|
||||
, Xanthous.Util.GraphSpec.test
|
||||
, Xanthous.Util.InflectionSpec.test
|
||||
]
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
-- |
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
module Xanthous.DataSpec (main, test) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Test.Prelude hiding (Right, Left, Down)
|
||||
import Xanthous.Data
|
||||
import Data.Group
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain test
|
||||
|
|
@ -35,11 +35,12 @@ test = testGroup "Xanthous.Data"
|
|||
(not . isUnit) (Position @Int 1 13) @? "isUnit $ Position 1 13"
|
||||
]
|
||||
]
|
||||
|
||||
, testGroup "Direction"
|
||||
[ testProperty "opposite is involutive" $ \(dir :: Direction) ->
|
||||
opposite (opposite dir) == dir
|
||||
, testProperty "opposite provides inverse" $ \dir ->
|
||||
invert (asPosition dir) == asPosition (opposite dir)
|
||||
invert (asPosition dir) === asPosition (opposite dir)
|
||||
, testProperty "asPosition isUnit" $ \dir ->
|
||||
dir /= Here ==> isUnit (asPosition dir)
|
||||
, testGroup "Move"
|
||||
|
|
@ -53,4 +54,29 @@ test = testGroup "Xanthous.Data"
|
|||
, testCase "DownRight" $ move DownRight mempty @?= Position 1 1
|
||||
]
|
||||
]
|
||||
|
||||
, testGroup "Corner"
|
||||
[ testGroup "instance Opposite"
|
||||
[ testProperty "involutive" $ \corner ->
|
||||
opposite (opposite corner) === corner
|
||||
]
|
||||
]
|
||||
|
||||
, testGroup "Edge"
|
||||
[ testGroup "instance Opposite"
|
||||
[ testProperty "involutive" $ \edge ->
|
||||
opposite (opposite edge) === edge
|
||||
]
|
||||
]
|
||||
|
||||
, testGroup "Box"
|
||||
[ testGroup "boxIntersects"
|
||||
[ testProperty "True" $ \dims ->
|
||||
boxIntersects (Box @Word (V2 1 1) (V2 2 2))
|
||||
(Box (V2 2 2) dims)
|
||||
, testProperty "False" $ \dims ->
|
||||
not $ boxIntersects (Box @Word (V2 1 1) (V2 2 2))
|
||||
(Box (V2 4 2) dims)
|
||||
]
|
||||
]
|
||||
]
|
||||
|
|
|
|||
39
test/Xanthous/Util/GraphSpec.hs
Normal file
39
test/Xanthous/Util/GraphSpec.hs
Normal file
|
|
@ -0,0 +1,39 @@
|
|||
module Xanthous.Util.GraphSpec (main, test) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Test.Prelude
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Util.Graph
|
||||
import Data.Graph.Inductive.Basic
|
||||
import Data.Graph.Inductive.Graph (labNodes, size, order)
|
||||
import Data.Graph.Inductive.PatriciaTree
|
||||
import Data.Graph.Inductive.Arbitrary
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain test
|
||||
|
||||
test :: TestTree
|
||||
test = testGroup "Xanthous.Util.Graph"
|
||||
[ testGroup "mstSubGraph"
|
||||
[ testProperty "always produces a subgraph"
|
||||
$ \(CG _ (graph :: Gr Int Int)) ->
|
||||
let msg = mstSubGraph $ undir graph
|
||||
in counterexample (show msg)
|
||||
$ msg `isSubGraphOf` undir graph
|
||||
, testProperty "returns a graph with the same nodes"
|
||||
$ \(CG _ (graph :: Gr Int Int)) ->
|
||||
let msg = mstSubGraph graph
|
||||
in counterexample (show msg)
|
||||
$ labNodes msg === labNodes graph
|
||||
, testProperty "has nodes - 1 edges"
|
||||
$ \(CG _ (graph :: Gr Int Int)) ->
|
||||
order graph > 1 ==>
|
||||
let msg = mstSubGraph graph
|
||||
in counterexample (show msg)
|
||||
$ size msg === order graph - 1
|
||||
, testProperty "always produces a simple graph"
|
||||
$ \(CG _ (graph :: Gr Int Int)) ->
|
||||
let msg = mstSubGraph graph
|
||||
in counterexample (show msg) $ isSimple msg
|
||||
]
|
||||
]
|
||||
|
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
|||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 2d93180ab419496ded42f750d00a5b3f6c6994a9af86a8694bb585a1f52919d4
|
||||
-- hash: 497414a98a626a63a6c5022688b33d0021c1580c7c262fbc1152599289df7935
|
||||
|
||||
name: xanthous
|
||||
version: 0.1.0.0
|
||||
|
|
@ -54,6 +54,7 @@ library
|
|||
Xanthous.Game.State
|
||||
Xanthous.Generators
|
||||
Xanthous.Generators.CaveAutomata
|
||||
Xanthous.Generators.Dungeon
|
||||
Xanthous.Generators.LevelContents
|
||||
Xanthous.Generators.Util
|
||||
Xanthous.Messages
|
||||
|
|
@ -63,9 +64,11 @@ library
|
|||
Xanthous.Random
|
||||
Xanthous.Resource
|
||||
Xanthous.Util
|
||||
Xanthous.Util.Graph
|
||||
Xanthous.Util.Graphics
|
||||
Xanthous.Util.Inflection
|
||||
Xanthous.Util.JSON
|
||||
Xanthous.Util.Optparse
|
||||
Xanthous.Util.QuickCheck
|
||||
other-modules:
|
||||
Paths_xanthous
|
||||
|
|
@ -74,8 +77,10 @@ library
|
|||
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
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
MonadRandom
|
||||
JuicyPixels
|
||||
, MonadRandom
|
||||
, QuickCheck
|
||||
, Rasterific
|
||||
, aeson
|
||||
, array
|
||||
, base
|
||||
|
|
@ -87,13 +92,18 @@ library
|
|||
, containers
|
||||
, data-default
|
||||
, deepseq
|
||||
, fgl
|
||||
, fgl-arbitrary
|
||||
, file-embed
|
||||
, filepath
|
||||
, generic-arbitrary
|
||||
, generic-lens
|
||||
, generic-monoid
|
||||
, groups
|
||||
, hgeometry
|
||||
, hgeometry-combinatorial
|
||||
, lens
|
||||
, linear
|
||||
, megaparsec
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
|
|
@ -105,7 +115,9 @@ library
|
|||
, random-source
|
||||
, raw-strings-qq
|
||||
, reflection
|
||||
, semigroupoids
|
||||
, stache
|
||||
, streams
|
||||
, text-zipper
|
||||
, tomland
|
||||
, vector
|
||||
|
|
@ -142,6 +154,7 @@ executable xanthous
|
|||
Xanthous.Game.State
|
||||
Xanthous.Generators
|
||||
Xanthous.Generators.CaveAutomata
|
||||
Xanthous.Generators.Dungeon
|
||||
Xanthous.Generators.LevelContents
|
||||
Xanthous.Generators.Util
|
||||
Xanthous.Messages
|
||||
|
|
@ -151,9 +164,11 @@ executable xanthous
|
|||
Xanthous.Random
|
||||
Xanthous.Resource
|
||||
Xanthous.Util
|
||||
Xanthous.Util.Graph
|
||||
Xanthous.Util.Graphics
|
||||
Xanthous.Util.Inflection
|
||||
Xanthous.Util.JSON
|
||||
Xanthous.Util.Optparse
|
||||
Xanthous.Util.QuickCheck
|
||||
Paths_xanthous
|
||||
hs-source-dirs:
|
||||
|
|
@ -161,8 +176,10 @@ executable xanthous
|
|||
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
|
||||
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2
|
||||
build-depends:
|
||||
MonadRandom
|
||||
JuicyPixels
|
||||
, MonadRandom
|
||||
, QuickCheck
|
||||
, Rasterific
|
||||
, aeson
|
||||
, array
|
||||
, base
|
||||
|
|
@ -174,13 +191,18 @@ executable xanthous
|
|||
, containers
|
||||
, data-default
|
||||
, deepseq
|
||||
, fgl
|
||||
, fgl-arbitrary
|
||||
, file-embed
|
||||
, filepath
|
||||
, generic-arbitrary
|
||||
, generic-lens
|
||||
, generic-monoid
|
||||
, groups
|
||||
, hgeometry
|
||||
, hgeometry-combinatorial
|
||||
, lens
|
||||
, linear
|
||||
, megaparsec
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
|
|
@ -192,7 +214,9 @@ executable xanthous
|
|||
, random-source
|
||||
, raw-strings-qq
|
||||
, reflection
|
||||
, semigroupoids
|
||||
, stache
|
||||
, streams
|
||||
, text-zipper
|
||||
, tomland
|
||||
, vector
|
||||
|
|
@ -217,6 +241,7 @@ test-suite test
|
|||
Xanthous.MessageSpec
|
||||
Xanthous.OrphansSpec
|
||||
Xanthous.Util.GraphicsSpec
|
||||
Xanthous.Util.GraphSpec
|
||||
Xanthous.Util.InflectionSpec
|
||||
Xanthous.UtilSpec
|
||||
Paths_xanthous
|
||||
|
|
@ -225,8 +250,10 @@ test-suite test
|
|||
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
|
||||
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O0
|
||||
build-depends:
|
||||
MonadRandom
|
||||
JuicyPixels
|
||||
, MonadRandom
|
||||
, QuickCheck
|
||||
, Rasterific
|
||||
, aeson
|
||||
, array
|
||||
, base
|
||||
|
|
@ -238,14 +265,19 @@ test-suite test
|
|||
, containers
|
||||
, data-default
|
||||
, deepseq
|
||||
, fgl
|
||||
, fgl-arbitrary
|
||||
, file-embed
|
||||
, filepath
|
||||
, generic-arbitrary
|
||||
, generic-lens
|
||||
, generic-monoid
|
||||
, groups
|
||||
, hgeometry
|
||||
, hgeometry-combinatorial
|
||||
, lens
|
||||
, lens-properties
|
||||
, linear
|
||||
, megaparsec
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
|
|
@ -257,7 +289,9 @@ test-suite test
|
|||
, random-source
|
||||
, raw-strings-qq
|
||||
, reflection
|
||||
, semigroupoids
|
||||
, stache
|
||||
, streams
|
||||
, tasty
|
||||
, tasty-hunit
|
||||
, tasty-quickcheck
|
||||
|
|
|
|||
Loading…
Reference in a new issue