module Game.LambdaHack.Server.DungeonGen.AreaRnd
(
mkFixed, pointInArea, findPointInArea, mkVoidRoom, mkRoom
, connectGrid, randomConnection
, HV(..), Corridor, connectPlaces
, SpecialArea(..), grid
#ifdef EXPOSE_INTERNAL
, 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.Definition.Defs
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Core.Random
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Content.PlaceKind
mkFixed :: (X, Y)
-> Area
-> Point
-> Area
mkFixed (xMax, yMax) area p@Point{..} =
let (x0, y0, x1, y1) = fromArea area
xradius = min ((xMax + 1) `div` 2) $ min (px - x0) (x1 - px)
yradius = min ((yMax + 1) `div` 2) $ min (py - y0) (y1 - py)
a = (px - xradius, py - yradius, px + xradius, py + yradius)
in fromMaybe (error $ "" `showFailure` (a, xMax, yMax, area, p)) $ toArea a
pointInArea :: Area -> Rnd Point
pointInArea area = do
let (Point x0 y0, xspan, yspan) = spanArea area
pxy <- randomR (0, xspan * yspan - 1)
let Point{..} = punindex xspan pxy
return $! Point (x0 + px) (y0 + py)
findPointInArea :: Area -> (Point -> Maybe Point)
-> Int -> (Point -> Maybe Point)
-> Rnd (Maybe Point)
findPointInArea area g gnumTries f =
let (Point x0 y0, xspan, yspan) = spanArea area
checkPoint :: Applicative m
=> (Point -> Maybe Point) -> m (Maybe Point) -> Int
-> m (Maybe Point)
{-# INLINE checkPoint #-}
checkPoint check fallback pxyRelative =
let Point{..} = punindex xspan pxyRelative
pos = Point (x0 + px) (y0 + py)
in case check pos of
Just p -> pure $ Just p
Nothing -> fallback
gsearch 0 = fsearch (xspan * yspan * 10)
gsearch count = do
pxy <- randomR (0, xspan * yspan - 1)
checkPoint g (gsearch (count - 1)) pxy
fsearch 0 = return $! runIdentity $ searchAll (xspan * yspan - 1)
fsearch count = do
pxy <- randomR (0, xspan * yspan - 1)
checkPoint f (fsearch (count - 1)) pxy
searchAll (-1) = pure Nothing
searchAll pxyRelative =
checkPoint f (searchAll (pxyRelative - 1)) pxyRelative
in gsearch gnumTries
mkVoidRoom :: Area -> Rnd Area
mkVoidRoom area = do
let core = fromMaybe area $ shrink area
pxy <- pointInArea core
return $! trivialArea pxy
mkRoom :: (X, Y)
-> (X, Y)
-> Area
-> Rnd Area
mkRoom (xm, ym) (xM, yM) area = do
let (x0, y0, x1, y1) = fromArea area
xspan = x1 - x0 + 1
yspan = y1 - y0 + 1
aW = (min xm xspan, min ym yspan, min xM xspan, min yM yspan)
areaW = fromMaybe (error $ "" `showFailure` aW) $ toArea aW
Point xW yW <- pointInArea areaW
let a1 = (x0, y0, max x0 (x1 - xW + 1), max y0 (y1 - yW + 1))
area1 = fromMaybe (error $ "" `showFailure` a1) $ toArea a1
Point rx1 ry1 <- pointInArea area1
let a3 = (rx1, ry1, rx1 + xW - 1, ry1 + yW - 1)
area3 = fromMaybe (error $ "" `showFailure` a3) $ toArea a3
return $! area3
connectGrid :: ES.EnumSet Point -> (X, Y) -> Rnd [(Point, Point)]
connectGrid voidPlaces (nx, ny) = do
let unconnected = ES.fromDistinctAscList [ Point x y
| y <- [0..ny-1], x <- [0..nx-1] ]
p <- oneOf $ ES.toList $ unconnected ES.\\ voidPlaces
let candidates = ES.singleton 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' voidPlaces (nx, ny) unconnected candidates !acc
| unconnected `ES.isSubsetOf` voidPlaces = return acc
| otherwise = do
let candidatesBest = candidates ES.\\ voidPlaces
c <- oneOf $ ES.toList $ if ES.null candidatesBest
then candidates
else candidatesBest
let ns = ES.fromList $ vicinityCardinal nx ny c
nu = ES.delete c unconnected
(nc, ds) = ES.partition (`ES.member` nu) ns
new <- if ES.null ds
then return id
else do
d <- oneOf (ES.toList ds)
return (sortPoint (c, d) :)
connectGrid' voidPlaces (nx, ny) nu
(ES.delete c (candidates `ES.union` nc)) (new acc)
sortPoint :: (Point, Point) -> (Point, Point)
sortPoint (a, b) | a <= b = (a, b)
| otherwise = (b, a)
randomConnection :: (X, Y) -> Rnd (Point, Point)
randomConnection (nx, ny) =
assert (nx > 1 && ny > 0 || nx > 0 && ny > 1 `blame` (nx, ny)) $ do
rb <- oneOf [False, True]
if rb && nx > 1
then do
rx <- randomR (0, nx-2)
ry <- randomR (0, ny-1)
return (Point rx ry, Point (rx+1) ry)
else do
rx <- randomR (0, nx-1)
ry <- randomR (0, ny-2)
return (Point rx ry, Point rx (ry+1))
data HV = Horiz | Vert
deriving Eq
type Corridor = (Point, Point, Point, Point)
mkCorridor :: HV
-> Point
-> Bool
-> Point
-> Bool
-> Area
-> Rnd Corridor
mkCorridor hv (Point x0 y0) p0floor (Point x1 y1) p1floor area = do
Point rxRaw ryRaw <- pointInArea area
let (sx0, sy0, sx1, sy1) = fromArea area
rx = if | rxRaw == sx0 + 1 && p0floor -> sx0
| rxRaw == sx1 - 1 && p1floor -> sx1
| otherwise -> rxRaw
ry = if | ryRaw == sy0 + 1 && p0floor -> sy0
| ryRaw == sy1 - 1 && p1floor -> sy1
| otherwise -> ryRaw
return $! case hv of
Horiz -> (Point x0 y0, Point rx y0, Point rx y1, Point x1 y1)
Vert -> (Point x0 y0, Point x0 ry, Point x1 ry, Point x1 y1)
connectPlaces :: (Area, Fence, Area) -> (Area, Fence, Area)
-> Rnd (Maybe Corridor)
connectPlaces (_, _, sg) (_, _, tg) | sg == tg = return Nothing
connectPlaces s3@(sqarea, spfence, sg) t3@(tqarea, tpfence, tg) = do
let (sa, so, stiny) = borderPlace sqarea spfence
(ta, to, ttiny) = borderPlace tqarea tpfence
trim area =
let (x0, y0, x1, y1) = fromArea area
dx = case (x1 - x0) `div` 2 of
0 -> 0
1 -> 1
2 -> 1
3 -> 1
_ -> 3
dy = case (y1 - y0) `div` 2 of
0 -> 0
1 -> 1
2 -> 1
3 -> 1
_ -> 3
in fromMaybe (error $ "" `showFailure` (area, s3, t3))
$ toArea (x0 + dx, y0 + dy, x1 - dx, y1 - dy)
Point sx sy <- pointInArea $ trim sa
Point tx ty <- pointInArea $ trim ta
let (_, _, sax1Raw, say1Raw) = fromArea sa
sslim = stiny && spfence == FNone
(sax1, say1) = if sslim
then (sax1Raw - 1, say1Raw - 1)
else (sax1Raw, say1Raw)
(tax0Raw, tay0Raw, _, _) = fromArea ta
tslim = ttiny && tpfence == FNone
(tax0, tay0) = if tslim
then (tax0Raw + 1, tay0Raw + 1)
else (tax0Raw, tay0Raw)
(_, _, sox1, soy1) = fromArea so
(tox0, toy0, _, _) = fromArea to
(sgx0, sgy0, sgx1, sgy1) = fromArea sg
(tgx0, tgy0, tgx1, tgy1) = fromArea tg
(hv, area, p0, p1)
| sgx1 == tgx0 =
let x0 = if sgy0 <= ty && ty <= sgy1 then sox1 + 1 else sgx1
x1 = if tgy0 <= sy && sy <= tgy1 then tox0 - 1 else sgx1
in case toArea (x0, min sy ty, x1, max sy ty) of
Just a -> (Horiz, a, Point (sax1 + 1) sy, Point (tax0 - 1) ty)
Nothing -> error $ "" `showFailure` (sx, sy, tx, ty, s3, t3)
| otherwise = assert (sgy1 == tgy0) $
let y0 = if sgx0 <= tx && tx <= sgx1 then soy1 + 1 else sgy1
y1 = if tgx0 <= sx && sx <= tgx1 then toy0 - 1 else sgy1
in case toArea (min sx tx, y0, max sx tx, y1) of
Just a -> (Vert, a, Point sx (say1 + 1), Point tx (tay0 - 1))
Nothing -> error $ "" `showFailure` (sx, sy, tx, ty, s3, t3)
nin p = not $ p `inside` sa || p `inside` ta
!_A = assert (sslim || tslim
|| allB nin [p0, p1] `blame` (sx, sy, tx, ty, s3, t3)) ()
cor@(c1, c2, c3, c4) <- mkCorridor hv p0 (sa == so) p1 (ta == to) area
let !_A2 = assert (sslim || tslim || allB nin [c1, c2, c3, c4]
`blame` (cor, sx, sy, tx, ty, s3, t3)) ()
return $ Just cor
borderPlace :: Area -> Fence -> (Area, Area, Bool)
borderPlace qarea pfence = case pfence of
FWall -> (qarea, expand qarea, False)
FFloor -> (qarea, qarea, False)
FGround -> (qarea, qarea, False)
FNone -> case shrink qarea of
Nothing -> (qarea, qarea, True)
Just sr -> (sr, qarea, False)
data SpecialArea =
SpecialArea Area
| SpecialFixed Point (Freqs PlaceKind) Area
| SpecialMerged SpecialArea Point
deriving Show
grid :: EM.EnumMap Point (Freqs PlaceKind) -> [Point] -> Area -> (X, Y)
-> ((X, Y), EM.EnumMap Point SpecialArea)
grid fixedCenters boot area cellSize =
let (x0, y0, x1, y1) = fromArea area
f zsize z1 n prev (c1 : c2 : rest) =
let len = c2 - c1
cn = len * n `div` zsize
in
if cn < 2
then let mid1 = (c1 + c2) `div` 2
mid2 = (c1 + c2) `divUp` 2
mid = if mid1 - prev > 4 then mid1 else mid2
in (prev, mid, Just c1) : f zsize z1 n mid (c2 : rest)
else (prev, c1 + len `div` (2 * cn), Just c1)
: [ ( c1 + len * (2 * z - 1) `div` (2 * cn)
, c1 + len * (2 * z + 1) `div` (2 * cn)
, Nothing )
| z <- [1 .. cn - 1] ]
++ f zsize z1 n (c1 + len * (2 * cn - 1) `div` (2 * cn))
(c2 : rest)
f _ z1 _ prev [c1] = [(prev, z1, Just c1)]
f _ _ _ _ [] = error $ "empty list of centers" `showFailure` fixedCenters
(xCenters, yCenters) = unzip $ map (px &&& py) $ EM.keys fixedCenters
xset = IS.fromList $ xCenters ++ map px boot
yset = IS.fromList $ yCenters ++ map py boot
xsize = IS.findMax xset - IS.findMin xset
ysize = IS.findMax yset - IS.findMin yset
lgrid = ( xsize `div` fst cellSize
, ysize `div` snd cellSize )
xallSegments = zip [0..] $ f xsize x1 (fst lgrid) x0 $ IS.toList xset
yallSegments = zip [0..] $ f ysize y1 (snd lgrid) y0 $ IS.toList yset
in
( (length xallSegments, length yallSegments)
, EM.fromDistinctAscList
[ ( Point x y
, case (mcx, mcy) of
(Just cx, Just cy) ->
case EM.lookup (Point cx cy) fixedCenters of
Nothing -> SpecialArea sarea
Just placeFreq -> SpecialFixed (Point cx cy) placeFreq sarea
_ -> SpecialArea sarea )
| (y, (cy0, cy1, mcy)) <- yallSegments
, (x, (cx0, cx1, mcx)) <- xallSegments
, let sarea = fromMaybe (error $ "" `showFailure` (x, y))
$ toArea (cx0, cy0, cx1, cy1) ] )