module Game.LambdaHack.Server.DungeonGen.AreaRnd
(
xyInArea, mkVoidRoom, mkRoom
, connectGrid, randomConnection
, HV(..), Corridor, connectPlaces
#ifdef EXPOSE_INTERNAL
, connectGrid', sortPoint, mkCorridor, borderPlace
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Data.EnumSet as ES
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Content.PlaceKind
import Game.LambdaHack.Server.DungeonGen.Area
xyInArea :: Area -> Rnd Point
xyInArea area = do
let (x0, y0, x1, y1) = fromArea area
rx <- randomR (x0, x1)
ry <- randomR (y0, y1)
return $! Point rx ry
mkVoidRoom :: Area -> Rnd Area
mkVoidRoom area = do
let core = fromMaybe area $ shrink area
pxy <- xyInArea 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 <- xyInArea 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 <- xyInArea 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 || ny <= 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]
mkCorridor :: HV
-> Point
-> Bool
-> Point
-> Bool
-> Area
-> Rnd Corridor
mkCorridor hv (Point x0 y0) p0floor (Point x1 y1) p1floor area = do
Point rxRaw ryRaw <- xyInArea 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 $! map (uncurry Point) $ case hv of
Horiz -> [(x0, y0), (rx, y0), (rx, y1), (x1, y1)]
Vert -> [(x0, y0), (x0, ry), (x1, ry), (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) = borderPlace sqarea spfence
(ta, to) = 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 <- xyInArea $ trim sa
Point tx ty <- xyInArea $ trim ta
let (_, _, sax1Raw, say1Raw) = fromArea sa
strivial = isTrivialArea sqarea && spfence == FNone
(sax1, say1) = if strivial
then (sax1Raw - 1, say1Raw - 1)
else (sax1Raw, say1Raw)
(tax0Raw, tay0Raw, _, _) = fromArea ta
ttrivial = isTrivialArea tqarea && tpfence == FNone
(tax0, tay0) = if ttrivial
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` fromArea sa || p `inside` fromArea ta
!_A = assert (strivial || ttrivial
|| allB nin [p0, p1]`blame` (sx, sy, tx, ty, s3, t3)) ()
cor <- mkCorridor hv p0 (sa == so) p1 (ta == to) area
let !_A2 = assert (strivial || ttrivial
|| allB nin cor `blame` (sx, sy, tx, ty, s3, t3)) ()
return $ Just cor
borderPlace :: Area -> Fence -> (Area, Area)
borderPlace qarea pfence = case pfence of
FWall -> (qarea, expand qarea)
FFloor -> (qarea, qarea)
FGround -> (qarea, qarea)
FNone -> case shrink qarea of
Nothing -> (qarea, qarea)
Just sr -> (sr, qarea)