about summary refs log tree commit diff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Main.hs25
-rw-r--r--src/Xanthous/Data.hs173
-rw-r--r--src/Xanthous/Generators.hs29
-rw-r--r--src/Xanthous/Generators/CaveAutomata.hs31
-rw-r--r--src/Xanthous/Generators/Dungeon.hs192
-rw-r--r--src/Xanthous/Generators/Util.hs7
-rw-r--r--src/Xanthous/Orphans.hs33
-rw-r--r--src/Xanthous/Random.hs23
-rw-r--r--src/Xanthous/Util.hs9
-rw-r--r--src/Xanthous/Util/Graph.hs33
-rw-r--r--src/Xanthous/Util/Graphics.hs36
-rw-r--r--src/Xanthous/Util/Optparse.hs21
12 files changed, 524 insertions, 88 deletions
diff --git a/src/Main.hs b/src/Main.hs
index 2e9d8c41eef2..b11f1b9f4960 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 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]
diff --git a/src/Xanthous/Generators.hs b/src/Xanthous/Generators.hs
index 490e50ea60a8..592bf73c0007 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 e885f4ed1aad..5a7c081d03e9 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 000000000000..fdc510bb79ec
--- /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 2c041149d900..13f248a045d8 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 6a860e1c49f1..b7a4a3212629 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 bbf176f71d6e..3cb0b068d3d7 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 93155af3fd59..524ad4819dac 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 000000000000..8e5c04f4bfa9
--- /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 e8269e72d6c8..bd6a0906a6d5 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 000000000000..dfa65372351d
--- /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
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-11-01T03·46+0000