341 lines
13 KiB
Haskell
341 lines
13 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
module Dodge.Room.Room
|
|
( shootingRange
|
|
, weaponRoom
|
|
, roomMiniIntro
|
|
, roomCCrits
|
|
, doubleCorridorBarrels
|
|
, pistolerRoom
|
|
, spawnerRoom
|
|
, corDoor
|
|
) where
|
|
import Dodge.Cleat
|
|
import Dodge.Data
|
|
import Dodge.PlacementSpot
|
|
import Dodge.RoomLink
|
|
import Dodge.Default.Room
|
|
import Dodge.Item.Weapon
|
|
import Dodge.Creature
|
|
import Dodge.Room.Pillar
|
|
import Dodge.Room.Girder
|
|
import Dodge.Room.Modify.Girder
|
|
import Dodge.LevelGen.Data
|
|
import RandomHelp
|
|
import Dodge.Tree
|
|
import Dodge.Placement.Instance
|
|
--import Dodge.LevelGen.Data
|
|
import Dodge.Room.Procedural
|
|
import Dodge.Room.Corridor
|
|
import Dodge.Room.Tanks
|
|
import Dodge.Room.Link
|
|
import Dodge.Room.Door
|
|
import Dodge.Room.Airlock
|
|
import Geometry
|
|
import MonadHelp
|
|
import LensHelp
|
|
|
|
import qualified Data.Set as S
|
|
|
|
roomC :: RandomGen g => Float -> Float -> State g Room
|
|
roomC w h = do
|
|
wallf <- takeOne [ crystalLine , windowLine ]
|
|
ntanks <- takeOne [0,0,0,0,0,1,1,1,1,2,3,4]
|
|
thetank <- randomTank <&> plSpot .~ rprBool (\rp _ ->
|
|
_rpPlacementUse rp == 0
|
|
&& rpIsOffPath rp
|
|
&& (xV2 (_rpPos rp) > w / 2 + 5 || xV2 (_rpPos rp) < w / 2 - 5 ))
|
|
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)) : replicate ntanks thetank)
|
|
& 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 = [(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 .++~
|
|
[ spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit miniGunCrit)
|
|
, spNoID (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)
|
|
]
|
|
|
|
{- Probabilites of the type of the first floor weapon. -}
|
|
randFirstWeapon :: State StdGen PSType
|
|
randFirstWeapon = takeOne $ map PutFlIt $
|
|
replicate 10 pistol
|
|
++ replicate 5 (bangStick 4)
|
|
++ replicate 5 (bangCaneX 3)
|
|
++ replicate 5 bangCone
|
|
++ [lasGun]
|
|
|
|
weaponEmptyRoom :: RandomGen g => State g (Tree Room)
|
|
weaponEmptyRoom = do
|
|
w <- state $ randomR (220,300)
|
|
h <- state $ randomR (220,300)
|
|
let plmnts =
|
|
[sPS (V2 (w/2) (h-40)) 0 $ RandPS randFirstWeapon
|
|
,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 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 randFirstWeapon
|
|
,sPS cpos (argV $ V2 120 80 -.- cpos) randC1
|
|
]
|
|
, cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN
|
|
]
|
|
|
|
weaponBetweenPillars :: RandomGen g => State g (Tree Room)
|
|
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)
|
|
critPlacementSpots <- replicateM ncrits $ randDirPS $ rprBool $ \rp r ->
|
|
rpIsOnPath rp
|
|
&& _rpPlacementUse rp == 0
|
|
&& all ((>100) . dist (_rpPos rp)) (usedRoomLinkPoss r)
|
|
fmap pure $ roomPillars 30 w h wn hn
|
|
<&> rmPmnts .++~ sps wpPos (RandPS randFirstWeapon) : map (`sps` randC1) critPlacementSpots
|
|
<&> cleatOnward
|
|
|
|
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 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 = []
|
|
, _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 :: RandomGen g => Int -> State g (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 (spNoID (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 -> spNoID (PSRoomRand i (uncurry PS)) (PutCrit autoCrit))
|
|
[0,1,2])
|
|
|
|
shootersRoom :: RandomGen g => State g Room
|
|
shootersRoom = shootersRoom' <&> rmPmnts .++~
|
|
map (\i -> spNoID (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
|
|
(spNoID (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 .:~ spNoID
|
|
(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
|
|
return $ tToBTree "corDoor" $ treePost [door,cor]
|