From e76567b9e776070812838828d8de8220c2a461e7 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Mon, 30 Dec 2019 11:31:56 -0500 Subject: [PATCH] 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 --- build/hgeometry-fix-haddock.patch | 13 ++ haskell-overlay.nix | 29 +++- package.yaml | 6 + shell.nix | 6 +- src/Main.hs | 25 ++- src/Xanthous/Data.hs | 173 +++++++++++++++++---- src/Xanthous/Generators.hs | 29 +++- src/Xanthous/Generators/CaveAutomata.hs | 31 ++-- src/Xanthous/Generators/Dungeon.hs | 192 ++++++++++++++++++++++++ src/Xanthous/Generators/Util.hs | 7 +- src/Xanthous/Orphans.hs | 33 ++-- src/Xanthous/Random.hs | 23 ++- src/Xanthous/Util.hs | 9 ++ src/Xanthous/Util/Graph.hs | 33 ++++ src/Xanthous/Util/Graphics.hs | 36 ++++- src/Xanthous/Util/Optparse.hs | 21 +++ test/Spec.hs | 2 + test/Xanthous/DataSpec.hs | 34 ++++- test/Xanthous/Util/GraphSpec.hs | 39 +++++ xanthous.cabal | 42 +++++- 20 files changed, 680 insertions(+), 103 deletions(-) create mode 100644 build/hgeometry-fix-haddock.patch create mode 100644 src/Xanthous/Generators/Dungeon.hs create mode 100644 src/Xanthous/Util/Graph.hs create mode 100644 src/Xanthous/Util/Optparse.hs create mode 100644 test/Xanthous/Util/GraphSpec.hs diff --git a/build/hgeometry-fix-haddock.patch b/build/hgeometry-fix-haddock.patch new file mode 100644 index 000000000..748c65b3e --- /dev/null +++ b/build/hgeometry-fix-haddock.patch @@ -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 diff --git a/haskell-overlay.nix b/haskell-overlay.nix index 959f63c5a..d3775316a 100644 --- a/haskell-overlay.nix +++ b/haskell-overlay.nix @@ -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"; + }; } diff --git a/package.yaml b/package.yaml index 72eb0d32a..32a402f3f 100644 --- a/package.yaml +++ b/package.yaml @@ -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 diff --git a/shell.nix b/shell.nix index 915e3e748..edd2fe4c0 100644 --- a/shell.nix +++ b/shell.nix @@ -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 ); diff --git a/src/Main.hs b/src/Main.hs index 2e9d8c41e..b11f1b9f4 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs index dfad2cffd..8a8a62d0e 100644 --- a/src/Xanthous/Data.hs +++ b/src/Xanthous/Data.hs @@ -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] diff --git a/src/Xanthous/Generators.hs b/src/Xanthous/Generators.hs index 490e50ea6..592bf73c0 100644 --- a/src/Xanthous/Generators.hs +++ b/src/Xanthous/Generators.hs @@ -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 = diff --git a/src/Xanthous/Generators/CaveAutomata.hs b/src/Xanthous/Generators/CaveAutomata.hs index e885f4ed1..5a7c081d0 100644 --- a/src/Xanthous/Generators/CaveAutomata.hs +++ b/src/Xanthous/Generators/CaveAutomata.hs @@ -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 diff --git a/src/Xanthous/Generators/Dungeon.hs b/src/Xanthous/Generators/Dungeon.hs new file mode 100644 index 000000000..fdc510bb7 --- /dev/null +++ b/src/Xanthous/Generators/Dungeon.hs @@ -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) diff --git a/src/Xanthous/Generators/Util.hs b/src/Xanthous/Generators/Util.hs index 2c041149d..13f248a04 100644 --- a/src/Xanthous/Generators/Util.hs +++ b/src/Xanthous/Generators/Util.hs @@ -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) diff --git a/src/Xanthous/Orphans.hs b/src/Xanthous/Orphans.hs index 6a860e1c4..b7a4a3212 100644 --- a/src/Xanthous/Orphans.hs +++ b/src/Xanthous/Orphans.hs @@ -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) diff --git a/src/Xanthous/Random.hs b/src/Xanthous/Random.hs index bbf176f71..3cb0b068d 100644 --- a/src/Xanthous/Random.hs +++ b/src/Xanthous/Random.hs @@ -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 diff --git a/src/Xanthous/Util.hs b/src/Xanthous/Util.hs index 93155af3f..524ad4819 100644 --- a/src/Xanthous/Util.hs +++ b/src/Xanthous/Util.hs @@ -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 diff --git a/src/Xanthous/Util/Graph.hs b/src/Xanthous/Util/Graph.hs new file mode 100644 index 000000000..8e5c04f4b --- /dev/null +++ b/src/Xanthous/Util/Graph.hs @@ -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₂) diff --git a/src/Xanthous/Util/Graphics.hs b/src/Xanthous/Util/Graphics.hs index e8269e72d..bd6a0906a 100644 --- a/src/Xanthous/Util/Graphics.hs +++ b/src/Xanthous/Util/Graphics.hs @@ -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) diff --git a/src/Xanthous/Util/Optparse.hs b/src/Xanthous/Util/Optparse.hs new file mode 100644 index 000000000..dfa653723 --- /dev/null +++ b/src/Xanthous/Util/Optparse.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs index 73b965bdb..8141b83e9 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 ] diff --git a/test/Xanthous/DataSpec.hs b/test/Xanthous/DataSpec.hs index 6fad88681..bd02c0f36 100644 --- a/test/Xanthous/DataSpec.hs +++ b/test/Xanthous/DataSpec.hs @@ -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) + ] + ] ] diff --git a/test/Xanthous/Util/GraphSpec.hs b/test/Xanthous/Util/GraphSpec.hs new file mode 100644 index 000000000..35ff090b2 --- /dev/null +++ b/test/Xanthous/Util/GraphSpec.hs @@ -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 + ] + ] diff --git a/xanthous.cabal b/xanthous.cabal index 5f1abdbc8..23044d7fc 100644 --- a/xanthous.cabal +++ b/xanthous.cabal @@ -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