-- | Operations on the 'Area' type that involve random numbers.
module Game.LambdaHack.Server.DungeonGen.AreaRnd
  ( -- * Picking points inside areas
    mkFixed, pointInArea, findPointInArea, mkVoidRoom, mkRoom
    -- * Choosing connections
  , connectGrid, randomConnection
    -- * Plotting corridors
  , HV(..), Corridor, connectPlaces
  , SpecialArea(..), grid
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , connectGrid', sortPoint, mkCorridor, borderPlace
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import           Data.Functor.Identity (runIdentity)
import qualified Data.IntSet as IS

import Game.LambdaHack.Common.Area
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Content.PlaceKind
import Game.LambdaHack.Core.Random
import Game.LambdaHack.Definition.Defs

-- Doesn't respect minimum sizes, because staircases are specified verbatim,
-- so can't be arbitrarily scaled up.
-- The size may be one more than what maximal size hint requests,
-- but this is safe (limited by area size) and makes up for the rigidity
-- of the fixed room sizes (e.g., that the size is always odd).
mkFixed :: (X, Y)    -- ^ maximum size
        -> Area      -- ^ the containing area, not the room itself
        -> Point     -- ^ the center point
        -> Area
mkFixed :: (X, X) -> Area -> Point -> Area
mkFixed (X
xMax, X
yMax) Area
area p :: Point
p@Point{X
py :: Point -> X
px :: Point -> X
py :: X
px :: X
..} =
  let (X
x0, X
y0, X
x1, X
y1) = Area -> (X, X, X, X)
fromArea Area
area
      xradius :: X
xradius = X -> X -> X
forall a. Ord a => a -> a -> a
min ((X
xMax X -> X -> X
forall a. Num a => a -> a -> a
+ X
1) X -> X -> X
forall a. Integral a => a -> a -> a
`div` X
2) (X -> X) -> X -> X
forall a b. (a -> b) -> a -> b
$ X -> X -> X
forall a. Ord a => a -> a -> a
min (X
px X -> X -> X
forall a. Num a => a -> a -> a
- X
x0) (X
x1 X -> X -> X
forall a. Num a => a -> a -> a
- X
px)
      yradius :: X
yradius = X -> X -> X
forall a. Ord a => a -> a -> a
min ((X
yMax X -> X -> X
forall a. Num a => a -> a -> a
+ X
1) X -> X -> X
forall a. Integral a => a -> a -> a
`div` X
2) (X -> X) -> X -> X
forall a b. (a -> b) -> a -> b
$ X -> X -> X
forall a. Ord a => a -> a -> a
min (X
py X -> X -> X
forall a. Num a => a -> a -> a
- X
y0) (X
y1 X -> X -> X
forall a. Num a => a -> a -> a
- X
py)
      a :: (X, X, X, X)
a = (X
px X -> X -> X
forall a. Num a => a -> a -> a
- X
xradius, X
py X -> X -> X
forall a. Num a => a -> a -> a
- X
yradius, X
px X -> X -> X
forall a. Num a => a -> a -> a
+ X
xradius, X
py X -> X -> X
forall a. Num a => a -> a -> a
+ X
yradius)
  in Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Area
forall a. HasCallStack => [Char] -> a
error ([Char] -> Area) -> [Char] -> Area
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> ((X, X, X, X), X, X, Area, Point) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` ((X, X, X, X)
a, X
xMax, X
yMax, Area
area, Point
p)) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (X, X, X, X) -> Maybe Area
toArea (X, X, X, X)
a

-- | Pick a random point within an area.
pointInArea :: Area -> Rnd Point
pointInArea :: Area -> Rnd Point
pointInArea Area
area = do
  let (Point X
x0 X
y0, X
xspan, X
yspan) = Area -> (Point, X, X)
spanArea Area
area
  X
pxy <- X -> Rnd X
forall a. Integral a => a -> Rnd a
randomR0 (X
xspan X -> X -> X
forall a. Num a => a -> a -> a
* X
yspan X -> X -> X
forall a. Num a => a -> a -> a
- X
1)
  let Point{X
py :: X
px :: X
py :: Point -> X
px :: Point -> X
..} = X -> X -> Point
punindex X
xspan X
pxy
  Point -> Rnd Point
forall (m :: * -> *) a. Monad m => a -> m a
return (Point -> Rnd Point) -> Point -> Rnd Point
forall a b. (a -> b) -> a -> b
$! X -> X -> Point
Point (X
x0 X -> X -> X
forall a. Num a => a -> a -> a
+ X
px) (X
y0 X -> X -> X
forall a. Num a => a -> a -> a
+ X
py)

-- | Find a suitable position in the area, based on random points
-- and a predicate.
findPointInArea :: Area -> (Point -> Maybe Point)
                -> Int -> (Point -> Maybe Point)
                -> Rnd (Maybe Point)
findPointInArea :: Area
-> (Point -> Maybe Point)
-> X
-> (Point -> Maybe Point)
-> Rnd (Maybe Point)
findPointInArea Area
area Point -> Maybe Point
g X
gnumTries Point -> Maybe Point
f =
  let (Point X
x0 X
y0, X
xspan, X
yspan) = Area -> (Point, X, X)
spanArea Area
area
      checkPoint :: Applicative m
                 => (Point -> Maybe Point) -> m (Maybe Point) -> Int
                 -> m (Maybe Point)
      {-# INLINE checkPoint #-}
      checkPoint :: (Point -> Maybe Point) -> m (Maybe Point) -> X -> m (Maybe Point)
checkPoint Point -> Maybe Point
check m (Maybe Point)
fallback X
pxyRelative =
        let Point{X
py :: X
px :: X
py :: Point -> X
px :: Point -> X
..} = X -> X -> Point
punindex X
xspan X
pxyRelative
            pos :: Point
pos = X -> X -> Point
Point (X
x0 X -> X -> X
forall a. Num a => a -> a -> a
+ X
px) (X
y0 X -> X -> X
forall a. Num a => a -> a -> a
+ X
py)
        in case Point -> Maybe Point
check Point
pos of
          Just Point
p -> Maybe Point -> m (Maybe Point)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Point -> m (Maybe Point)) -> Maybe Point -> m (Maybe Point)
forall a b. (a -> b) -> a -> b
$ Point -> Maybe Point
forall a. a -> Maybe a
Just Point
p
          Maybe Point
Nothing -> m (Maybe Point)
fallback
      gsearch :: X -> Rnd (Maybe Point)
gsearch X
0 = X -> Rnd (Maybe Point)
fsearch (X
xspan X -> X -> X
forall a. Num a => a -> a -> a
* X
yspan X -> X -> X
forall a. Num a => a -> a -> a
* X
10)
      gsearch X
count = do
        X
pxy <- X -> Rnd X
forall a. Integral a => a -> Rnd a
randomR0 (X
xspan X -> X -> X
forall a. Num a => a -> a -> a
* X
yspan X -> X -> X
forall a. Num a => a -> a -> a
- X
1)
        (Point -> Maybe Point)
-> Rnd (Maybe Point) -> X -> Rnd (Maybe Point)
forall (m :: * -> *).
Applicative m =>
(Point -> Maybe Point) -> m (Maybe Point) -> X -> m (Maybe Point)
checkPoint Point -> Maybe Point
g (X -> Rnd (Maybe Point)
gsearch (X
count X -> X -> X
forall a. Num a => a -> a -> a
- X
1)) X
pxy
      fsearch :: X -> Rnd (Maybe Point)
fsearch X
0 = Maybe Point -> Rnd (Maybe Point)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Point -> Rnd (Maybe Point))
-> Maybe Point -> Rnd (Maybe Point)
forall a b. (a -> b) -> a -> b
$! Identity (Maybe Point) -> Maybe Point
forall a. Identity a -> a
runIdentity (Identity (Maybe Point) -> Maybe Point)
-> Identity (Maybe Point) -> Maybe Point
forall a b. (a -> b) -> a -> b
$ X -> Identity (Maybe Point)
searchAll (X
xspan X -> X -> X
forall a. Num a => a -> a -> a
* X
yspan X -> X -> X
forall a. Num a => a -> a -> a
- X
1)
      fsearch X
count = do
        X
pxy <- X -> Rnd X
forall a. Integral a => a -> Rnd a
randomR0 (X
xspan X -> X -> X
forall a. Num a => a -> a -> a
* X
yspan X -> X -> X
forall a. Num a => a -> a -> a
- X
1)
        (Point -> Maybe Point)
-> Rnd (Maybe Point) -> X -> Rnd (Maybe Point)
forall (m :: * -> *).
Applicative m =>
(Point -> Maybe Point) -> m (Maybe Point) -> X -> m (Maybe Point)
checkPoint Point -> Maybe Point
f (X -> Rnd (Maybe Point)
fsearch (X
count X -> X -> X
forall a. Num a => a -> a -> a
- X
1)) X
pxy
      searchAll :: X -> Identity (Maybe Point)
searchAll (-1) = Maybe Point -> Identity (Maybe Point)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Point
forall a. Maybe a
Nothing
      searchAll X
pxyRelative =
        (Point -> Maybe Point)
-> Identity (Maybe Point) -> X -> Identity (Maybe Point)
forall (m :: * -> *).
Applicative m =>
(Point -> Maybe Point) -> m (Maybe Point) -> X -> m (Maybe Point)
checkPoint Point -> Maybe Point
f (X -> Identity (Maybe Point)
searchAll (X
pxyRelative X -> X -> X
forall a. Num a => a -> a -> a
- X
1)) X
pxyRelative
  in X -> Rnd (Maybe Point)
gsearch X
gnumTries

-- | Create a void room, i.e., a single point area within the designated area.
mkVoidRoom :: Area -> Rnd Area
mkVoidRoom :: Area -> Rnd Area
mkVoidRoom Area
area = do
  -- Pass corridors closer to the middle of the grid area, if possible.
  let core :: Area
core = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe Area
area (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ Area -> Maybe Area
shrink Area
area
  Point
pxy <- Area -> Rnd Point
pointInArea Area
core
  Area -> Rnd Area
forall (m :: * -> *) a. Monad m => a -> m a
return (Area -> Rnd Area) -> Area -> Rnd Area
forall a b. (a -> b) -> a -> b
$! Point -> Area
trivialArea Point
pxy

-- | Create a random room according to given parameters.
mkRoom :: (X, Y)    -- ^ minimum size
       -> (X, Y)    -- ^ maximum size
       -> Area      -- ^ the containing area, not the room itself
       -> Rnd Area
mkRoom :: (X, X) -> (X, X) -> Area -> Rnd Area
mkRoom (X
xm, X
ym) (X
xM, X
yM) Area
area = do
  let (X
x0, X
y0, X
x1, X
y1) = Area -> (X, X, X, X)
fromArea Area
area
      xspan :: X
xspan = X
x1 X -> X -> X
forall a. Num a => a -> a -> a
- X
x0 X -> X -> X
forall a. Num a => a -> a -> a
+ X
1
      yspan :: X
yspan = X
y1 X -> X -> X
forall a. Num a => a -> a -> a
- X
y0 X -> X -> X
forall a. Num a => a -> a -> a
+ X
1
      aW :: (X, X, X, X)
aW = (X -> X -> X
forall a. Ord a => a -> a -> a
min X
xm X
xspan, X -> X -> X
forall a. Ord a => a -> a -> a
min X
ym X
yspan, X -> X -> X
forall a. Ord a => a -> a -> a
min X
xM X
xspan, X -> X -> X
forall a. Ord a => a -> a -> a
min X
yM X
yspan)
      areaW :: Area
areaW = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Area
forall a. HasCallStack => [Char] -> a
error ([Char] -> Area) -> [Char] -> Area
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> (X, X, X, X) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (X, X, X, X)
aW) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (X, X, X, X) -> Maybe Area
toArea (X, X, X, X)
aW
  Point X
xW X
yW <- Area -> Rnd Point
pointInArea Area
areaW  -- roll size
  let a1 :: (X, X, X, X)
a1 = (X
x0, X
y0, X -> X -> X
forall a. Ord a => a -> a -> a
max X
x0 (X
x1 X -> X -> X
forall a. Num a => a -> a -> a
- X
xW X -> X -> X
forall a. Num a => a -> a -> a
+ X
1), X -> X -> X
forall a. Ord a => a -> a -> a
max X
y0 (X
y1 X -> X -> X
forall a. Num a => a -> a -> a
- X
yW X -> X -> X
forall a. Num a => a -> a -> a
+ X
1))
      area1 :: Area
area1 = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Area
forall a. HasCallStack => [Char] -> a
error ([Char] -> Area) -> [Char] -> Area
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> (X, X, X, X) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (X, X, X, X)
a1) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (X, X, X, X) -> Maybe Area
toArea (X, X, X, X)
a1
  Point X
rx1 X
ry1 <- Area -> Rnd Point
pointInArea Area
area1  -- roll top-left corner
  let a3 :: (X, X, X, X)
a3 = (X
rx1, X
ry1, X
rx1 X -> X -> X
forall a. Num a => a -> a -> a
+ X
xW X -> X -> X
forall a. Num a => a -> a -> a
- X
1, X
ry1 X -> X -> X
forall a. Num a => a -> a -> a
+ X
yW X -> X -> X
forall a. Num a => a -> a -> a
- X
1)
      area3 :: Area
area3 = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Area
forall a. HasCallStack => [Char] -> a
error ([Char] -> Area) -> [Char] -> Area
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> (X, X, X, X) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (X, X, X, X)
a3) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (X, X, X, X) -> Maybe Area
toArea (X, X, X, X)
a3
  Area -> Rnd Area
forall (m :: * -> *) a. Monad m => a -> m a
return (Area -> Rnd Area) -> Area -> Rnd Area
forall a b. (a -> b) -> a -> b
$! Area
area3

-- Choosing connections between areas in a grid

-- | Pick a subset of connections between adjacent areas within a grid until
-- there is only one connected component in the graph of all areas.
connectGrid :: ES.EnumSet Point -> (X, Y) -> Rnd [(Point, Point)]
connectGrid :: EnumSet Point -> (X, X) -> Rnd [(Point, Point)]
connectGrid EnumSet Point
voidPlaces (X
nx, X
ny) = do
  let unconnected :: EnumSet Point
unconnected = [Point] -> EnumSet Point
forall k. Enum k => [k] -> EnumSet k
ES.fromDistinctAscList [ X -> X -> Point
Point X
x X
y
                                           | X
y <- [X
0..X
nyX -> X -> X
forall a. Num a => a -> a -> a
-X
1], X
x <- [X
0..X
nxX -> X -> X
forall a. Num a => a -> a -> a
-X
1] ]
  -- Candidates are neighbours that are still unconnected. We start with
  -- a random choice.
  Point
p <- [Point] -> Rnd Point
forall a. [a] -> Rnd a
oneOf ([Point] -> Rnd Point) -> [Point] -> Rnd Point
forall a b. (a -> b) -> a -> b
$ EnumSet Point -> [Point]
forall k. Enum k => EnumSet k -> [k]
ES.elems (EnumSet Point -> [Point]) -> EnumSet Point -> [Point]
forall a b. (a -> b) -> a -> b
$ EnumSet Point
unconnected EnumSet Point -> EnumSet Point -> EnumSet Point
forall k. EnumSet k -> EnumSet k -> EnumSet k
ES.\\ EnumSet Point
voidPlaces
  let candidates :: EnumSet Point
candidates = Point -> EnumSet Point
forall k. Enum k => k -> EnumSet k
ES.singleton Point
p
  EnumSet Point
-> (X, X)
-> EnumSet Point
-> EnumSet Point
-> [(Point, Point)]
-> Rnd [(Point, Point)]
connectGrid' EnumSet Point
voidPlaces (X
nx, X
ny) EnumSet Point
unconnected EnumSet Point
candidates []

connectGrid' :: ES.EnumSet Point -> (X, Y)
             -> ES.EnumSet Point -> ES.EnumSet Point
             -> [(Point, Point)]
             -> Rnd [(Point, Point)]
connectGrid' :: EnumSet Point
-> (X, X)
-> EnumSet Point
-> EnumSet Point
-> [(Point, Point)]
-> Rnd [(Point, Point)]
connectGrid' EnumSet Point
voidPlaces (X
nx, X
ny) EnumSet Point
unconnected EnumSet Point
candidates ![(Point, Point)]
acc
  | EnumSet Point
unconnected EnumSet Point -> EnumSet Point -> Bool
forall k. EnumSet k -> EnumSet k -> Bool
`ES.isSubsetOf` EnumSet Point
voidPlaces = [(Point, Point)] -> Rnd [(Point, Point)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Point, Point)]
acc
  | Bool
otherwise = do
      let candidatesBest :: EnumSet Point
candidatesBest = EnumSet Point
candidates EnumSet Point -> EnumSet Point -> EnumSet Point
forall k. EnumSet k -> EnumSet k -> EnumSet k
ES.\\ EnumSet Point
voidPlaces
      Point
c <- [Point] -> Rnd Point
forall a. [a] -> Rnd a
oneOf ([Point] -> Rnd Point) -> [Point] -> Rnd Point
forall a b. (a -> b) -> a -> b
$ EnumSet Point -> [Point]
forall k. Enum k => EnumSet k -> [k]
ES.elems (EnumSet Point -> [Point]) -> EnumSet Point -> [Point]
forall a b. (a -> b) -> a -> b
$ if EnumSet Point -> Bool
forall k. EnumSet k -> Bool
ES.null EnumSet Point
candidatesBest
                               then EnumSet Point
candidates
                               else EnumSet Point
candidatesBest
      -- potential new candidates:
      let ns :: EnumSet Point
ns = [Point] -> EnumSet Point
forall k. Enum k => [k] -> EnumSet k
ES.fromList ([Point] -> EnumSet Point) -> [Point] -> EnumSet Point
forall a b. (a -> b) -> a -> b
$ X -> X -> Point -> [Point]
vicinityCardinal X
nx X
ny Point
c
          nu :: EnumSet Point
nu = Point -> EnumSet Point -> EnumSet Point
forall k. Enum k => k -> EnumSet k -> EnumSet k
ES.delete Point
c EnumSet Point
unconnected  -- new unconnected
          -- (new candidates, potential connections):
          (EnumSet Point
nc, EnumSet Point
ds) = (Point -> Bool) -> EnumSet Point -> (EnumSet Point, EnumSet Point)
forall k.
Enum k =>
(k -> Bool) -> EnumSet k -> (EnumSet k, EnumSet k)
ES.partition (Point -> EnumSet Point -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.member` EnumSet Point
nu) EnumSet Point
ns
      [(Point, Point)] -> [(Point, Point)]
new <- if EnumSet Point -> Bool
forall k. EnumSet k -> Bool
ES.null EnumSet Point
ds
             then ([(Point, Point)] -> [(Point, Point)])
-> StateT SMGen Identity ([(Point, Point)] -> [(Point, Point)])
forall (m :: * -> *) a. Monad m => a -> m a
return [(Point, Point)] -> [(Point, Point)]
forall a. a -> a
id
             else do
               Point
d <- [Point] -> Rnd Point
forall a. [a] -> Rnd a
oneOf (EnumSet Point -> [Point]
forall k. Enum k => EnumSet k -> [k]
ES.elems EnumSet Point
ds)
               ([(Point, Point)] -> [(Point, Point)])
-> StateT SMGen Identity ([(Point, Point)] -> [(Point, Point)])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Point, Point) -> (Point, Point)
sortPoint (Point
c, Point
d) (Point, Point) -> [(Point, Point)] -> [(Point, Point)]
forall a. a -> [a] -> [a]
:)
      EnumSet Point
-> (X, X)
-> EnumSet Point
-> EnumSet Point
-> [(Point, Point)]
-> Rnd [(Point, Point)]
connectGrid' EnumSet Point
voidPlaces (X
nx, X
ny) EnumSet Point
nu
        (Point -> EnumSet Point -> EnumSet Point
forall k. Enum k => k -> EnumSet k -> EnumSet k
ES.delete Point
c (EnumSet Point
candidates EnumSet Point -> EnumSet Point -> EnumSet Point
forall k. EnumSet k -> EnumSet k -> EnumSet k
`ES.union` EnumSet Point
nc)) ([(Point, Point)] -> [(Point, Point)]
new [(Point, Point)]
acc)

-- | Sort the sequence of two points, in the derived lexicographic order.
sortPoint :: (Point, Point) -> (Point, Point)
sortPoint :: (Point, Point) -> (Point, Point)
sortPoint (Point
a, Point
b) | Point
a Point -> Point -> Bool
forall a. Ord a => a -> a -> Bool
<= Point
b    = (Point
a, Point
b)
                 | Bool
otherwise = (Point
b, Point
a)

-- | Pick a single random connection between adjacent areas within a grid.
randomConnection :: (X, Y) -> Rnd (Point, Point)
randomConnection :: (X, X) -> Rnd (Point, Point)
randomConnection (X
nx, X
ny) =
  Bool -> Rnd (Point, Point) -> Rnd (Point, Point)
forall a. HasCallStack => Bool -> a -> a
assert (X
nx X -> X -> Bool
forall a. Ord a => a -> a -> Bool
> X
1 Bool -> Bool -> Bool
&& X
ny X -> X -> Bool
forall a. Ord a => a -> a -> Bool
> X
0 Bool -> Bool -> Bool
|| X
nx X -> X -> Bool
forall a. Ord a => a -> a -> Bool
> X
0 Bool -> Bool -> Bool
&& X
ny X -> X -> Bool
forall a. Ord a => a -> a -> Bool
> X
1 Bool -> (X, X) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (X
nx, X
ny)) (Rnd (Point, Point) -> Rnd (Point, Point))
-> Rnd (Point, Point) -> Rnd (Point, Point)
forall a b. (a -> b) -> a -> b
$ do
  Bool
rb <- [Bool] -> Rnd Bool
forall a. [a] -> Rnd a
oneOf [Bool
False, Bool
True]
  if Bool
rb Bool -> Bool -> Bool
&& X
nx X -> X -> Bool
forall a. Ord a => a -> a -> Bool
> X
1
  then do
    X
rx <- X -> Rnd X
forall a. Integral a => a -> Rnd a
randomR0 (X
nx X -> X -> X
forall a. Num a => a -> a -> a
- X
2)
    X
ry <- X -> Rnd X
forall a. Integral a => a -> Rnd a
randomR0 (X
ny X -> X -> X
forall a. Num a => a -> a -> a
- X
1)
    (Point, Point) -> Rnd (Point, Point)
forall (m :: * -> *) a. Monad m => a -> m a
return (X -> X -> Point
Point X
rx X
ry, X -> X -> Point
Point (X
rxX -> X -> X
forall a. Num a => a -> a -> a
+X
1) X
ry)
  else do
    X
rx <- X -> Rnd X
forall a. Integral a => a -> Rnd a
randomR0 (X
nx X -> X -> X
forall a. Num a => a -> a -> a
- X
1)
    X
ry <- X -> Rnd X
forall a. Integral a => a -> Rnd a
randomR0 (X
ny X -> X -> X
forall a. Num a => a -> a -> a
- X
2)
    (Point, Point) -> Rnd (Point, Point)
forall (m :: * -> *) a. Monad m => a -> m a
return (X -> X -> Point
Point X
rx X
ry, X -> X -> Point
Point X
rx (X
ryX -> X -> X
forall a. Num a => a -> a -> a
+X
1))

-- Plotting individual corridors between two areas

-- | The choice of horizontal and vertical orientation.
data HV = Horiz | Vert
  deriving HV -> HV -> Bool
(HV -> HV -> Bool) -> (HV -> HV -> Bool) -> Eq HV
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HV -> HV -> Bool
$c/= :: HV -> HV -> Bool
== :: HV -> HV -> Bool
$c== :: HV -> HV -> Bool
Eq

-- | The coordinates of consecutive fields of a corridor.
type Corridor = (Point, Point, Point, Point)

-- | Create a corridor, either horizontal or vertical, with
-- a possible intermediate part that is in the opposite direction.
-- There might not always exist a good intermediate point
-- if the places are allowed to be close together
-- and then we let the intermediate part degenerate.
mkCorridor :: HV            -- ^ orientation of the starting section
           -> Point         -- ^ starting point
           -> Bool          -- ^ starting is inside @FGround@ or @FFloor@
           -> Point         -- ^ ending point
           -> Bool          -- ^ ending is inside @FGround@ or @FFloor@
           -> Area          -- ^ the area containing the intermediate point
           -> Rnd Corridor  -- ^ straight sections of the corridor
mkCorridor :: HV -> Point -> Bool -> Point -> Bool -> Area -> Rnd Corridor
mkCorridor HV
hv (Point X
x0 X
y0) Bool
p0floor (Point X
x1 X
y1) Bool
p1floor Area
area = do
  Point X
rxRaw X
ryRaw <- Area -> Rnd Point
pointInArea Area
area
  let (X
sx0, X
sy0, X
sx1, X
sy1) = Area -> (X, X, X, X)
fromArea Area
area
      -- Avoid corridors that run along @FGround@ or @FFloor@ fence,
      -- unless not possible.
      rx :: X
rx = if | X
rxRaw X -> X -> Bool
forall a. Eq a => a -> a -> Bool
== X
sx0 X -> X -> X
forall a. Num a => a -> a -> a
+ X
1 Bool -> Bool -> Bool
&& Bool
p0floor -> X
sx0
              | X
rxRaw X -> X -> Bool
forall a. Eq a => a -> a -> Bool
== X
sx1 X -> X -> X
forall a. Num a => a -> a -> a
- X
1 Bool -> Bool -> Bool
&& Bool
p1floor -> X
sx1
              | Bool
otherwise -> X
rxRaw
      ry :: X
ry = if | X
ryRaw X -> X -> Bool
forall a. Eq a => a -> a -> Bool
== X
sy0 X -> X -> X
forall a. Num a => a -> a -> a
+ X
1 Bool -> Bool -> Bool
&& Bool
p0floor -> X
sy0
              | X
ryRaw X -> X -> Bool
forall a. Eq a => a -> a -> Bool
== X
sy1 X -> X -> X
forall a. Num a => a -> a -> a
- X
1 Bool -> Bool -> Bool
&& Bool
p1floor -> X
sy1
              | Bool
otherwise -> X
ryRaw
  Corridor -> Rnd Corridor
forall (m :: * -> *) a. Monad m => a -> m a
return (Corridor -> Rnd Corridor) -> Corridor -> Rnd Corridor
forall a b. (a -> b) -> a -> b
$! case HV
hv of
    HV
Horiz -> (X -> X -> Point
Point X
x0 X
y0, X -> X -> Point
Point X
rx X
y0, X -> X -> Point
Point X
rx X
y1, X -> X -> Point
Point X
x1 X
y1)
    HV
Vert  -> (X -> X -> Point
Point X
x0 X
y0, X -> X -> Point
Point X
x0 X
ry, X -> X -> Point
Point X
x1 X
ry, X -> X -> Point
Point X
x1 X
y1)

-- | Try to connect two interiors of places with a corridor.
-- Choose entrances some steps away from the edges, if the place
-- is big enough. Note that with @pfence == FNone@, the inner area considered
-- is the strict interior of the place, without the outermost tiles.
--
-- The corridor connects (touches) the inner areas and the turning point
-- of the corridor (if any) is outside of the outer areas
-- and inside the grid areas.
connectPlaces :: (Area, Fence, Area) -> (Area, Fence, Area)
              -> Rnd (Maybe Corridor)
connectPlaces :: (Area, Fence, Area) -> (Area, Fence, Area) -> Rnd (Maybe Corridor)
connectPlaces (Area
_, Fence
_, Area
sg) (Area
_, Fence
_, Area
tg) | Area
sg Area -> Area -> Bool
forall a. Eq a => a -> a -> Bool
== Area
tg = Maybe Corridor -> Rnd (Maybe Corridor)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Corridor
forall a. Maybe a
Nothing
connectPlaces s3 :: (Area, Fence, Area)
s3@(Area
sqarea, Fence
spfence, Area
sg) t3 :: (Area, Fence, Area)
t3@(Area
tqarea, Fence
tpfence, Area
tg) = do
  let (Area
sa, Area
so, Bool
stiny) = Area -> Fence -> (Area, Area, Bool)
borderPlace Area
sqarea Fence
spfence
      (Area
ta, Area
to, Bool
ttiny) = Area -> Fence -> (Area, Area, Bool)
borderPlace Area
tqarea Fence
tpfence
      trim :: Area -> Area
trim Area
area =
        let (X
x0, X
y0, X
x1, X
y1) = Area -> (X, X, X, X)
fromArea Area
area
            dx :: X
dx = case (X
x1 X -> X -> X
forall a. Num a => a -> a -> a
- X
x0) X -> X -> X
forall a. Integral a => a -> a -> a
`div` X
2 of
              X
0 -> X
0
              X
1 -> X
1
              X
2 -> X
1
              X
3 -> X
1
              X
_ -> X
3
            dy :: X
dy = case (X
y1 X -> X -> X
forall a. Num a => a -> a -> a
- X
y0) X -> X -> X
forall a. Integral a => a -> a -> a
`div` X
2 of
              X
0 -> X
0
              X
1 -> X
1
              X
2 -> X
1
              X
3 -> X
1
              X
_ -> X
3
        in Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Area
forall a. HasCallStack => [Char] -> a
error ([Char] -> Area) -> [Char] -> Area
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char]
-> (Area, (Area, Fence, Area), (Area, Fence, Area)) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (Area
area, (Area, Fence, Area)
s3, (Area, Fence, Area)
t3))
           (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (X, X, X, X) -> Maybe Area
toArea (X
x0 X -> X -> X
forall a. Num a => a -> a -> a
+ X
dx, X
y0 X -> X -> X
forall a. Num a => a -> a -> a
+ X
dy, X
x1 X -> X -> X
forall a. Num a => a -> a -> a
- X
dx, X
y1 X -> X -> X
forall a. Num a => a -> a -> a
- X
dy)
  Point X
sx X
sy <- Area -> Rnd Point
pointInArea (Area -> Rnd Point) -> Area -> Rnd Point
forall a b. (a -> b) -> a -> b
$ Area -> Area
trim Area
sa
  Point X
tx X
ty <- Area -> Rnd Point
pointInArea (Area -> Rnd Point) -> Area -> Rnd Point
forall a b. (a -> b) -> a -> b
$ Area -> Area
trim Area
ta
  -- If the place (e.g., void place) is slim (at most 2-tile wide, no fence),
  -- overwrite it with corridor. The place may not even be built (e.g., void)
  -- and the overwrite ensures connections through it are not broken.
  let (X
_, X
_, X
sax1Raw, X
say1Raw) = Area -> (X, X, X, X)
fromArea Area
sa  -- inner area
      sslim :: Bool
sslim = Bool
stiny Bool -> Bool -> Bool
&& Fence
spfence Fence -> Fence -> Bool
forall a. Eq a => a -> a -> Bool
== Fence
FNone
      (X
sax1, X
say1) = if Bool
sslim
                     then (X
sax1Raw X -> X -> X
forall a. Num a => a -> a -> a
- X
1, X
say1Raw X -> X -> X
forall a. Num a => a -> a -> a
- X
1)
                     else (X
sax1Raw, X
say1Raw)
      (X
tax0Raw, X
tay0Raw, X
_, X
_) = Area -> (X, X, X, X)
fromArea Area
ta
      tslim :: Bool
tslim = Bool
ttiny Bool -> Bool -> Bool
&& Fence
tpfence Fence -> Fence -> Bool
forall a. Eq a => a -> a -> Bool
== Fence
FNone
      (X
tax0, X
tay0) = if Bool
tslim
                     then (X
tax0Raw X -> X -> X
forall a. Num a => a -> a -> a
+ X
1, X
tay0Raw X -> X -> X
forall a. Num a => a -> a -> a
+ X
1)
                     else (X
tax0Raw, X
tay0Raw)
      (X
_, X
_, X
sox1, X
soy1) = Area -> (X, X, X, X)
fromArea Area
so  -- outer area
      (X
tox0, X
toy0, X
_, X
_) = Area -> (X, X, X, X)
fromArea Area
to
      (X
sgx0, X
sgy0, X
sgx1, X
sgy1) = Area -> (X, X, X, X)
fromArea Area
sg  -- grid area
      (X
tgx0, X
tgy0, X
tgx1, X
tgy1) = Area -> (X, X, X, X)
fromArea Area
tg
      (HV
hv, Area
area, Point
p0, Point
p1)
        | X
sgx1 X -> X -> Bool
forall a. Eq a => a -> a -> Bool
== X
tgx0 =
          let x0 :: X
x0 = if X
sgy0 X -> X -> Bool
forall a. Ord a => a -> a -> Bool
<= X
ty Bool -> Bool -> Bool
&& X
ty X -> X -> Bool
forall a. Ord a => a -> a -> Bool
<= X
sgy1 then X
sox1 X -> X -> X
forall a. Num a => a -> a -> a
+ X
1 else X
sgx1
              x1 :: X
x1 = if X
tgy0 X -> X -> Bool
forall a. Ord a => a -> a -> Bool
<= X
sy Bool -> Bool -> Bool
&& X
sy X -> X -> Bool
forall a. Ord a => a -> a -> Bool
<= X
tgy1 then X
tox0 X -> X -> X
forall a. Num a => a -> a -> a
- X
1 else X
sgx1
          in case (X, X, X, X) -> Maybe Area
toArea (X
x0, X -> X -> X
forall a. Ord a => a -> a -> a
min X
sy X
ty, X
x1, X -> X -> X
forall a. Ord a => a -> a -> a
max X
sy X
ty) of
            Just Area
a -> (HV
Horiz, Area
a, X -> X -> Point
Point (X
sax1 X -> X -> X
forall a. Num a => a -> a -> a
+ X
1) X
sy, X -> X -> Point
Point (X
tax0 X -> X -> X
forall a. Num a => a -> a -> a
- X
1) X
ty)
            Maybe Area
Nothing -> [Char] -> (HV, Area, Point, Point)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (HV, Area, Point, Point))
-> [Char] -> (HV, Area, Point, Point)
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char]
-> (X, X, X, X, (Area, Fence, Area), (Area, Fence, Area)) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (X
sx, X
sy, X
tx, X
ty, (Area, Fence, Area)
s3, (Area, Fence, Area)
t3)
        | Bool
otherwise = Bool -> (HV, Area, Point, Point) -> (HV, Area, Point, Point)
forall a. HasCallStack => Bool -> a -> a
assert (X
sgy1 X -> X -> Bool
forall a. Eq a => a -> a -> Bool
== X
tgy0) ((HV, Area, Point, Point) -> (HV, Area, Point, Point))
-> (HV, Area, Point, Point) -> (HV, Area, Point, Point)
forall a b. (a -> b) -> a -> b
$
          let y0 :: X
y0 = if X
sgx0 X -> X -> Bool
forall a. Ord a => a -> a -> Bool
<= X
tx Bool -> Bool -> Bool
&& X
tx X -> X -> Bool
forall a. Ord a => a -> a -> Bool
<= X
sgx1 then X
soy1 X -> X -> X
forall a. Num a => a -> a -> a
+ X
1 else X
sgy1
              y1 :: X
y1 = if X
tgx0 X -> X -> Bool
forall a. Ord a => a -> a -> Bool
<= X
sx Bool -> Bool -> Bool
&& X
sx X -> X -> Bool
forall a. Ord a => a -> a -> Bool
<= X
tgx1 then X
toy0 X -> X -> X
forall a. Num a => a -> a -> a
- X
1 else X
sgy1
          in case (X, X, X, X) -> Maybe Area
toArea (X -> X -> X
forall a. Ord a => a -> a -> a
min X
sx X
tx, X
y0, X -> X -> X
forall a. Ord a => a -> a -> a
max X
sx X
tx, X
y1) of
            Just Area
a -> (HV
Vert, Area
a, X -> X -> Point
Point X
sx (X
say1 X -> X -> X
forall a. Num a => a -> a -> a
+ X
1), X -> X -> Point
Point X
tx (X
tay0 X -> X -> X
forall a. Num a => a -> a -> a
- X
1))
            Maybe Area
Nothing -> [Char] -> (HV, Area, Point, Point)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (HV, Area, Point, Point))
-> [Char] -> (HV, Area, Point, Point)
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char]
-> (X, X, X, X, (Area, Fence, Area), (Area, Fence, Area)) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (X
sx, X
sy, X
tx, X
ty, (Area, Fence, Area)
s3, (Area, Fence, Area)
t3)
      nin :: Point -> Bool
nin Point
p = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Area -> Point -> Bool
inside Area
sa Point
p Bool -> Bool -> Bool
|| Area -> Point -> Bool
inside Area
ta Point
p
      !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool
sslim Bool -> Bool -> Bool
|| Bool
tslim
                    Bool -> Bool -> Bool
|| (Point -> Bool) -> [Point] -> Bool
forall a. Show a => (a -> Bool) -> [a] -> Bool
allB Point -> Bool
nin [Point
p0, Point
p1] Bool
-> (X, X, X, X, (Area, Fence, Area), (Area, Fence, Area)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (X
sx, X
sy, X
tx, X
ty, (Area, Fence, Area)
s3, (Area, Fence, Area)
t3)) ()
  cor :: Corridor
cor@(Point
c1, Point
c2, Point
c3, Point
c4) <- HV -> Point -> Bool -> Point -> Bool -> Area -> Rnd Corridor
mkCorridor HV
hv Point
p0 (Area
sa Area -> Area -> Bool
forall a. Eq a => a -> a -> Bool
== Area
so) Point
p1 (Area
ta Area -> Area -> Bool
forall a. Eq a => a -> a -> Bool
== Area
to) Area
area
  let !_A2 :: ()
_A2 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool
sslim Bool -> Bool -> Bool
|| Bool
tslim Bool -> Bool -> Bool
|| (Point -> Bool) -> [Point] -> Bool
forall a. Show a => (a -> Bool) -> [a] -> Bool
allB Point -> Bool
nin [Point
c1, Point
c2, Point
c3, Point
c4]
                     Bool
-> (Corridor, X, X, X, X, (Area, Fence, Area), (Area, Fence, Area))
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (Corridor
cor, X
sx, X
sy, X
tx, X
ty, (Area, Fence, Area)
s3, (Area, Fence, Area)
t3)) ()
  Maybe Corridor -> Rnd (Maybe Corridor)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Corridor -> Rnd (Maybe Corridor))
-> Maybe Corridor -> Rnd (Maybe Corridor)
forall a b. (a -> b) -> a -> b
$ Corridor -> Maybe Corridor
forall a. a -> Maybe a
Just Corridor
cor

borderPlace :: Area -> Fence -> (Area, Area, Bool)
borderPlace :: Area -> Fence -> (Area, Area, Bool)
borderPlace Area
qarea Fence
pfence = case Fence
pfence of
  Fence
FWall -> (Area
qarea, Area -> Area
expand Area
qarea, Bool
False)
  Fence
FFloor  -> (Area
qarea, Area
qarea, Bool
False)
  Fence
FGround -> (Area
qarea, Area
qarea, Bool
False)
  Fence
FNone -> case Area -> Maybe Area
shrink Area
qarea of
    Maybe Area
Nothing -> (Area
qarea, Area
qarea, Bool
True)
    Just Area
sr -> (Area
sr, Area
qarea, Bool
False)

data SpecialArea =
    SpecialArea Area
  | SpecialFixed Point (Freqs PlaceKind) Area
  | SpecialMerged SpecialArea Point
  deriving X -> SpecialArea -> ShowS
[SpecialArea] -> ShowS
SpecialArea -> [Char]
(X -> SpecialArea -> ShowS)
-> (SpecialArea -> [Char])
-> ([SpecialArea] -> ShowS)
-> Show SpecialArea
forall a.
(X -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SpecialArea] -> ShowS
$cshowList :: [SpecialArea] -> ShowS
show :: SpecialArea -> [Char]
$cshow :: SpecialArea -> [Char]
showsPrec :: X -> SpecialArea -> ShowS
$cshowsPrec :: X -> SpecialArea -> ShowS
Show

-- | Divide uniformly a larger area into the given number of smaller areas
-- overlapping at the edges.
--
-- The list of fixed centers (some important points inside)
-- of (non-overlapping) areas is given. Incorporate those,
-- with as little disruption, as possible.
-- Assume each of four boundaries of the cave are covered by a fixed centre.
grid :: EM.EnumMap Point (Freqs PlaceKind) -> [Point] -> Area -> (X, Y)
     -> ((X, Y), EM.EnumMap Point SpecialArea)
grid :: EnumMap Point (Freqs PlaceKind)
-> [Point] -> Area -> (X, X) -> ((X, X), EnumMap Point SpecialArea)
grid EnumMap Point (Freqs PlaceKind)
fixedCenters [Point]
boot Area
area (X, X)
cellSize =
  let (X
x0, X
y0, X
x1, X
y1) = Area -> (X, X, X, X)
fromArea Area
area
      f :: X -> X -> X -> X -> [X] -> [(X, X, Maybe X)]
f X
zsize X
z1 X
n X
prev (X
c1 : X
c2 : [X]
rest) =
        let len :: X
len = X
c2 X -> X -> X
forall a. Num a => a -> a -> a
- X
c1
            cn :: X
cn = X
len X -> X -> X
forall a. Num a => a -> a -> a
* X
n X -> X -> X
forall a. Integral a => a -> a -> a
`div` X
zsize
        in -- traceShow ( zsize, z1, n, prev, len, cn
           --           , len `div` max 1 (2 * cn) ) $
           if X
cn X -> X -> Bool
forall a. Ord a => a -> a -> Bool
< X
2
           then let mid1 :: X
mid1 = (X
c1 X -> X -> X
forall a. Num a => a -> a -> a
+ X
c2) X -> X -> X
forall a. Integral a => a -> a -> a
`div` X
2
                    mid2 :: X
mid2 = (X
c1 X -> X -> X
forall a. Num a => a -> a -> a
+ X
c2) X -> X -> X
forall a. Integral a => a -> a -> a
`divUp` X
2
                    mid :: X
mid = if X
mid1 X -> X -> X
forall a. Num a => a -> a -> a
- X
prev X -> X -> Bool
forall a. Ord a => a -> a -> Bool
> X
4 then X
mid1 else X
mid2
                in (X
prev, X
mid, X -> Maybe X
forall a. a -> Maybe a
Just X
c1) (X, X, Maybe X) -> [(X, X, Maybe X)] -> [(X, X, Maybe X)]
forall a. a -> [a] -> [a]
: X -> X -> X -> X -> [X] -> [(X, X, Maybe X)]
f X
zsize X
z1 X
n X
mid (X
c2 X -> [X] -> [X]
forall a. a -> [a] -> [a]
: [X]
rest)
           else (X
prev, X
c1 X -> X -> X
forall a. Num a => a -> a -> a
+ X
len X -> X -> X
forall a. Integral a => a -> a -> a
`div` (X
2 X -> X -> X
forall a. Num a => a -> a -> a
* X
cn), X -> Maybe X
forall a. a -> Maybe a
Just X
c1)
                (X, X, Maybe X) -> [(X, X, Maybe X)] -> [(X, X, Maybe X)]
forall a. a -> [a] -> [a]
: [ ( X
c1 X -> X -> X
forall a. Num a => a -> a -> a
+ X
len X -> X -> X
forall a. Num a => a -> a -> a
* (X
2 X -> X -> X
forall a. Num a => a -> a -> a
* X
z X -> X -> X
forall a. Num a => a -> a -> a
- X
1) X -> X -> X
forall a. Integral a => a -> a -> a
`div` (X
2 X -> X -> X
forall a. Num a => a -> a -> a
* X
cn)
                    , X
c1 X -> X -> X
forall a. Num a => a -> a -> a
+ X
len X -> X -> X
forall a. Num a => a -> a -> a
* (X
2 X -> X -> X
forall a. Num a => a -> a -> a
* X
z X -> X -> X
forall a. Num a => a -> a -> a
+ X
1) X -> X -> X
forall a. Integral a => a -> a -> a
`div` (X
2 X -> X -> X
forall a. Num a => a -> a -> a
* X
cn)
                    , Maybe X
forall a. Maybe a
Nothing )
                  | X
z <- [X
1 .. X
cn X -> X -> X
forall a. Num a => a -> a -> a
- X
1] ]
                [(X, X, Maybe X)] -> [(X, X, Maybe X)] -> [(X, X, Maybe X)]
forall a. [a] -> [a] -> [a]
++ X -> X -> X -> X -> [X] -> [(X, X, Maybe X)]
f X
zsize X
z1 X
n (X
c1 X -> X -> X
forall a. Num a => a -> a -> a
+ X
len X -> X -> X
forall a. Num a => a -> a -> a
* (X
2 X -> X -> X
forall a. Num a => a -> a -> a
* X
cn X -> X -> X
forall a. Num a => a -> a -> a
- X
1) X -> X -> X
forall a. Integral a => a -> a -> a
`div` (X
2 X -> X -> X
forall a. Num a => a -> a -> a
* X
cn))
                     (X
c2 X -> [X] -> [X]
forall a. a -> [a] -> [a]
: [X]
rest)
      f X
_ X
z1 X
_ X
prev [X
c1] = [(X
prev, X
z1, X -> Maybe X
forall a. a -> Maybe a
Just X
c1)]
      f X
_ X
_ X
_ X
_ [] = [Char] -> [(X, X, Maybe X)]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [(X, X, Maybe X)]) -> [Char] -> [(X, X, Maybe X)]
forall a b. (a -> b) -> a -> b
$ [Char]
"empty list of centers" [Char] -> EnumMap Point (Freqs PlaceKind) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` EnumMap Point (Freqs PlaceKind)
fixedCenters
      ([X]
xCenters, [X]
yCenters) = [(X, X)] -> ([X], [X])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(X, X)] -> ([X], [X])) -> [(X, X)] -> ([X], [X])
forall a b. (a -> b) -> a -> b
$ (Point -> (X, X)) -> [Point] -> [(X, X)]
forall a b. (a -> b) -> [a] -> [b]
map (Point -> X
px (Point -> X) -> (Point -> X) -> Point -> (X, X)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Point -> X
py) ([Point] -> [(X, X)]) -> [Point] -> [(X, X)]
forall a b. (a -> b) -> a -> b
$ EnumMap Point (Freqs PlaceKind) -> [Point]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys EnumMap Point (Freqs PlaceKind)
fixedCenters
      xset :: IntSet
xset = [X] -> IntSet
IS.fromList ([X] -> IntSet) -> [X] -> IntSet
forall a b. (a -> b) -> a -> b
$ [X]
xCenters [X] -> [X] -> [X]
forall a. [a] -> [a] -> [a]
++ (Point -> X) -> [Point] -> [X]
forall a b. (a -> b) -> [a] -> [b]
map Point -> X
px [Point]
boot
      yset :: IntSet
yset = [X] -> IntSet
IS.fromList ([X] -> IntSet) -> [X] -> IntSet
forall a b. (a -> b) -> a -> b
$ [X]
yCenters [X] -> [X] -> [X]
forall a. [a] -> [a] -> [a]
++ (Point -> X) -> [Point] -> [X]
forall a b. (a -> b) -> [a] -> [b]
map Point -> X
py [Point]
boot
      xsize :: X
xsize = IntSet -> X
IS.findMax IntSet
xset X -> X -> X
forall a. Num a => a -> a -> a
- IntSet -> X
IS.findMin IntSet
xset
      ysize :: X
ysize = IntSet -> X
IS.findMax IntSet
yset X -> X -> X
forall a. Num a => a -> a -> a
- IntSet -> X
IS.findMin IntSet
yset
      -- This is precisely how the cave will be divided among places,
      -- if there are no fixed centres except at boot coordinates.
      -- In any case, places, except for at boot points and fixed centres,
      -- are guaranteed at least the rolled minimal size of their
      -- enclosing cell (with one shared fence). Fixed centres are guaranteed
      -- a size between the cave cell size and the one implied by their
      -- placement wrt to cave fence and other fixed centers.
      lgrid :: (X, X)
lgrid = ( X
xsize X -> X -> X
forall a. Integral a => a -> a -> a
`div` (X, X) -> X
forall a b. (a, b) -> a
fst (X, X)
cellSize
              , X
ysize X -> X -> X
forall a. Integral a => a -> a -> a
`div` (X, X) -> X
forall a b. (a, b) -> b
snd (X, X)
cellSize )
      xallSegments :: [(X, (X, X, Maybe X))]
xallSegments = [X] -> [(X, X, Maybe X)] -> [(X, (X, X, Maybe X))]
forall a b. [a] -> [b] -> [(a, b)]
zip [X
0..] ([(X, X, Maybe X)] -> [(X, (X, X, Maybe X))])
-> [(X, X, Maybe X)] -> [(X, (X, X, Maybe X))]
forall a b. (a -> b) -> a -> b
$ X -> X -> X -> X -> [X] -> [(X, X, Maybe X)]
f X
xsize X
x1 ((X, X) -> X
forall a b. (a, b) -> a
fst (X, X)
lgrid) X
x0 ([X] -> [(X, X, Maybe X)]) -> [X] -> [(X, X, Maybe X)]
forall a b. (a -> b) -> a -> b
$ IntSet -> [X]
IS.toList IntSet
xset
      yallSegments :: [(X, (X, X, Maybe X))]
yallSegments = [X] -> [(X, X, Maybe X)] -> [(X, (X, X, Maybe X))]
forall a b. [a] -> [b] -> [(a, b)]
zip [X
0..] ([(X, X, Maybe X)] -> [(X, (X, X, Maybe X))])
-> [(X, X, Maybe X)] -> [(X, (X, X, Maybe X))]
forall a b. (a -> b) -> a -> b
$ X -> X -> X -> X -> [X] -> [(X, X, Maybe X)]
f X
ysize X
y1 ((X, X) -> X
forall a b. (a, b) -> b
snd (X, X)
lgrid) X
y0 ([X] -> [(X, X, Maybe X)]) -> [X] -> [(X, X, Maybe X)]
forall a b. (a -> b) -> a -> b
$ IntSet -> [X]
IS.toList IntSet
yset
  in -- traceShow (xallSegments, yallSegments) $
     ( ([(X, (X, X, Maybe X))] -> X
forall a. [a] -> X
length [(X, (X, X, Maybe X))]
xallSegments, [(X, (X, X, Maybe X))] -> X
forall a. [a] -> X
length [(X, (X, X, Maybe X))]
yallSegments)
     , [(Point, SpecialArea)] -> EnumMap Point SpecialArea
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromDistinctAscList
         [ ( X -> X -> Point
Point X
x X
y
           , case (Maybe X
mcx, Maybe X
mcy) of
               (Just X
cx, Just X
cy) ->
                 case Point -> EnumMap Point (Freqs PlaceKind) -> Maybe (Freqs PlaceKind)
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup (X -> X -> Point
Point X
cx X
cy) EnumMap Point (Freqs PlaceKind)
fixedCenters of
                   Maybe (Freqs PlaceKind)
Nothing -> Area -> SpecialArea
SpecialArea Area
sarea
                   Just Freqs PlaceKind
placeFreq -> Point -> Freqs PlaceKind -> Area -> SpecialArea
SpecialFixed (X -> X -> Point
Point X
cx X
cy) Freqs PlaceKind
placeFreq Area
sarea
               (Maybe X, Maybe X)
_ -> Area -> SpecialArea
SpecialArea Area
sarea )
         | (X
y, (X
cy0, X
cy1, Maybe X
mcy)) <- [(X, (X, X, Maybe X))]
yallSegments
         , (X
x, (X
cx0, X
cx1, Maybe X
mcx)) <- [(X, (X, X, Maybe X))]
xallSegments
         , let sarea :: Area
sarea = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Area
forall a. HasCallStack => [Char] -> a
error ([Char] -> Area) -> [Char] -> Area
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> (X, X) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (X
x, X
y))
                       (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (X, X, X, X) -> Maybe Area
toArea (X
cx0, X
cy0, X
cx1, X
cy1) ] )