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
2019-12-30 11:31:56 -05:00 · 2019-12-30 11:31:56 -05:00 · e76567b9e7
commit e76567b9e7
parent 6f427fe4d6
20 changed files with 680 additions and 103 deletions
--- a/build/hgeometry-fix-haddock.patch
+++ 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
--- 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";
+    };
 }
--- 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
--- 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
  );
--- 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
--- a/src/Xanthous/Data.hs
+++ b/src/Xanthous/Data.hs
@ -8,16 +8,20 @@
 {-# 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,7 +269,7 @@ instance Arbitrary Direction where
  arbitrary = genericArbitrary
  shrink = genericShrink

-opposite :: Direction -> Direction
+instance Opposite Direction where
  opposite Up        = Down
  opposite Down      = Up
  opposite Left      = Right
@ -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]
--- 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 =
--- 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 qualified Options.Applicative as Opt
-
+--------------------------------------------------------------------------------
 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
--- a/src/Xanthous/Generators/Dungeon.hs
+++ 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)
--- 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)
--- 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)
--- a/src/Xanthous/Random.hs
+++ b/src/Xanthous/Random.hs
@ -8,12 +8,14 @@ module Xanthous.Random
  , Weighted(..)
  , evenlyWeighted
  , weightedBy
+  , subRand
  ) where
 --------------------------------------------------------------------------------
 import Xanthous.Prelude
 --------------------------------------------------------------------------------
-import Data.List.NonEmpty (NonEmpty)
+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
@ -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
--- 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
--- a/src/Xanthous/Util/Graph.hs
+++ 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₂)
--- 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)
--- a/src/Xanthous/Util/Optparse.hs
+++ 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
--- 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
  ]
--- 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)
+      ]
+    ]
  ]
--- a/test/Xanthous/Util/GraphSpec.hs
+++ 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
+    ]
+  ]
--- 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