385 lines
14 KiB
Haskell
385 lines
14 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
module Dodge.Room.Room (
|
|
shootingRange,
|
|
weaponRoom,
|
|
roomMiniIntro,
|
|
roomCCrits,
|
|
doubleCorridorBarrels,
|
|
pistolerRoom,
|
|
spawnerRoom,
|
|
corDoor,
|
|
) where
|
|
|
|
import qualified Data.Set as S
|
|
import Dodge.Cleat
|
|
import Dodge.Creature
|
|
import Dodge.Data.GenWorld
|
|
import Dodge.Default.Room
|
|
import Dodge.Item.Display
|
|
import Dodge.LevelGen.PlacementHelper
|
|
import Dodge.Placement.Instance
|
|
import Dodge.Placement.Random
|
|
import Dodge.PlacementSpot
|
|
import Dodge.Room.Airlock
|
|
import Dodge.Room.Corridor
|
|
import Dodge.Room.Door
|
|
import Dodge.Room.Foreground
|
|
import Dodge.Room.Girder
|
|
import Dodge.Room.Link
|
|
import Dodge.Room.Modify.Girder
|
|
import Dodge.Room.Pillar
|
|
import Dodge.Room.Procedural
|
|
import Dodge.RoomLink
|
|
import Dodge.Tree
|
|
import Geometry
|
|
import LensHelp
|
|
import MonadHelp
|
|
import RandomHelp
|
|
|
|
roomC :: RandomGen g => Float -> Float -> State g Room
|
|
roomC w h = do
|
|
wallf <- takeOne [crystalLine, windowLine]
|
|
maybeaddgird <- takeOne [return, addRandomGirderFrom West 0, addRandomGirderFrom North 0]
|
|
maybeaddgird
|
|
=<< shuffleLinks
|
|
( roomRectAutoLinks w h
|
|
& rmLinks
|
|
%~ ( setInLinks (\rl -> S.fromList [FromEdge East 0, OnEdge South] `S.isSubsetOf` _rlType rl)
|
|
. setOutLinks (\rl -> OnEdge West `S.member` _rlType rl)
|
|
)
|
|
& rmPmnts .:~ wallf (V2 (w / 2) 0) (V2 (w / 2) (h -60))
|
|
& rmPmnts .:~ sps0 (PutDecoration (highMesh (V2 0 0) (V2 0 h) 50))
|
|
& rmRandPSs .~ [farside]
|
|
)
|
|
where
|
|
farside = do
|
|
x <- state $ randomR (5, w / 2 - 20)
|
|
y <- state $ randomR (5, h - 70)
|
|
a <- state $ randomR (0, 2 * pi)
|
|
return (V2 x y, a)
|
|
|
|
roomPadCut :: [Point2] -> Point2 -> Room
|
|
roomPadCut ps p =
|
|
defaultRoom
|
|
{ _rmPolys = [ps]
|
|
, _rmLinks = muout [(p, 0)] ++ muin [(V2 0 0, pi)]
|
|
, _rmPath = doublePairSet (V2 0 0, p)
|
|
}
|
|
|
|
branchWith :: Room -> [Tree Room] -> Tree Room
|
|
branchWith r = Node r . (return (cleatOnward door) :)
|
|
|
|
glassSwitchBack :: RandomGen g => State g Room
|
|
glassSwitchBack = do
|
|
wth <- state $ randomR (200, 400)
|
|
hgt <- state $ randomR (400, 600)
|
|
wllen <- state $ randomR (60, wth / 2 -40)
|
|
let hf = hgt / 5
|
|
awindow h xl xr = windowLine (V2 xl h) (V2 xr h)
|
|
plmnts =
|
|
[ awindow hf (wth -60) wllen
|
|
, awindow (2 * hf) (wth - wllen) 60
|
|
, awindow (3 * hf) (wth -60) wllen
|
|
, awindow (4 * hf) (wth - wllen) 60
|
|
, blockLine (V2 0 (1 * hf)) (V2 wllen (1 * hf))
|
|
, blockLine (V2 (wth - wllen) (2 * hf)) (V2 wth (2 * hf))
|
|
, blockLine (V2 0 (3 * hf)) (V2 wllen (3 * hf))
|
|
, blockLine (V2 (wth - wllen) (4 * hf)) (V2 wth (4 * hf))
|
|
, sPS (V2 (wth / 2) (hgt / 2)) 0 putLamp
|
|
]
|
|
let northPSs = do
|
|
cry <- randomRanges [3 * hf + 10, 4 * hf -10, 4 * hf + 10, 5 * hf -10]
|
|
crx <- state $ randomR (wllen, wth - (wllen + 40))
|
|
return (V2 crx cry, 1.5 * pi)
|
|
midPS = return (V2 (wth -20) (hgt / 2 + 40), pi)
|
|
return $
|
|
roomRect wth hgt 2 4
|
|
& rmPmnts .~ plmnts
|
|
& rmRandPSs .~ [northPSs, midPS]
|
|
& rmName .~ "glassSwitchBack"
|
|
|
|
glassSwitchBackCrits :: RandomGen g => State g Room
|
|
glassSwitchBackCrits =
|
|
glassSwitchBack <&> rmPmnts
|
|
.++~ [ psPtPl (PSRoomRand 0 (uncurry PS)) (PutCrit miniGunCrit)
|
|
, psPtPl (PSRoomRand 1 (uncurry PS)) randC1
|
|
]
|
|
|
|
miniTree2 :: RandomGen g => State g (Tree Room)
|
|
miniTree2 = do
|
|
rm <- glassSwitchBackCrits >>= shuffleLinks . restrictInLinks (\p -> (sndV2 . fst) p < 70)
|
|
return $ branchWith rm (replicate 3 $ treePost [door, corridor, critInDeadEnd])
|
|
|
|
-- So, the idea is to attach outer children to the bottommost right nodes
|
|
-- inside an inner tree
|
|
-- no idea what was going on here...
|
|
roomMiniIntro :: RandomGen g => State g (MetaTree Room String)
|
|
roomMiniIntro = do
|
|
midroom <- join $ takeOne [miniTree2] --,glassLesson]
|
|
rToOnward "roomMiniIntro" midroom
|
|
|
|
roomCenterPillar :: RandomGen g => State g Room
|
|
roomCenterPillar = do
|
|
addHighGirder'
|
|
=<< ( shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst) $
|
|
cleatSide $
|
|
set rmPmnts plmnts $
|
|
set rmName "roomCenterPillar" $
|
|
roomRect 240 240 2 2
|
|
)
|
|
where
|
|
plmnts =
|
|
[ blockLine (V2 115 115) (V2 115 125)
|
|
, blockLine (V2 125 115) (V2 125 125)
|
|
, -- , mntLightLnkCond useUnusedLnk
|
|
mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
|
|
, mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isOutLnk rp)
|
|
]
|
|
|
|
weaponEmptyRoom :: State StdGen (Tree Room)
|
|
weaponEmptyRoom = do
|
|
w <- state $ randomR (220, 300)
|
|
h <- state $ randomR (220, 300)
|
|
wp <- randFirstWeapon
|
|
let plmnts =
|
|
[ sPS (V2 (w / 2) (h -40)) 0 $ PutFlIt wp
|
|
, sPS (V2 20 20) (pi / 2) randC1
|
|
, sPS (V2 (w -20) 20) (pi / 2) randC1
|
|
, mntLightLnkCond useUnusedLnk
|
|
]
|
|
f (V2 x y, a) = (a == pi && x > 25 && x < w - 25) || (a /= 0 && y > w - 30)
|
|
rm <-
|
|
addHighGirder >=> shuffleLinks $
|
|
restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts)
|
|
return $ treePost [corridor, cleatSide $ cleatOnward rm]
|
|
|
|
weaponUnderCrits :: RandomGen g => Int -> State g (MetaTree Room String)
|
|
weaponUnderCrits i = do
|
|
let addwpat p = rmPmnts .:~ PickOnePlacement i (sPS p 0 $ RandPS $ fmap PutFlIt randFirstWeapon)
|
|
continuationRoom =
|
|
treePost
|
|
[ addwpat (V2 20 0) corridorN
|
|
, addwpat (V2 20 0) corridorN
|
|
, cleatOnward $
|
|
corridorN & rmPmnts
|
|
.~ [ sPS (V2 20 0) (negate $ pi / 2) randC1
|
|
, sPS (V2 20 20) (pi / 2) randC1
|
|
]
|
|
]
|
|
rcp <- roomCenterPillar
|
|
rmpils <- roomPillars 30 240 240 2 2
|
|
deadEndRoom' <- takeOne [addwpat (V2 120 20) rmpils, addwpat (V2 120 20) $ cleatSide rcp]
|
|
junctionRoom <- takeOne [tEast, tWest]
|
|
rToOnward "weaponUnderCrits" $
|
|
treeFromTrunk [corridorN, corridorN] $
|
|
Node junctionRoom [continuationRoom, pure deadEndRoom']
|
|
|
|
weaponBehindPillar :: RandomGen g => State g (Tree Room)
|
|
weaponBehindPillar = do
|
|
wpa <- state $ randomR (0, pi)
|
|
wpos <- takeOne [V2 120 160, V2 80 40, V2 160 40, V2 220 200, V2 40 200, V2 120 35]
|
|
cpos <- takeOne $ [V2 x y | x <- [20, 220], y <- [20, 40]] ++ [V2 120 160, V2 120 200]
|
|
rcp <- roomCenterPillar
|
|
return $
|
|
treePost
|
|
[ corridor
|
|
, rcp & rmPmnts
|
|
++.~ [ sPS wpos wpa $ RandPS $ fmap PutFlIt randFirstWeapon
|
|
, sPS cpos (argV $ V2 120 80 -.- cpos) randC1
|
|
]
|
|
, cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi / 2) randC1] corridorN
|
|
]
|
|
|
|
weaponBetweenPillars :: State StdGen (MetaTree Room String)
|
|
weaponBetweenPillars = do
|
|
(w, wn) <- takeOne [(240, 2), (340, 3)]
|
|
(h, hn) <- takeOne [(240, 2), (340, 3)]
|
|
let wpPos = rprBool $ \rp r ->
|
|
and
|
|
[ rpIsOnPath rp
|
|
, _rpPlacementUse rp == 0
|
|
, _rpLinkStatus rp == NotLink
|
|
, any ((< 100) . dist (_rpPos rp)) (usedRoomInLinkPoss r)
|
|
]
|
|
ncrits <- state $ randomR (1, 3)
|
|
wp <- randFirstWeapon
|
|
critPlacementSpots <- replicateM ncrits $
|
|
randDirPS $
|
|
rprBool $ \rp r ->
|
|
rpIsOnPath rp
|
|
&& _rpPlacementUse rp == 0
|
|
&& all ((> 100) . dist (_rpPos rp)) (usedRoomLinkPoss r)
|
|
( roomPillars 30 w h wn hn
|
|
<&> rmPmnts .++~ map (`sps` randC1) critPlacementSpots ++ [sps wpPos (PutFlIt wp)]
|
|
<&> cleatOnward
|
|
)
|
|
>>= rToOnward ("weaponBetweenPillars_" ++ itemString wp) . pure
|
|
|
|
weaponLongCorridor :: RandomGen g => State g (Tree Room)
|
|
weaponLongCorridor = do
|
|
rt <- takeOne [tEast, tWest]
|
|
connectingRoom <- takeOne [tEast & rmPmnts .~ [spanLightI (V2 (-30) 40) (V2 (-30) 80)]]
|
|
i1 <- state $ randomR (2, 5)
|
|
i2 <- state $ randomR (2, 5)
|
|
let branch1 =
|
|
treeFromTrunk
|
|
(replicate i1 corridorN)
|
|
(pure . cleatSide . cleatOnward $ putCrs connectingRoom)
|
|
let branch2 = treeFromTrunk (replicate i2 corridorN) (pure . cleatSide $ putWp corridor)
|
|
return $ Node rt [branch1, branch2]
|
|
where
|
|
putCrs = rmPmnts .++~ [sPS (V2 10 40) (- pi / 2) randC1, sPS (V2 (-10) 40) (- pi / 2) randC1]
|
|
putWp = rmPmnts .~ [sPS (V2 20 60) 0 $ RandPS $ fmap PutFlIt randFirstWeapon, spanLightI (V2 0 40) (V2 40 40)]
|
|
|
|
critInDeadEnd :: Room
|
|
critInDeadEnd = deadEndRoom & rmPmnts .~ [sPS (V2 0 0) 0 randC1]
|
|
|
|
deadEndRoom :: Room
|
|
deadEndRoom =
|
|
defaultRoom
|
|
{ _rmPolys = [rectNSWE 40 (-20) (-20) 20]
|
|
, _rmLinks = muout (init lnks) ++ muin [last lnks]
|
|
, _rmPath = mempty
|
|
, _rmPmnts = [sPS (V2 0 (-10)) 0 putLamp]
|
|
, _rmBound = [rectNSWE 20 (-20) (-30) 30]
|
|
, _rmName = "deadEndRoom"
|
|
}
|
|
where
|
|
lnks = [(V2 0 30, 0)]
|
|
|
|
{- A random Either tree with a weapon and melee monster challenge. -}
|
|
weaponRoom :: Int -> State StdGen (MetaTree Room String)
|
|
weaponRoom i =
|
|
join $
|
|
takeOne
|
|
[ weaponEmptyRoom >>= rToOnward "weaponEmptyRoom"
|
|
, weaponUnderCrits i -- this int is used for PickOnePlacement
|
|
, weaponBehindPillar >>= rToOnward "weaponBehindPillar"
|
|
, weaponBetweenPillars -- >>= rToOnward "weaponBetweenPillars"
|
|
, weaponLongCorridor >>= rToOnward "weaponLongCorridor"
|
|
]
|
|
|
|
roomCCrits :: RandomGen g => Int -> State g Room
|
|
roomCCrits i =
|
|
roomC 200 200
|
|
<&> rmPmnts .++~ replicate i (psPtPl (PSRoomRand 0 (uncurry PS)) randC1)
|
|
|
|
doubleCorridorBarrels :: RandomGen g => State g Room
|
|
doubleCorridorBarrels = do
|
|
h <- state $ randomR (200, 300)
|
|
let cond x = (sndV2 . fst) x < h - 40
|
|
return $
|
|
restrictInLinks cond $
|
|
roomRect 100 h 1 1 & rmPmnts
|
|
.~ [ blockLine (V2 50 50) (V2 50 h)
|
|
, sPS (V2 25 (h -25)) (negate pi / 2) $ PutCrit $ addArmour autoCrit
|
|
, sPS (V2 75 (h -80)) 0 putLamp
|
|
]
|
|
++ [ sPS p 0 $ PutCrit explosiveBarrel
|
|
| p <- [V2 75 (h -30), V2 75 (h -60), V2 85 (h -10), V2 85 (h -45)]
|
|
]
|
|
|
|
shootersRoom' :: RandomGen g => State g Room
|
|
shootersRoom' = do
|
|
w <- state $ randomR (200, 300)
|
|
x1 <- state $ randomR (20, w / 3 -20)
|
|
x2 <- state $ randomR (w / 3 + 20, 2 * w / 3 -20)
|
|
x3 <- state $ randomR (2 * w / 3 + 20, w -20)
|
|
y1 <- state $ randomR (280, 550)
|
|
y2 <- state $ randomR (280, 550)
|
|
y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (280, 560)
|
|
x4 <- state $ randomR (60, w -60)
|
|
y4 <- state $ randomR (40, 150)
|
|
let bln x y = putBlockN (x + 25) (x -25) (y + 20) (y + 10)
|
|
blv x y = putBlockV (x + 25) (x -25) (y + 20) (y + 10)
|
|
plmnts =
|
|
bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
|
|
++ [ spanLightI (V2 (-10) 200) (V2 (w / 2) 200)
|
|
, spanLightI (V2 (w / 2) 200) (V2 (w + 10) 200)
|
|
]
|
|
toPS x y = return (V2 x y, -0.5 * pi)
|
|
return $
|
|
set rmPmnts plmnts $
|
|
roomRectAutoLinks w 600
|
|
& rmPmnts .~ plmnts
|
|
& rmRandPSs .~ [toPS x1 y1, toPS x2 y2, toPS x3 y3]
|
|
|
|
shootersRoom1 :: RandomGen g => State g Room
|
|
shootersRoom1 =
|
|
shootersRoom' <&> rmPmnts
|
|
.:~ RandomPlacement
|
|
( takeOne $
|
|
map
|
|
(\i -> psPtPl (PSRoomRand i (uncurry PS)) (PutCrit autoCrit))
|
|
[0, 1, 2]
|
|
)
|
|
|
|
shootersRoom :: RandomGen g => State g Room
|
|
shootersRoom =
|
|
shootersRoom' <&> rmPmnts
|
|
.++~ map (\i -> psPtPl (PSRoomRand i (uncurry PS)) (PutCrit autoCrit)) [0, 1, 2]
|
|
|
|
-- TODO stop from spawning on inlinks fromedge
|
|
pistolerRoom :: RandomGen g => State g Room
|
|
pistolerRoom = do
|
|
(w, wn) <- takeOne [(200, 3), (255, 4)]
|
|
roomPillars 10 w 200 wn 3 <&> rmPmnts
|
|
.++~ replicate
|
|
3
|
|
( psPtPl
|
|
(rprBool $ \rp _ -> _rpPlacementUse rp == 0 && rpIsOnPath rp)
|
|
(PutCrit pistolCrit)
|
|
)
|
|
|
|
shootingRange :: RandomGen g => State g (MetaTree Room String)
|
|
shootingRange = do
|
|
rm1 <-
|
|
shootersRoom1
|
|
>>= shuffleLinks . restrictInLinks (\(V2 _ y, _) -> y < 40)
|
|
. restrictOutLinks (\(V2 _ y, r) -> y > 200 && r /= 0)
|
|
rm2 <-
|
|
shootersRoom
|
|
>>= shuffleLinks
|
|
. restrictInLinks (\(V2 x y, _) -> y < 10 && x > 20 && x < 180)
|
|
. restrictOutLinks (\(V2 _ y, r) -> y > 200 && r /= 0)
|
|
rm3 <-
|
|
shootersRoom
|
|
>>= shuffleLinks
|
|
. restrictInLinks (\(V2 x y, _) -> y < 10 && x > 20 && x < 180)
|
|
. restrictOutLinks (\(_, r) -> r == 0)
|
|
let padcutroom =
|
|
roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
|
|
& rmPmnts .:~ spanLightI (V2 (-80) 10) (V2 80 10)
|
|
rToOnward "shootingRange" $
|
|
treePost
|
|
[ rm1
|
|
, padcutroom
|
|
, rm2
|
|
, padcutroom
|
|
, cleatOnward rm3
|
|
]
|
|
|
|
spawnerRoom :: RandomGen g => State g (Tree Room)
|
|
spawnerRoom = do
|
|
x <- state $ randomR (250, 300)
|
|
y <- state $ randomR (300, 400)
|
|
roomWithSpawner <-
|
|
roomC x y <&> rmPmnts
|
|
.:~ psPtPl
|
|
( rprBool $ \rp _ ->
|
|
_rpPlacementUse rp == 0 && rpIsOnPath rp
|
|
&& xV2 (_rpPos rp) < x / 2
|
|
&& yV2 (_rpPos rp) < y / 2
|
|
)
|
|
(PutCrit spawnerCrit)
|
|
aRoom <- airlock
|
|
return $ treeFromTrunk [aRoom, corridor] $ pure $ cleatOnward roomWithSpawner
|
|
|
|
corDoor :: State StdGen (MetaTree Room String)
|
|
corDoor = do
|
|
cor <- shuffleLinks (cleatOnward corridor) <&> rmPmnts .~ []
|
|
return $ tToBTree "corDoor" $ treePost [door, cor]
|
|
|
|
-- cor <- shuffleLinks corridor
|
|
-- return $ tToBTree "corDoor" $ treePost [door,cor,cleatOnward door]
|