Files
loop/src/Dodge/Room/Room.hs
T
2022-03-14 20:39:23 +00:00

444 lines
17 KiB
Haskell

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.Item.Weapon.Launcher
import Dodge.Creature
import Dodge.Room.Foreground
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 qualified Data.Set as S
import Control.Monad.State
--import Control.Monad.Loops
import System.Random
import Data.Maybe
import Data.Tree
import Data.Bifunctor
import Data.List
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)]
}
roomPillars :: Room
roomPillars = roomRect 240 240 2 2
& rmPmnts .~ plmnts
where
plmnts = spanLightI (V2 120 24) (V2 120 216)
: mntLS vShape (V2 12 12) (V3 25 25 70)
: mntLS vShape (V2 228 228) (V3 215 215 70)
: sps0 (PutShape $ thinHighBar 75 (V2 26 25) (V2 120 25))
: sps0 (PutShape $ thinHighBar 75 (V2 214 215) (V2 120 215))
: g 180 150 90 60
f a x b y = putBlockRect a x b y
g a b c d = f a b a b ++ f a b c d ++ f c d a b ++ f c d c d
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]
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 (SubCompTree Room)
roomMiniIntro = do
midroom <- join $ takeOne [miniTree2] --,glassLesson]
return $ chainUses [return $ UseAll door, midroom,return $ UseAll corridor]
roomCenterPillar :: RandomGen g => State g Room
roomCenterPillar = randomiseAllLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst)
$ set rmPmnts plmnts $ roomRect 240 240 2 2
where
plmnts =
[ blockLine (V2 115 115) (V2 115 125)
, blockLine (V2 125 115) (V2 125 125)
--, sPS (V2 40 120) 0 putLamp
--, sPS (V2 200 120) 0 putLamp
, mntLightLnkCond useUnusedLnk
, mntLightLnkCond useUnusedLnk
]
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)
]
roomNgon :: Int -> Float -> Room
roomNgon n x = defaultRoom
{ _rmPolys = [poly]
, _rmLinks = map toBothLnk lnks -- muout (init lnks) ++ muin[last lnks]
, _rmPath = [] -- TODO
, _rmPmnts = [mntLightLnkCond $ resetPLUse $ rprBool $ const . isInLnk]
, _rmBound = [poly]
, _rmFloor = Tiled [makeTileFromPoly poly 9]
, _rmName = show n ++ "gon"
}
where
rot = 2*pi / fromIntegral n
rots = map ((rot *) . fromIntegral) [0..n-1]
poly = mapMaybe
(\(ra,rb) -> intersectLineLine' (rotateV ra bl) (rotateV ra br) (rotateV rb bl) (rotateV rb br))
$ loopPairs rots
bl = V2 x x
br = V2 (-x) x
lnks = sortOn ((\(V2 a b) -> (negate b,a)) . fst) $ map (\r -> (rotateV r (V2 0 x),r)) rots
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 ltAutoGun
++ replicate 5 spreadGun
++ replicate 5 multGun
++ replicate 2 autoGun
++ [launcher]
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 <- shuffleLinks $ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts)
return $ treeFromTrunk [PassDown corridor] (singleUseAll rm )
weaponUnderCrits :: RandomGen g => State g (SubCompTree Room)
weaponUnderCrits = do
let plmnts =
[--sPS (V2 20 0) 0 $ RandPS randFirstWeapon
sPS (V2 20 0) (negate $ pi/2) randC1
,sPS (V2 20 20) (negate $ pi/2) randC1
]
addwpat p = rmPmnts %~ ((PickOnePlacement 0 $ 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
deadEndRoom' <- takeOne
[ addwpat (V2 120 20) roomPillars
, addwpat (V2 120 20) rcp]
junctionRoom <- takeOne [PassDown tEast,PassDown tWest]
return $ treeFromTrunk [PassDown corridorN,PassDown corridorN]
$ Node junctionRoom
[continuationRoom
,singleUseNone deadEndRoom'
]
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
let wpPos = unusedSpotNearInLink 100
ncrits <- state $ randomR (1,3)
critPlacementSpots <- replicateM ncrits $ randDirPS $ unusedSpotAwayFromInLink 100
let theRoom = roomPillars & 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]
}
where
lnks = [(V2 0 30 ,0) ]
{- A random Either tree with a weapon and melee monster challenge. -}
weaponRoom :: RandomGen g => State g (SubCompTree Room)
weaponRoom = join $ takeOne
[ weaponEmptyRoom
, weaponUnderCrits
, weaponBehindPillar
, weaponBetweenPillars
, weaponLongCorridor
]
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 (SubCompTree 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)
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