314 lines
12 KiB
Haskell
314 lines
12 KiB
Haskell
-- | Procedural creation of rooms and subroom parts.
|
|
module Dodge.Room.Procedural (
|
|
roomRect,
|
|
roomRectAutoLights,
|
|
randomFourCornerRoom,
|
|
randomFourCornerRoomCrsIts,
|
|
centerVaultRoom,
|
|
combineRooms,
|
|
-- linksAndPath,
|
|
-- makeGrid,
|
|
) where
|
|
|
|
import Linear
|
|
import Grid
|
|
import Dodge.Door.PutSlideDoor
|
|
import Dodge.Default.Wall
|
|
import Control.Monad
|
|
import Tile
|
|
import qualified Data.Set as S
|
|
import Data.Tile
|
|
import Dodge.Creature
|
|
import Dodge.Data.GenWorld
|
|
import Dodge.Default.Door
|
|
import Dodge.Default.Room
|
|
import Dodge.LevelGen.PlacementHelper
|
|
import Dodge.LevelGen.Switch
|
|
import Dodge.Placement.Instance
|
|
import Dodge.Placement.Shift
|
|
import Dodge.PlacementSpot
|
|
import Dodge.Room.Link
|
|
import Dodge.Room.Path
|
|
import Dodge.RoomLink
|
|
import Geometry
|
|
import LensHelp
|
|
import Picture
|
|
import RandomHelp
|
|
|
|
--import Control.Lens
|
|
-- This will need a cleanup, but it might change a bit first
|
|
{- A simple rectangular room with no lights.
|
|
Creates links and pathfinding graph. -}
|
|
roomRect :: Float -> Float -> Int -> Int -> Room
|
|
roomRect x y xn yn =
|
|
defaultRoom
|
|
{ _rmPolys = [rectNSWE y 0 0 x]
|
|
, _rmLinks = lnks
|
|
, _rmName = "rect"
|
|
, _rmPath = linksDAGToPath lnks $ latticeXsYs xs ys
|
|
, _rmPos = gridRoomPos xs ys
|
|
, _rmPmnts = []
|
|
, _rmBound = [rectNSWE (y + 5) (-5) (-5) (x + 5)]
|
|
, _rmFloor =
|
|
Tiled
|
|
[ Tile
|
|
{ _tilePoly = rectNSWE y 0 0 x
|
|
, _tileZero = 0
|
|
, _tileTangentPos = V2 baseFloorTileSize 0
|
|
, _tileArrayZ = 16
|
|
}
|
|
]
|
|
, _rmRandPSs = [psRandRanges (10, x -10) (10, y -10) (0, 2 * pi)]
|
|
, _rmType =
|
|
RectRoomType
|
|
{ _numLinkEW = xn
|
|
, _numLinkNS = yn
|
|
, _linkGapEW = xd
|
|
, _linkGapNS = yd
|
|
, _rmWidth = x
|
|
, _rmHeight = y
|
|
}
|
|
}
|
|
where
|
|
xs = take (xn + 1) [0,xd..] & each +~ 20
|
|
ys = take (yn + 1) [0,yd..] & each +~ 20
|
|
yd = (y - 40) / fromIntegral yn
|
|
xd = (x - 40) / fromIntegral xn
|
|
horilnks y' a e = xs <&> \x' -> RoomLink (rlt e) (V2 x' y') a
|
|
vertlnks x' a e = ys <&> \y' -> RoomLink (rlt e) (V2 x' y') a
|
|
rlt e = S.fromList [OnEdge e, InLink, OutLink]
|
|
wlnks = vertlnks 0 (pi/2) West
|
|
elnks = vertlnks x (-pi/2) East
|
|
nlnks = horilnks y 0 North
|
|
slnks = horilnks 0 pi South
|
|
lnks = imap (g West) nlnks
|
|
<> imap (g West) slnks
|
|
<> imap (g South) elnks
|
|
<> imap (g South) wlnks
|
|
g c xi = rlType <>~ S.fromList [FromEdge c xi,FromEdge (revCard c) (xn - xi)]
|
|
|
|
gridRoomPos :: [Float] -> [Float] -> [RoomPos]
|
|
gridRoomPos xs ys = map makeonpos (grid xs ys) <> map makeoffpos (grid (mids xs) (mids ys))
|
|
where
|
|
yn = length ys - 1
|
|
xn = length xs - 1
|
|
grid as bs = [(V2 x' y', (xi,yi)) | (x',xi) <- zip as [0..], (y',yi) <- zip bs [0..]]
|
|
makeonpos (p, a) = RoomPos p 0 (S.singleton $ RoomPosOnGrid $ makerpedges a)
|
|
(NotLink True) mempty
|
|
makerpedges (a, b) =
|
|
S.fromList
|
|
[ PathFromEdge South b
|
|
, PathFromEdge North (yn - b)
|
|
, PathFromEdge East (xn - a)
|
|
, PathFromEdge West a
|
|
]
|
|
mids zs = zipWith (\a b -> 0.5 * (a + b)) zs $ tail zs
|
|
makeoffpos (p, a) = RoomPos
|
|
p 0 (S.singleton $ RoomPosOffGrid $ makerpedges' a) (NotLink False) mempty
|
|
makerpedges' (a, b) =
|
|
S.fromList
|
|
[ PathFromEdge South b
|
|
, PathFromEdge North (yn - (b + 1))
|
|
, PathFromEdge East (xn - (a + 1))
|
|
, PathFromEdge West a
|
|
]
|
|
|
|
{- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size. -}
|
|
-- it is not clear to me that this works for very small rooms (but it does seem
|
|
-- to do so)
|
|
roomRectAutoLights :: RandomGen g => Float -> Float -> State g Room
|
|
roomRectAutoLights x y = do
|
|
shp <- takeOne [vShape, lShape, jShape, liShape]
|
|
let l1 = mntLightLnkShape shp $ resetPLUse $ rprBool $ \rp _ -> isInLnk rp
|
|
l2 = mntLightLnkShape shp $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp
|
|
return $ roomRect x y (f x) (f y)
|
|
& rmName .~ "autoRect"
|
|
& rmPmnts .~ [ l1 , l2 ]
|
|
where
|
|
f z = max 1 $ (ceiling z - 40) `div` 60
|
|
|
|
{- Combines two rooms into one room.
|
|
- will have to work out exactly what to do with combining links
|
|
Mostly involves concatenation. -}
|
|
combineRooms :: Room -> Room -> Room
|
|
combineRooms r r' =
|
|
defaultRoom
|
|
{ _rmPolys = _rmPolys r ++ _rmPolys r'
|
|
, _rmLinks = _rmLinks r ++ _rmLinks r'
|
|
, _rmPath = S.map clampPath $ _rmPath r <> _rmPath r'
|
|
, _rmPmnts = _rmPmnts r ++ _rmPmnts r'
|
|
, _rmBound = _rmBound r ++ _rmBound r'
|
|
, _rmPos = _rmPos r ++ _rmPos r'
|
|
, _rmFloor = combineFloors (_rmFloor r) (_rmFloor r')
|
|
, _rmShift = (V2 0 0, 0)
|
|
}
|
|
|
|
-- not that this assumes that any link paths are integral
|
|
clampPath :: (Point2, Point2) -> (Point2, Point2)
|
|
clampPath = bimap f f
|
|
where
|
|
f (V2 x y) = V2 (g x) (g y)
|
|
g = (fromIntegral :: Int -> Float) . floor
|
|
|
|
combineFloors :: Floor -> Floor -> Floor
|
|
combineFloors = const
|
|
|
|
{- Randomly generate a top fourth of a room possibly with a wall.
|
|
Add a light and a 'PutNothing' placement. -}
|
|
quarterRoomTri :: RandomGen g => Float -> State g Room
|
|
quarterRoomTri w = do
|
|
b <-
|
|
takeOne
|
|
[
|
|
[ mntLS vShape (V2 0 w) (V3 0 (w -20) 70)
|
|
, blockLine (V2 (w / 2) (w / 2)) (V2 (w / 2) w)
|
|
]
|
|
, [blockLine (V2 (w / 2) (w / 2)) (V2 (negate $ w / 2) (w / 2))]
|
|
,
|
|
[ blockLine (V2 (w / 2) (w / 2)) (V2 0 (w / 2))
|
|
, blockLine (V2 (-29) w) (V2 0 (w / 2)) & plType . putWall . wlRotateTo .~ False
|
|
]
|
|
]
|
|
pure $
|
|
defaultRoom
|
|
{ _rmPolys = [[V2 0 0, V2 w w, V2 (- w) w]]
|
|
, _rmLinks = [toBothLnk (V2 0 w, 0)]
|
|
, _rmPath =
|
|
foldMap
|
|
doublePairSet
|
|
[ (V2 0 w, V2 0 (w -20))
|
|
, (V2 0 (w -20), V2 (w -20) (w -20))
|
|
, (V2 0 (w -20), V2 (55 - w) (w -20))
|
|
, (V2 (55 - w) (w -20), V2 (20 - w) (w -20))
|
|
, (V2 0 (w -20), V2 0 0)
|
|
, (V2 (55 - w) (w -20), V2 0 0)
|
|
]
|
|
, _rmPmnts = b ++ [mntLS iShape (V2 (w -20) w) (V3 (w -20) (w -20) 70)]
|
|
, _rmPos =
|
|
[ RoomPos (V2 (w -20) (w -20)) pi S.empty (NotLink False) mempty
|
|
, RoomPos (V2 (w -15) (w -25)) pi S.empty (NotLink False) mempty
|
|
]
|
|
, _rmBound = [[V2 0 0, V2 w w, V2 (- w) w]]
|
|
}
|
|
|
|
quarterRoomSquare :: RandomGen g => Float -> State g Room
|
|
quarterRoomSquare w = do
|
|
b <-
|
|
takeOne
|
|
[
|
|
[ mntLS vShape (V2 0 (2 * w -20)) (V3 0 (2 * w -40) 70)
|
|
, blockLine (V2 (negate $ w / 2) (w / 2)) (V2 0 w)
|
|
]
|
|
,
|
|
[ mntLS vShape (V2 0 (2 * w -20)) (V3 0 (2 * w -40) 70)
|
|
, blockLine (V2 (negate w) w) (V2 0 w)
|
|
]
|
|
,
|
|
[ mntLS iShape (V2 (0.7 * w) (1.3 * w)) (V3 (0.7 * w -20) (1.3 * w -20) 70)
|
|
, blockLine (V2 0 w) (V2 0 (w * 2))
|
|
]
|
|
]
|
|
let thepoly = [map toV2 [(0, 0), (w, w), (0, 2 * w), (- w, w)]]
|
|
pure $
|
|
defaultRoom
|
|
{ _rmPolys = thepoly
|
|
, _rmLinks =
|
|
map
|
|
toBothLnk
|
|
[ (V2 (w / 2) (3 * w / 2), negate $ pi / 4)
|
|
, (V2 (negate $ w / 2) (3 * w / 2), pi / 4)
|
|
]
|
|
, _rmPath =
|
|
foldMap
|
|
doublePairSet
|
|
[ (V2 (0.5 * w) (1.5 * w), V2 (0.5 * w -20) (1.5 * w -20))
|
|
, (V2 (-0.5 * w) (1.5 * w), V2 (-0.5 * w + 20) (1.5 * w -20))
|
|
, (V2 0 (2 * w -40), V2 (-0.5 * w + 20) (1.5 * w -20))
|
|
, (V2 0 (2 * w -40), V2 (0.5 * w -20) (1.5 * w -20))
|
|
, (V2 (w -20) (w -20), V2 (0.5 * w -20) (1.5 * w -20))
|
|
, (V2 (20 - w) (w -20), V2 (-0.5 * w + 20) (1.5 * w -20))
|
|
, --,(V2 (40-w) (w),V2 0 (w-40))
|
|
(V2 (20 - w) (w -20), V2 0 (w -40))
|
|
, (V2 0 0, V2 0 (w -40))
|
|
-- ,(V2 (20-w) (w-20),V2 (40-w) (w))
|
|
]
|
|
, _rmPmnts = b ++ [blockLine (V2 (w / 2) (w / 2)) (V2 0 w)]
|
|
, _rmPos =
|
|
[ RoomPos p pi S.empty (NotLink False) mempty
|
|
| p <- [V2 20 (2 * w -40), V2 25 (2 * w -45)]
|
|
]
|
|
, --, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
|
|
_rmBound = [map toV2 [(0, 0), (w, w), (0, 2 * w), (- w, w)]]
|
|
}
|
|
|
|
{- | A randomly generate room based on four randomly generated corners.
|
|
Tight corridors, random placements.
|
|
-}
|
|
randomFourCornerRoom :: RandomGen g => [Item] -> State g Room
|
|
randomFourCornerRoom its = do
|
|
nCrits <- state $ randomR (1, 3)
|
|
crits <-
|
|
takeN nCrits <=< shuffle $
|
|
[spreadGunCrit, autoCrit, armourChaseCrit]
|
|
++ replicate 20 chaseCrit
|
|
randomFourCornerRoomCrsIts crits its
|
|
|
|
{- | A randomly generate room based on four randomly generated corners.
|
|
Tight corridors.
|
|
-}
|
|
randomFourCornerRoomCrsIts :: RandomGen g => [Creature] -> [Item] -> State g Room
|
|
randomFourCornerRoomCrsIts crits its = do
|
|
corners <- replicateM 4 . join $ takeOne [quarterRoomTri 100, quarterRoomSquare 100]
|
|
let putitms = map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) its
|
|
putcrits = map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crits
|
|
shuffleLinks
|
|
. (rmPmnts .++~ (sps0 putLamp : putitms ++ putcrits))
|
|
. foldr1 combineRooms
|
|
$ zipWith (\r a -> moveRoomBy (V2 0 0, a) r) corners [0, pi / 2, pi, 3 * pi / 2]
|
|
|
|
-- | Creates room with a central vault with doors around it.
|
|
centerVaultRoom ::
|
|
-- | Width
|
|
Float ->
|
|
-- | Height
|
|
Float ->
|
|
-- | Vault dimensions
|
|
Float ->
|
|
State g Room
|
|
centerVaultRoom w h d =
|
|
return $
|
|
defaultRoom
|
|
{ _rmPolys = [rectNSWE h (- h) (- w) w]
|
|
, _rmLinks =
|
|
[ outLink (V2 0 h) 0
|
|
, outLink (V2 w 0) (- pi / 2)
|
|
, outLink (V2 (- w) 0) (pi / 2)
|
|
, inLink (V2 0 (- h)) pi
|
|
]
|
|
, _rmPath = mempty
|
|
, _rmPmnts =
|
|
[ sps0 $ PutWall (reverse $ rectNSWE d (d - 30) (d - 30) d) defaultWall
|
|
, sps0 $ PutWall (reverse $ rectNSWE d (d - 30) (30 - d) (- d)) defaultWall
|
|
, sps0 $ PutWall (reverse $ rectNSWE (- d) (30 - d) (d - 30) d) defaultWall
|
|
, sps0 $ PutWall (reverse $ rectNSWE (- d) (30 - d) (30 - d) (- d)) defaultWall
|
|
]
|
|
++ map
|
|
(\a -> mntLS vShape (rotateV a $ V2 0 d) (rotate3z a $ V3 0 (d + 30) 70))
|
|
[0, 0.5 * pi, pi, 1.5 * pi]
|
|
++ concatMap
|
|
(\r -> map (shiftPlacement (V2 0 0, r)) theDoor)
|
|
[0, pi / 2, pi, 3 * pi / 2]
|
|
, _rmBound = [rectNSWE h (- h) (- w) w]
|
|
, _rmName = "cenVault"
|
|
}
|
|
where
|
|
col = dim $ dim $ bright red
|
|
theDoor =
|
|
[ pContID (PS (V2 35 (d + 4)) 0) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $
|
|
\btid ->
|
|
jspsJ (V2 0 (d -10)) 0 (putSlideDr (thedoor btid) thewall 1 (V2 (-21) 0) (V2 0 0)) $
|
|
sPS (V2 0 (d -10)) 0 (putSlideDr (thedoor btid) thewall 1 (V2 21 0) (V2 0 0))
|
|
]
|
|
thewall = defaultDoorWall
|
|
thedoor btid = defaultDoor & drTrigger .~ WdBlBtOn btid
|