-- | 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
px :: Point -> Key
py :: 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
  Key
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{Key
px :: Point -> Key
py :: Point -> Key
px :: Key
py :: Key
..} = Key -> Key -> Point
punindex Key
xspan Key
pxy
  Point -> Rnd Point
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Point -> Rnd Point) -> Point -> Rnd Point
forall a b. (a -> b) -> a -> b
$! 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)

-- | 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
px :: Point -> Key
py :: 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
        Key
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)
        (Point -> Maybe Point)
-> Rnd (Maybe Point) -> Key -> Rnd (Maybe Point)
forall (m :: * -> *).
Applicative m =>
(Point -> Maybe Point) -> m (Maybe Point) -> Key -> m (Maybe Point)
checkPoint Point -> Maybe Point
g (Key -> Rnd (Maybe Point)
gsearch (Key
count Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)) Key
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
        Key
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)
        (Point -> Maybe Point)
-> Rnd (Maybe Point) -> Key -> Rnd (Maybe Point)
forall (m :: * -> *).
Applicative m =>
(Point -> Maybe Point) -> m (Maybe Point) -> Key -> m (Maybe Point)
checkPoint Point -> Maybe Point
f (Key -> Rnd (Maybe Point)
fsearch (Key
count Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)) Key
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
  Point
pxy <- Area -> Rnd Point
pointInArea Area
core
  Area -> Rnd Area
forall a. a -> StateT SMGen Identity a
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 :: (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 Key
xW Key
yW <- Area -> Rnd Point
pointInArea Area
areaW  -- roll size
  let a1 :: (Key, Key, Key, Key)
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
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 Key
rx1 Key
ry1 <- Area -> Rnd Point
pointInArea Area
area1  -- roll top-left corner
  let a3 :: (Key, Key, Key, Key)
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
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
  Area -> Rnd Area
forall a. a -> StateT SMGen Identity a
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 -> (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.
  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
-> (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 []

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
      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
$ Key -> Key -> Point -> [Point]
vicinityCardinal Key
nx Key
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 a. a -> StateT SMGen Identity a
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 a. a -> StateT SMGen Identity a
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
-> (Key, Key)
-> EnumSet Point
-> EnumSet Point
-> [(Point, Point)]
-> Rnd [(Point, Point)]
connectGrid' EnumSet Point
voidPlaces (Key
nx, Key
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 :: (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
  Bool
rb <- [Bool] -> Rnd Bool
forall a. [a] -> Rnd a
oneOf [Bool
False, Bool
True]
  if Bool
rb Bool -> Bool -> Bool
&& 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
1
  then do
    Key
rx <- Key -> Rnd Key
forall a. Integral a => a -> Rnd a
randomR0 (Key
nx Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
2)
    Key
ry <- Key -> Rnd Key
forall a. Integral a => a -> Rnd a
randomR0 (Key
ny Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)
    (Point, Point) -> Rnd (Point, Point)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> Key -> Point
Point Key
rx Key
ry, Key -> Key -> Point
Point (Key
rxKey -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1) Key
ry)
  else do
    Key
rx <- Key -> Rnd Key
forall a. Integral a => a -> Rnd a
randomR0 (Key
nx Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)
    Key
ry <- Key -> Rnd Key
forall a. Integral a => a -> Rnd a
randomR0 (Key
ny Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
2)
    (Point, Point) -> Rnd (Point, Point)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> Key -> Point
Point Key
rx Key
ry, Key -> Key -> Point
Point Key
rx (Key
ryKey -> Key -> Key
forall a. Num a => a -> a -> a
+Key
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 Key
rxRaw Key
ryRaw <- Area -> Rnd Point
pointInArea Area
area
  let (Key
sx0, Key
sy0, Key
sx1, Key
sy1) = Area -> (Key, Key, Key, Key)
fromArea Area
area
      -- Avoid corridors that run along @FGround@ or @FFloor@ fence,
      -- unless not possible.
      rx :: Key
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 :: Key
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
  Corridor -> Rnd Corridor
forall a. a -> StateT SMGen Identity a
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 -> (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 Key
sx Key
sy <- Area -> Rnd Point
pointInArea (Area -> Rnd Point) -> Area -> Rnd Point
forall a b. (a -> b) -> a -> b
$ Area -> Area
trim Area
sa
  Point Key
tx Key
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 (Key
_, Key
_, Key
sax1Raw, Key
say1Raw) = Area -> (Key, Key, Key, Key)
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
      (Key
sax1, Key
say1) = if Bool
sslim
                     then (Key
sax1Raw Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1, Key
say1Raw Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1)
                     else (Key
sax1Raw, Key
say1Raw)
      (Key
tax0Raw, Key
tay0Raw, Key
_, Key
_) = Area -> (Key, Key, Key, Key)
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
      (Key
tax0, Key
tay0) = if Bool
tslim
                     then (Key
tax0Raw Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1, Key
tay0Raw Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1)
                     else (Key
tax0Raw, Key
tay0Raw)
      (Key
_, Key
_, Key
sox1, Key
soy1) = Area -> (Key, Key, Key, Key)
fromArea Area
so  -- outer area
      (Key
tox0, Key
toy0, Key
_, Key
_) = Area -> (Key, Key, Key, Key)
fromArea Area
to
      (Key
sgx0, Key
sgy0, Key
sgx1, Key
sgy1) = Area -> (Key, Key, Key, Key)
fromArea Area
sg  -- grid area
      (Key
tgx0, Key
tgy0, Key
tgx1, Key
tgy1) = Area -> (Key, Key, Key, Key)
fromArea Area
tg
      (HV
hv, Area
area, Point
p0, Point
p1)
        | Key
sgx1 Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
tgx0 =
          let x0 :: Key
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 :: Key
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 (Key, Key, Key, Key) -> Maybe Area
toArea (Key
x0, Key -> Key -> Key
forall a. Ord a => a -> a -> a
min Key
sy Key
ty, Key
x1, Key -> Key -> Key
forall a. Ord a => a -> a -> a
max Key
sy Key
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)
        | Bool
otherwise = Bool -> (HV, Area, Point, Point) -> (HV, Area, Point, Point)
forall a. HasCallStack => Bool -> a -> a
assert (Key
sgy1 Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
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 :: Key
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 :: Key
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 (Key, Key, Key, Key) -> Maybe Area
toArea (Key -> Key -> Key
forall a. Ord a => a -> a -> a
min Key
sx Key
tx, Key
y0, Key -> Key -> Key
forall a. Ord a => a -> a -> a
max Key
sx Key
tx, Key
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 -> 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 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 :: 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 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)) ()
  Maybe Corridor -> Rnd (Maybe Corridor)
forall a. a -> StateT SMGen Identity a
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 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) ] )