Files
loop/src/Dodge/Room/Room.hs
T
2022-05-20 21:15:44 +01:00

444 lines
17 KiB
Haskell

{-# LANGUAGE TupleSections #-}
module Dodge.Room.Room where
import Data.Tile
import Dodge.Data
import Dodge.PlacementSpot
import Dodge.RoomLink
import Dodge.Default.Room
import Dodge.Item.Weapon.BulletGuns
import Dodge.Creature
import Dodge.Room.Pillar
import Dodge.Room.Modify.Girder
import Dodge.LevelGen.Data
import Dodge.RandomHelp
import Dodge.Default.Wall
import Dodge.Tree
import Dodge.Placement.Instance
--import Dodge.LevelGen.Data
import Dodge.Room.Procedural
import Dodge.Room.Corridor
import Dodge.Room.Link
import Dodge.Room.Door
import Dodge.Room.Airlock
import Geometry
import Tile
import MonadHelp
import LensHelp
--import Color
import qualified Data.Set as S
import Control.Monad.State
--import Control.Monad.Loops
import System.Random
import Data.Tree
import Data.Bifunctor
roomC :: RandomGen g => Float -> Float -> State g Room
roomC w h = do
wl <- takeOne
[ sPS (V2 0 0) 0 $ PutWall (rectNSWE (h-60) 0 (w/2-10) (w/2+10)) defaultCrystalWall
, windowLine (V2 (w/2) 0) (V2 (w/2) (h-60))
]
randomiseAllLinks $ restrictOutLinks fromCond $ roomRectAutoLinks w h
& rmPmnts %~ (wl : )
& rmRandPSs .~ [farside]
where
fromCond (V2 x _,_) = x < w / 2 - 10
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] -> SubCompTree Room
branchWith r ts = Node (PassDown r) $ return (UseAll door) : fmap (fmap PassDown) ts
manyDoors :: Int -> SubCompTree Room
manyDoors i = treeFromPost (replicate i (PassDown door)) $ UseAll 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
plmnts =
[ windowLine (V2 (wth-60 ) hf ) (V2 wllen hf )
,windowLine (V2 (wth-wllen) (2*hf)) (V2 60 (2*hf))
,windowLine (V2 (wth-60 ) (3*hf)) (V2 wllen (3*hf))
,windowLine (V2 (wth-wllen) (4*hf)) (V2 60 (4*hf))
,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 (SubCompTree Room)
miniTree2 = (glassSwitchBackCrits
>>= randomiseAllLinks . restrictInLinks (\p -> (sndV2 . fst) p < 70))
<&> flip branchWith (replicate 3 $ treeFromPost [door,corridor] critInDeadEnd)
miniRoom3 :: RandomGen g => State g (SubCompTree Room)
miniRoom3 = do
w <- state $ randomR (300,400)
h <- state $ randomR (300,400)
let cp = V2 0 (h/2+40)
let b = PutBlock StoneBlock 5 [20,20] baseBlockPane $ map toV2 [(-10,-60)
,( 10,-60)
,( 10,-80)
,(-10,-80)
]
let plmnts =
[ sPS cp (fromIntegral i*pi/4) $ windowLineType (V2 0 (-40)) (V2 0 (-80))
| i <- [0..7::Int]
] ++
[ sPS cp (pi/8+fromIntegral i*pi/4) b
| i <- [0..7::Int]
] ++
[ sPS cp 0 $ PutCrit miniGunCrit
, sPS (V2 (w/2) (h/2)) 0 putLamp ]
fmap singleUseAll $ shuffleLinks $ set rmPmnts plmnts $ roomRectAutoLinks w h
rot90Around :: Point2 -> Point2 -> Point2
rot90Around cen p = cen +.+ vNormal (p -.- cen)
-- So, the idea is to attach outer children to the bottommost right nodes
-- inside an inner tree
roomMiniIntro :: RandomGen g => State g (LabSubCompTree Room)
roomMiniIntro = do
midroom <- join $ takeOne [miniTree2] --,glassLesson]
(return $ chainUses
[return $ UseAll corridor,return $ UseAll corridor,return $ UseAll corridor,return $ UseAll door, midroom,return $ UseAll corridor]
) <&> (,TreeSubLabelling "roomMiniIntro" Nothing)
roomCenterPillar :: RandomGen g => State g Room
roomCenterPillar = shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst)
$ 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 useUnusedLnk
, mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
]
roomOctogon :: Room
roomOctogon = defaultRoom
{ _rmPolys = [poly ]
, _rmLinks = muout (init lnks) ++ muin [last lnks]
, _rmPath = allPairs $ map fst lnks -- this is too much
, _rmPmnts = []
, _rmBound = [map toV2 [(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] ]
, _rmFloor = Tiled [makeTileFromPoly poly 7]
}
where
poly = map toV2 [(-20,40),(20,40),(50,70),(50,110),(20,140),(-20,140),(-50,110),(-50,70)]
lnks = map (first toV2)
[((0,140),0)
,((35,125),negate $ pi/4)
,((-35,125),pi/4)
,( (50,90),negate $ pi/2)
,( (-50,90),pi/2)
,((35,55),negate $ 3*pi/4)
,((-35,55),3*pi/4)
,( (0,40),pi)
]
allPairs :: Eq a => [a] -> [(a,a)]
allPairs xs = [(x,y) | x <- xs, y <- xs, x /= y]
{- Probabilites of the type of the first floor weapon. -}
randFirstWeapon :: State StdGen PSType
randFirstWeapon = do
takeOne $ map PutFlIt $
replicate 10 pistol
++ replicate 5 (bangStick 4)
++ replicate 5 (bangCaneX 3)
weaponEmptyRoom :: RandomGen g => State g (SubCompTree 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
--,sPS (V2 (w/2) (h/2)) 0 putLamp
,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 $ treeFromTrunk [PassDown corridor] (singleUseAll rm )
weaponUnderCrits :: RandomGen g => Int -> State g (LabSubCompTree Room)
weaponUnderCrits i = do
let plmnts =
[--sPS (V2 20 0) 0 $ RandPS randFirstWeapon
sPS (V2 20 0) (negate $ pi/2) randC1
,sPS (V2 20 20) ( pi/2) randC1
]
addwpat p = rmPmnts .:~ PickOnePlacement i (sPS p 0 $ RandPS randFirstWeapon)
let continuationRoom = treeFromTrunk
[PassDown $ addwpat (V2 20 0) corridorN,PassDown $ addwpat (V2 20 0) corridorN]
(singleUseAll (set rmPmnts plmnts corridorN))
rcp <- roomCenterPillar
rmpils <- roomPillars 30 240 240 2 2
deadEndRoom' <- takeOne
[ addwpat (V2 120 20) rmpils
, addwpat (V2 120 20) rcp]
junctionRoom <- takeOne [PassDown tEast,PassDown tWest]
let thetree = treeFromTrunk
--[PassDown $ corridorN & rmPmnts .:~ mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
[PassDown corridorN
,PassDown corridorN]
$ Node junctionRoom
[continuationRoom
,singleUseNone deadEndRoom'
]
return thetree
<&> (, TreeSubLabelling ("weaponUnderCrits "++show i) (Just $ fmap composingNodeName thetree))
composingNodeName :: ComposingNode Room -> TreeSubLabelling
composingNodeName cn = case cn of
PassDown rm -> f $ _rmName rm ++ "-PassDown"
SplitDown rm -> f $ _rmName rm ++ "-SplitDown"
UseAll rm -> f $ _rmName rm ++ "-UseAll"
UseSome is rm -> f $ _rmName rm ++ "-" ++ show is ++ "-UseSome"
UseNone rm -> f $ _rmName rm ++ "-UseNone"
UseLabel i rm -> f $ _rmName rm ++ "-" ++ show i ++ "-UseLabel"
where
f str = TreeSubLabelling str Nothing
weaponBehindPillar :: RandomGen g => State g (SubCompTree 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]
let d p = argV $ V2 120 80 -.- p
let plmnts1 =
[sPS wpos wpa $ RandPS randFirstWeapon
,sPS cpos (d cpos) randC1
]
rcp <- roomCenterPillar
return $ treeFromTrunk
[PassDown corridor
--,PassDown $ over rmOutLinks tail $ over rmPmnts (++ plmnts1) rcp
,PassDown $ over rmPmnts (++ plmnts1) rcp
]
(singleUseAll $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN)
weaponBetweenPillars :: RandomGen g => State g (SubCompTree Room)
weaponBetweenPillars = do
(w,wn) <- takeOne [(240,2),(340,3)]
(h,hn) <- takeOne [(240,2),(340,3)]
let wpPos = rprBool $ \rp r -> and
[ RoomPosOnPath `S.member` _rpType 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 ->
RoomPosOnPath `S.member` _rpType rp
&& _rpPlacementUse rp == 0
&& all ((>100) . dist (_rpPos rp)) (usedRoomLinkPoss r)
theRoom <- roomPillars 30 w h wn hn <&> rmPmnts .++~
sps wpPos (RandPS randFirstWeapon) : map (`sps` randC1) critPlacementSpots
return $ singleUseAll theRoom
weaponLongCorridor :: RandomGen g => State g (SubCompTree Room)
weaponLongCorridor = do
root <- 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 $ PassDown corridorN) (singleUseAll $ putCrs connectingRoom)
let branch2 = treeFromTrunk (replicate i2 $ PassDown corridorN) (singleUseNone $ putWp corridor)
return $ Node (PassDown root) [branch1,branch2]
where
putCrs = over rmPmnts (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ])
putWp = set rmPmnts [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)]
critInDeadEnd :: Room
critInDeadEnd = set rmPmnts [sPS (V2 0 0) 0 randC1] deadEndRoom
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 (LabSubCompTree Room)
weaponRoom i = join $ takeOne
[ weaponEmptyRoom <&> (,f "weaponEmptyRoom")
, weaponUnderCrits i
, weaponBehindPillar<&> (,f "weaponBehindPillar")
, weaponBetweenPillars<&> (,f "weaponBetweenPillars")
, weaponLongCorridor<&> (,f "weaponLongCorridor")
]
where
f str = TreeSubLabelling str Nothing
roomCCrits :: RandomGen g => State g Room
roomCCrits = roomC 200 200
<&> rmPmnts %~ (replicate 20 (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)) 0 $ PutCrit $ addArmour autoCrit
,sPS (V2 75 (h-30)) 0 $ PutCrit explosiveBarrel
,sPS (V2 75 (h-60)) 0 $ PutCrit explosiveBarrel
,sPS (V2 85 (h-10)) 0 $ PutCrit explosiveBarrel
,sPS (V2 85 (h-45)) 0 $ PutCrit explosiveBarrel
,sPS (V2 75 (h-80)) 0 putLamp
]
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]
++ )
pillarGrid :: RandomGen g => State g Room
pillarGrid = do
let f2 x y = singleBlock (V2 x y)
f <- takeOne [f2]
h <- state $ randomR (400,800)
let w = h
i <- takeOne [3,4,5]
let j = fromIntegral i
-- the 20+etc here is to correct for the pathfinding grid, which matches up to
-- edges based on the size of doors (i.e. the line next to the wall is 20
-- away from it)
xs = take i [20+0.5*(w-40)/j,20+1.5*(w-40)/j..]
ys = take i [20+0.5*(h-40)/j,20+1.5*(h-40)/j..]
gap = 0.5 * h / (j+1)
rps = do
x <- takeOne xs
y <- takeOne ys
a <- state $ randomR (0,2*pi)
return (V2 (x+gap) y,a)
-- the following was used to stop lights from being mounted in corners and
-- potentially overlapping, might want to redo
-- cornerRestrict (V2 x y,_)
-- = (x > 40 && x < h - 40)
-- || (y > 40 && y < h - 40)
let plmnts = replicate 8 (mntLightLnkCond useUnusedLnk)
++
concat [f x y | x<-xs,y<-ys]
return $ roomRect w h (max i 2) (max i 2)
& rmPmnts .~ plmnts
& rmRandPSs .~ [rps]
-- TODO remove possible identical draws on random PSs
pistolerRoom :: RandomGen g => State g Room
pistolerRoom = pillarGrid
<&> rmPmnts %~ (
[spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit pistolCrit)
,spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit pistolCrit)
,spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit pistolCrit)
]
++)
shootingRange :: RandomGen g => State g (LabSubCompTree Room)
shootingRange = do
rm1 <- shootersRoom1 >>= randomiseAllLinks . restrictInLinks (\(V2 _ y,_) -> y < 40)
. restrictOutLinks (\(V2 _ y,r) -> y > 200 && r /= 0)
rm2 <- shootersRoom >>= randomiseAllLinks
. restrictInLinks (\(V2 x y,_) -> y < 10 && x > 20 && x < 180)
. restrictOutLinks (\(V2 _ y,r) -> y > 200 && r /= 0)
rm3 <- shootersRoom >>= randomiseAllLinks
. restrictInLinks (\(V2 x y,_) -> y < 10 && x > 20 && x < 180)
. restrictOutLinks (\(_,r) -> r == 0)
(return $ treeFromPost
[PassDown rm1
,PassDown $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
& rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :)
,PassDown rm2
,PassDown $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
& rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :)
]
(UseAll rm3)
) <&> (,TreeSubLabelling "shootingRange" Nothing)
spawnerRoom :: RandomGen g => State g (SubCompTree Room)
spawnerRoom = do
x <- state $ randomR (250,300)
y <- state $ randomR (300,400)
roomWithSpawner <- roomC x y <&>
rmPmnts %~ (spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit spawnerCrit) :)
aRoom <- airlock
return $ treeFromTrunk [PassDown aRoom,PassDown corridor] $ singleUseAll roomWithSpawner