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

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₂)

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)

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