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

1 files changed, 147 insertions, 26 deletions

diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs
index dfad2cffd392..8a8a62d0ee08 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,12 +65,16 @@ module Xanthous.Data
 
     -- *
   , Direction(..)
-  , opposite
   , move
   , asPosition
   , directionOf
 
     -- *
+  , Corner(..)
+  , Edge(..)
+  , cornerEdges
+
+    -- *
   , Neighbors(..)
   , edges
   , neighborDirections
@@ -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]