-- | 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 :: (Key, Key) -> Area -> Point -> Area
mkFixed (Key
xMax, Key
yMax) Area
area p :: Point
p@Point{Key
px :: Key
py :: Key
py :: Point -> Key
px :: Point -> Key
..} =
  let (Key
x0, Key
y0, Key
x1, Key
y1) = Area -> (Key, Key, Key, Key)
fromArea Area
area
      xradius :: Key
xradius = Key -> Key -> Key
forall a. Ord a => a -> a -> a
min ((Key
xMax Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` Key
2) (Key -> Key) -> Key -> Key
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Key
forall a. Ord a => a -> a -> a
min (Key
px Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
x0) (Key
x1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
px)
      yradius :: Key
yradius = Key -> Key -> Key
forall a. Ord a => a -> a -> a
min ((Key
yMax Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` Key
2) (Key -> Key) -> Key -> Key
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Key
forall a. Ord a => a -> a -> a
min (Key
py Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
y0) (Key
y1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
py)
      a :: (Key, Key, Key, Key)
a = (Key
px Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
xradius, Key
py Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
yradius, Key
px Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
xradius, Key
py Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
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] -> ((Key, Key, Key, Key), Key, Key, Area, Point) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` ((Key, Key, Key, Key)
a, Key
xMax, Key
yMax, Area
area, Point
p)) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (Key, Key, Key, Key) -> Maybe Area
toArea (Key, Key, Key, Key)
a

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

-- | Find a suitable position in the area, based on random points
-- and a preference predicate and fallback acceptability predicate.
findPointInArea :: Area -> (Point -> Maybe Point)
                -> Int -> (Point -> Maybe Point)
                -> Rnd (Maybe Point)
findPointInArea :: Area
-> (Point -> Maybe Point)
-> Key
-> (Point -> Maybe Point)
-> Rnd (Maybe Point)
findPointInArea Area
area Point -> Maybe Point
g Key
gnumTries Point -> Maybe Point
f =
  let (Point Key
x0 Key
y0, Key
xspan, Key
yspan) = Area -> (Point, Key, Key)
spanArea Area
area
      checkPoint :: Applicative m
                 => (Point -> Maybe Point) -> m (Maybe Point) -> Int
                 -> m (Maybe Point)
      {-# INLINE checkPoint #-}
      checkPoint :: forall (m :: * -> *).
Applicative m =>
(Point -> Maybe Point) -> m (Maybe Point) -> Key -> m (Maybe Point)
checkPoint Point -> Maybe Point
check m (Maybe Point)
fallback Key
pxyRelative =
        let Point{Key
py :: Point -> Key
px :: Point -> Key
px :: Key
py :: Key
..} = Key -> Key -> Point
punindex Key
xspan Key
pxyRelative
            pos :: Point
pos = Key -> Key -> Point
Point (Key
x0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
px) (Key
y0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
py)
        in case Point -> Maybe Point
check Point
pos of
          Just Point
p -> Maybe Point -> m (Maybe Point)
forall a. a -> m a
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 :: Key -> Rnd (Maybe Point)
gsearch Key
0 = Key -> Rnd (Maybe Point)
fsearch (Key
xspan Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
yspan Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
10)
      gsearch Key
count = do
        pxy <- Key -> Rnd Key
forall a. Integral a => a -> Rnd a
randomR0 (Key
xspan Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
yspan Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)
        checkPoint g (gsearch (count - 1)) pxy
      fsearch :: Key -> Rnd (Maybe Point)
fsearch Key
0 = Maybe Point -> Rnd (Maybe Point)
forall a. a -> StateT SMGen Identity a
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
$ Key -> Identity (Maybe Point)
searchAll (Key
xspan Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
yspan Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)
      fsearch Key
count = do
        pxy <- Key -> Rnd Key
forall a. Integral a => a -> Rnd a
randomR0 (Key
xspan Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
yspan Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)
        checkPoint f (fsearch (count - 1)) pxy
      searchAll :: Key -> Identity (Maybe Point)
searchAll (-1) = Maybe Point -> Identity (Maybe Point)
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Point
forall a. Maybe a
Nothing
      searchAll Key
pxyRelative =
        (Point -> Maybe Point)
-> Identity (Maybe Point) -> Key -> Identity (Maybe Point)
forall (m :: * -> *).
Applicative m =>
(Point -> Maybe Point) -> m (Maybe Point) -> Key -> m (Maybe Point)
checkPoint Point -> Maybe Point
f (Key -> Identity (Maybe Point)
searchAll (Key
pxyRelative Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)) Key
pxyRelative
  in Key -> Rnd (Maybe Point)
gsearch Key
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
  pxy <- Area -> Rnd Point
pointInArea Area
core
  return $! trivialArea 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 :: (Key, Key) -> (Key, Key) -> Area -> Rnd Area
mkRoom (Key
xm, Key
ym) (Key
xM, Key
yM) Area
area = do
  let (Key
x0, Key
y0, Key
x1, Key
y1) = Area -> (Key, Key, Key, Key)
fromArea Area
area
      xspan :: Key
xspan = Key
x1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
x0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1
      yspan :: Key
yspan = Key
y1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
y0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1
      aW :: (Key, Key, Key, Key)
aW = (Key -> Key -> Key
forall a. Ord a => a -> a -> a
min Key
xm Key
xspan, Key -> Key -> Key
forall a. Ord a => a -> a -> a
min Key
ym Key
yspan, Key -> Key -> Key
forall a. Ord a => a -> a -> a
min Key
xM Key
xspan, Key -> Key -> Key
forall a. Ord a => a -> a -> a
min Key
yM Key
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] -> (Key, Key, Key, Key) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (Key, Key, Key, Key)
aW) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (Key, Key, Key, Key) -> Maybe Area
toArea (Key, Key, Key, Key)
aW
  Point xW yW <- Area -> Rnd Point
pointInArea Area
areaW  -- roll size
  let a1 = (Key
x0, Key
y0, Key -> Key -> Key
forall a. Ord a => a -> a -> a
max Key
x0 (Key
x1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
xW Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1), Key -> Key -> Key
forall a. Ord a => a -> a -> a
max Key
y0 (Key
y1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
yW Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1))
      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] -> (Key, Key, Key, Key) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (Key, Key, Key, Key)
a1) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (Key, Key, Key, Key) -> Maybe Area
toArea (Key, Key, Key, Key)
a1
  Point rx1 ry1 <- pointInArea area1  -- roll top-left corner
  let a3 = (Key
rx1, Key
ry1, Key
rx1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
xW Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1, Key
ry1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
yW Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)
      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] -> (Key, Key, Key, Key) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (Key, Key, Key, Key)
a3) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (Key, Key, Key, Key) -> Maybe Area
toArea (Key, Key, Key, Key)
a3
  return $! 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 -> (Key, Key) -> Rnd [(Point, Point)]
connectGrid EnumSet Point
voidPlaces (Key
nx, Key
ny) = do
  let unconnected :: EnumSet Point
unconnected = [Point] -> EnumSet Point
forall k. Enum k => [k] -> EnumSet k
ES.fromDistinctAscList [ Key -> Key -> Point
Point Key
x Key
y
                                           | Key
y <- [Key
0..Key
nyKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
1], Key
x <- [Key
0..Key
nxKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
1] ]
  -- Candidates are neighbours that are still unconnected. We start with
  -- a random choice.
  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 = Point -> EnumSet Point
forall k. Enum k => k -> EnumSet k
ES.singleton Point
p
  connectGrid' voidPlaces (nx, ny) unconnected candidates []

connectGrid' :: ES.EnumSet Point -> (X, Y)
             -> ES.EnumSet Point -> ES.EnumSet Point
             -> [(Point, Point)]
             -> Rnd [(Point, Point)]
connectGrid' :: EnumSet Point
-> (Key, Key)
-> EnumSet Point
-> EnumSet Point
-> [(Point, Point)]
-> Rnd [(Point, Point)]
connectGrid' EnumSet Point
voidPlaces (Key
nx, Key
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 a. a -> StateT SMGen Identity a
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
      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 = [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
$ Key -> Key -> Point -> [Point]
vicinityCardinal Key
nx Key
ny Point
c
          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):
          (nc, ds) = ES.partition (`ES.member` nu) ns
      new <- if ES.null ds
             then return id
             else do
               d <- oneOf (ES.elems ds)
               return (sortPoint (c, d) :)
      connectGrid' voidPlaces (nx, ny) nu
        (ES.delete c (candidates `ES.union` nc)) (new 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 :: (Key, Key) -> Rnd (Point, Point)
randomConnection (Key
nx, Key
ny) =
  Bool -> Rnd (Point, Point) -> Rnd (Point, Point)
forall a. HasCallStack => Bool -> a -> a
assert (Key
nx Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
1 Bool -> Bool -> Bool
&& Key
ny Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
0 Bool -> Bool -> Bool
|| Key
nx Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
0 Bool -> Bool -> Bool
&& Key
ny Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
1 Bool -> (Key, Key) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` (Key
nx, Key
ny)) (Rnd (Point, Point) -> Rnd (Point, Point))
-> Rnd (Point, Point) -> Rnd (Point, Point)
forall a b. (a -> b) -> a -> b
$ do
  rb <- [Bool] -> Rnd Bool
forall a. [a] -> Rnd a
oneOf [Bool
False, Bool
True]
  if rb && nx > 1 || ny <= 1
  then do
    rx <- randomR0 (nx - 2)
    ry <- randomR0 (ny - 1)
    return (Point rx ry, Point (rx+1) ry)
  else do
    rx <- randomR0 (nx - 1)
    ry <- randomR0 (ny - 2)
    return (Point rx ry, Point rx (ry+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
$c== :: HV -> HV -> Bool
== :: HV -> HV -> Bool
$c/= :: HV -> HV -> Bool
/= :: 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 Key
x0 Key
y0) Bool
p0floor (Point Key
x1 Key
y1) Bool
p1floor Area
area = do
  Point rxRaw ryRaw <- Area -> Rnd Point
pointInArea Area
area
  let (sx0, sy0, sx1, sy1) = fromArea area
      -- Avoid corridors that run along @FGround@ or @FFloor@ fence,
      -- unless not possible.
      rx = if | Key
rxRaw Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
sx0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1 Bool -> Bool -> Bool
&& Bool
p0floor -> Key
sx0
              | Key
rxRaw Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
sx1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1 Bool -> Bool -> Bool
&& Bool
p1floor -> Key
sx1
              | Bool
otherwise -> Key
rxRaw
      ry = if | Key
ryRaw Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
sy0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1 Bool -> Bool -> Bool
&& Bool
p0floor -> Key
sy0
              | Key
ryRaw Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
sy1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1 Bool -> Bool -> Bool
&& Bool
p1floor -> Key
sy1
              | Bool
otherwise -> Key
ryRaw
  return $! case hv of
    HV
Horiz -> (Key -> Key -> Point
Point Key
x0 Key
y0, Key -> Key -> Point
Point Key
rx Key
y0, Key -> Key -> Point
Point Key
rx Key
y1, Key -> Key -> Point
Point Key
x1 Key
y1)
    HV
Vert  -> (Key -> Key -> Point
Point Key
x0 Key
y0, Key -> Key -> Point
Point Key
x0 Key
ry, Key -> Key -> Point
Point Key
x1 Key
ry, Key -> Key -> Point
Point Key
x1 Key
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 a. a -> StateT SMGen Identity a
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 (Key
x0, Key
y0, Key
x1, Key
y1) = Area -> (Key, Key, Key, Key)
fromArea Area
area
            dx :: Key
dx = case (Key
x1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
x0) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` Key
2 of
              Key
0 -> Key
0
              Key
1 -> Key
1
              Key
2 -> Key
1
              Key
3 -> Key
1
              Key
_ -> Key
3
            dy :: Key
dy = case (Key
y1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
y0) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` Key
2 of
              Key
0 -> Key
0
              Key
1 -> Key
1
              Key
2 -> Key
1
              Key
3 -> Key
1
              Key
_ -> Key
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
$ (Key, Key, Key, Key) -> Maybe Area
toArea (Key
x0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
dx, Key
y0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
dy, Key
x1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
dx, Key
y1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
dy)
  Point sx sy <- Area -> Rnd Point
pointInArea (Area -> Rnd Point) -> Area -> Rnd Point
forall a b. (a -> b) -> a -> b
$ Area -> Area
trim Area
sa
  Point tx ty <- pointInArea $ trim 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 (_, _, sax1Raw, say1Raw) = fromArea sa  -- inner area
      sslim = Bool
stiny Bool -> Bool -> Bool
&& Fence
spfence Fence -> Fence -> Bool
forall a. Eq a => a -> a -> Bool
== Fence
FNone
      (sax1, say1) = if sslim
                     then (sax1Raw - 1, say1Raw - 1)
                     else (sax1Raw, say1Raw)
      (tax0Raw, tay0Raw, _, _) = fromArea ta
      tslim = Bool
ttiny Bool -> Bool -> Bool
&& Fence
tpfence Fence -> Fence -> Bool
forall a. Eq a => a -> a -> Bool
== Fence
FNone
      (tax0, tay0) = if tslim
                     then (tax0Raw + 1, tay0Raw + 1)
                     else (tax0Raw, tay0Raw)
      (_, _, sox1, soy1) = fromArea so  -- outer area
      (tox0, toy0, _, _) = fromArea to
      (sgx0, sgy0, sgx1, sgy1) = fromArea sg  -- grid area
      (tgx0, tgy0, tgx1, tgy1) = fromArea tg
      (hv, area, p0, p1)
        | sgx1 == tgx0 =
          let x0 = if Key
sgy0 Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
ty Bool -> Bool -> Bool
&& Key
ty Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
sgy1 then Key
sox1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1 else Key
sgx1
              x1 = if Key
tgy0 Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
sy Bool -> Bool -> Bool
&& Key
sy Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
tgy1 then Key
tox0 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1 else Key
sgx1
          in case toArea (x0, min sy ty, x1, max sy ty) of
            Just Area
a -> (HV
Horiz, Area
a, Key -> Key -> Point
Point (Key
sax1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) Key
sy, Key -> Key -> Point
Point (Key
tax0 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1) Key
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]
-> (Key, Key, Key, Key, (Area, Fence, Area), (Area, Fence, Area))
-> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (Key
sx, Key
sy, Key
tx, Key
ty, (Area, Fence, Area)
s3, (Area, Fence, Area)
t3)
        | otherwise = assert (sgy1 == tgy0) $
          let y0 = if Key
sgx0 Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
tx Bool -> Bool -> Bool
&& Key
tx Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
sgx1 then Key
soy1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1 else Key
sgy1
              y1 = if Key
tgx0 Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
sx Bool -> Bool -> Bool
&& Key
sx Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
<= Key
tgx1 then Key
toy0 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1 else Key
sgy1
          in case toArea (min sx tx, y0, max sx tx, y1) of
            Just Area
a -> (HV
Vert, Area
a, Key -> Key -> Point
Point Key
sx (Key
say1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1), Key -> Key -> Point
Point Key
tx (Key
tay0 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
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]
-> (Key, Key, Key, Key, (Area, Fence, Area), (Area, Fence, Area))
-> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (Key
sx, Key
sy, Key
tx, Key
ty, (Area, Fence, Area)
s3, (Area, Fence, Area)
t3)
      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 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool
sslim Bool -> Bool -> Bool
|| Bool
tslim
                    Bool -> Bool -> Bool
|| (Point -> Bool) -> [Point] -> Bool
forall v. Show v => (v -> Bool) -> [v] -> Bool
allB Point -> Bool
nin [Point
p0, Point
p1] Bool
-> (Key, Key, Key, Key, (Area, Fence, Area), (Area, Fence, Area))
-> Bool
forall v. Show v => Bool -> v -> Bool
`blame` (Key
sx, Key
sy, Key
tx, Key
ty, (Area, Fence, Area)
s3, (Area, Fence, Area)
t3)) ()
  cor@(c1, c2, c3, c4) <- mkCorridor hv p0 (sa == so) p1 (ta == to) area
  let !_A2 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool
sslim Bool -> Bool -> Bool
|| Bool
tslim Bool -> Bool -> Bool
|| (Point -> Bool) -> [Point] -> Bool
forall v. Show v => (v -> Bool) -> [v] -> Bool
allB Point -> Bool
nin [Point
c1, Point
c2, Point
c3, Point
c4]
                     Bool
-> (Corridor, Key, Key, Key, Key, (Area, Fence, Area),
    (Area, Fence, Area))
-> Bool
forall v. Show v => Bool -> v -> Bool
`blame` (Corridor
cor, Key
sx, Key
sy, Key
tx, Key
ty, (Area, Fence, Area)
s3, (Area, Fence, Area)
t3)) ()
  return $ Just 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 Key -> SpecialArea -> ShowS
[SpecialArea] -> ShowS
SpecialArea -> [Char]
(Key -> SpecialArea -> ShowS)
-> (SpecialArea -> [Char])
-> ([SpecialArea] -> ShowS)
-> Show SpecialArea
forall a.
(Key -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Key -> SpecialArea -> ShowS
showsPrec :: Key -> SpecialArea -> ShowS
$cshow :: SpecialArea -> [Char]
show :: SpecialArea -> [Char]
$cshowList :: [SpecialArea] -> ShowS
showList :: [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
-> (Key, Key)
-> ((Key, Key), EnumMap Point SpecialArea)
grid EnumMap Point (Freqs PlaceKind)
fixedCenters [Point]
boot Area
area (Key, Key)
cellSize =
  let (Key
x0, Key
y0, Key
x1, Key
y1) = Area -> (Key, Key, Key, Key)
fromArea Area
area
      f :: Key -> Key -> Key -> Key -> [Key] -> [(Key, Key, Maybe Key)]
f Key
zsize Key
z1 Key
n Key
prev (Key
c1 : Key
c2 : [Key]
rest) =
        let len :: Key
len = Key
c2 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
c1
            cn :: Key
cn = Key
len Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
n Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` Key
zsize
        in -- traceShow ( zsize, z1, n, prev, len, cn
           --           , len `div` max 1 (2 * cn) ) $
           if Key
cn Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
< Key
2
           then let mid1 :: Key
mid1 = (Key
c1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
c2) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` Key
2
                    mid2 :: Key
mid2 = (Key
c1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
c2) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`divUp` Key
2
                    mid :: Key
mid = if Key
mid1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
prev Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
4 then Key
mid1 else Key
mid2
                in (Key
prev, Key
mid, Key -> Maybe Key
forall a. a -> Maybe a
Just Key
c1) (Key, Key, Maybe Key)
-> [(Key, Key, Maybe Key)] -> [(Key, Key, Maybe Key)]
forall a. a -> [a] -> [a]
: Key -> Key -> Key -> Key -> [Key] -> [(Key, Key, Maybe Key)]
f Key
zsize Key
z1 Key
n Key
mid (Key
c2 Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: [Key]
rest)
           else (Key
prev, Key
c1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
len Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` (Key
2 Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
cn), Key -> Maybe Key
forall a. a -> Maybe a
Just Key
c1)
                (Key, Key, Maybe Key)
-> [(Key, Key, Maybe Key)] -> [(Key, Key, Maybe Key)]
forall a. a -> [a] -> [a]
: [ ( Key
c1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
len Key -> Key -> Key
forall a. Num a => a -> a -> a
* (Key
2 Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
z Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` (Key
2 Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
cn)
                    , Key
c1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
len Key -> Key -> Key
forall a. Num a => a -> a -> a
* (Key
2 Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
z Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` (Key
2 Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
cn)
                    , Maybe Key
forall a. Maybe a
Nothing )
                  | Key
z <- [Key
1 .. Key
cn Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1] ]
                [(Key, Key, Maybe Key)]
-> [(Key, Key, Maybe Key)] -> [(Key, Key, Maybe Key)]
forall a. [a] -> [a] -> [a]
++ Key -> Key -> Key -> Key -> [Key] -> [(Key, Key, Maybe Key)]
f Key
zsize Key
z1 Key
n (Key
c1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
len Key -> Key -> Key
forall a. Num a => a -> a -> a
* (Key
2 Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
cn Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` (Key
2 Key -> Key -> Key
forall a. Num a => a -> a -> a
* Key
cn))
                     (Key
c2 Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: [Key]
rest)
      f Key
_ Key
z1 Key
_ Key
prev [Key
c1] = [(Key
prev, Key
z1, Key -> Maybe Key
forall a. a -> Maybe a
Just Key
c1)]
      f Key
_ Key
_ Key
_ Key
_ [] = [Char] -> [(Key, Key, Maybe Key)]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [(Key, Key, Maybe Key)])
-> [Char] -> [(Key, Key, Maybe Key)]
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
      (IntSet
xCenters, IntSet
yCenters) = [Key] -> IntSet
IS.fromList ([Key] -> IntSet)
-> ([Key] -> IntSet) -> ([Key], [Key]) -> (IntSet, IntSet)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** [Key] -> IntSet
IS.fromList
                             (([Key], [Key]) -> (IntSet, IntSet))
-> ([Key], [Key]) -> (IntSet, IntSet)
forall a b. (a -> b) -> a -> b
$ [(Key, Key)] -> ([Key], [Key])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Key, Key)] -> ([Key], [Key])) -> [(Key, Key)] -> ([Key], [Key])
forall a b. (a -> b) -> a -> b
$ (Point -> (Key, Key)) -> [Point] -> [(Key, Key)]
forall a b. (a -> b) -> [a] -> [b]
map (Point -> Key
px (Point -> Key) -> (Point -> Key) -> Point -> (Key, Key)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Point -> Key
py) ([Point] -> [(Key, Key)]) -> [Point] -> [(Key, Key)]
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
      distFromIS :: IntSet -> Key -> Key
distFromIS IntSet
is Key
z =
        - [Key] -> Key
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (Key
forall a. Bounded a => a
maxBound Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: (Key -> Key) -> [Key] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map (\Key
i -> Key -> Key
forall a. Num a => a -> a
abs (Key
i Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
z)) (IntSet -> [Key]
IS.toList IntSet
is))
      xboot :: [Key]
xboot = [Key] -> [Key]
forall a. Eq a => [a] -> [a]
nub ([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$ (Key -> Key) -> [Key] -> [Key]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (IntSet -> Key -> Key
distFromIS IntSet
xCenters)
              ([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$ (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (Key -> IntSet -> Bool
`IS.notMember` IntSet
xCenters) ([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$ (Point -> Key) -> [Point] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map Point -> Key
px [Point]
boot
      yboot :: [Key]
yboot = [Key] -> [Key]
forall a. Eq a => [a] -> [a]
nub ([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$ (Key -> Key) -> [Key] -> [Key]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (IntSet -> Key -> Key
distFromIS IntSet
yCenters)
              ([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$ (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
filter (Key -> IntSet -> Bool
`IS.notMember` IntSet
yCenters) ([Key] -> [Key]) -> [Key] -> [Key]
forall a b. (a -> b) -> a -> b
$ (Point -> Key) -> [Point] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map Point -> Key
py [Point]
boot
      -- Don't let boots ignore cell size too much, esp. in small caves.
      xcellsInArea :: Key
xcellsInArea = (Key
x1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
x0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` (Key, Key) -> Key
forall a b. (a, b) -> a
fst (Key, Key)
cellSize
      ycellsInArea :: Key
ycellsInArea = (Key
y1 Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
y0 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` (Key, Key) -> Key
forall a b. (a, b) -> b
snd (Key, Key)
cellSize
      xbootN :: Key
xbootN = Bool -> Key -> Key
forall a. HasCallStack => Bool -> a -> a
assert (Key
xcellsInArea Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
0) (Key -> Key) -> Key -> Key
forall a b. (a -> b) -> a -> b
$ Key
xcellsInArea Key -> Key -> Key
forall a. Num a => a -> a -> a
- IntSet -> Key
IS.size IntSet
xCenters
      ybootN :: Key
ybootN = Bool -> Key -> Key
forall a. HasCallStack => Bool -> a -> a
assert (Key
ycellsInArea Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
0) (Key -> Key) -> Key -> Key
forall a b. (a -> b) -> a -> b
$ Key
ycellsInArea Key -> Key -> Key
forall a. Num a => a -> a -> a
- IntSet -> Key
IS.size IntSet
yCenters
      xset :: IntSet
xset = IntSet
xCenters IntSet -> IntSet -> IntSet
`IS.union` [Key] -> IntSet
IS.fromList (Key -> [Key] -> [Key]
forall a. Key -> [a] -> [a]
take Key
xbootN [Key]
xboot)
      yset :: IntSet
yset = IntSet
yCenters IntSet -> IntSet -> IntSet
`IS.union` [Key] -> IntSet
IS.fromList (Key -> [Key] -> [Key]
forall a. Key -> [a] -> [a]
take Key
ybootN [Key]
yboot)
      xsize :: Key
xsize = IntSet -> Key
IS.findMax IntSet
xset Key -> Key -> Key
forall a. Num a => a -> a -> a
- IntSet -> Key
IS.findMin IntSet
xset
      ysize :: Key
ysize = IntSet -> Key
IS.findMax IntSet
yset Key -> Key -> Key
forall a. Num a => a -> a -> a
- IntSet -> Key
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 :: (Key, Key)
lgrid = ( Key
xsize Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` (Key, Key) -> Key
forall a b. (a, b) -> a
fst (Key, Key)
cellSize
              , Key
ysize Key -> Key -> Key
forall a. Integral a => a -> a -> a
`div` (Key, Key) -> Key
forall a b. (a, b) -> b
snd (Key, Key)
cellSize )
      xallSegments :: [(Key, (Key, Key, Maybe Key))]
xallSegments = [Key] -> [(Key, Key, Maybe Key)] -> [(Key, (Key, Key, Maybe Key))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Key
0..] ([(Key, Key, Maybe Key)] -> [(Key, (Key, Key, Maybe Key))])
-> [(Key, Key, Maybe Key)] -> [(Key, (Key, Key, Maybe Key))]
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Key -> Key -> [Key] -> [(Key, Key, Maybe Key)]
f Key
xsize Key
x1 ((Key, Key) -> Key
forall a b. (a, b) -> a
fst (Key, Key)
lgrid) Key
x0 ([Key] -> [(Key, Key, Maybe Key)])
-> [Key] -> [(Key, Key, Maybe Key)]
forall a b. (a -> b) -> a -> b
$ IntSet -> [Key]
IS.toList IntSet
xset
      yallSegments :: [(Key, (Key, Key, Maybe Key))]
yallSegments = [Key] -> [(Key, Key, Maybe Key)] -> [(Key, (Key, Key, Maybe Key))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Key
0..] ([(Key, Key, Maybe Key)] -> [(Key, (Key, Key, Maybe Key))])
-> [(Key, Key, Maybe Key)] -> [(Key, (Key, Key, Maybe Key))]
forall a b. (a -> b) -> a -> b
$ Key -> Key -> Key -> Key -> [Key] -> [(Key, Key, Maybe Key)]
f Key
ysize Key
y1 ((Key, Key) -> Key
forall a b. (a, b) -> b
snd (Key, Key)
lgrid) Key
y0 ([Key] -> [(Key, Key, Maybe Key)])
-> [Key] -> [(Key, Key, Maybe Key)]
forall a b. (a -> b) -> a -> b
$ IntSet -> [Key]
IS.toList IntSet
yset
  in -- traceShow (xallSegments, yallSegments) $
     ( ([(Key, (Key, Key, Maybe Key))] -> Key
forall a. [a] -> Key
length [(Key, (Key, Key, Maybe Key))]
xallSegments, [(Key, (Key, Key, Maybe Key))] -> Key
forall a. [a] -> Key
length [(Key, (Key, Key, Maybe Key))]
yallSegments)
     , [(Point, SpecialArea)] -> EnumMap Point SpecialArea
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromDistinctAscList
         [ ( Key -> Key -> Point
Point Key
x Key
y
           , case (Maybe Key
mcx, Maybe Key
mcy) of
               (Just Key
cx, Just Key
cy) ->
                 case Point -> EnumMap Point (Freqs PlaceKind) -> Maybe (Freqs PlaceKind)
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup (Key -> Key -> Point
Point Key
cx Key
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 (Key -> Key -> Point
Point Key
cx Key
cy) Freqs PlaceKind
placeFreq Area
sarea
               (Maybe Key, Maybe Key)
_ -> Area -> SpecialArea
SpecialArea Area
sarea )
         | (Key
y, (Key
cy0, Key
cy1, Maybe Key
mcy)) <- [(Key, (Key, Key, Maybe Key))]
yallSegments
         , (Key
x, (Key
cx0, Key
cx1, Maybe Key
mcx)) <- [(Key, (Key, Key, Maybe Key))]
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] -> (Key, Key) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (Key
x, Key
y))
                       (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (Key, Key, Key, Key) -> Maybe Area
toArea (Key
cx0, Key
cy0, Key
cx1, Key
cy1) ] )