336 lines
13 KiB
Haskell
336 lines
13 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
|
|
-- | Rooms containing long doors, probably with a big reveal behind them.
|
|
module Dodge.Room.LongDoor where
|
|
|
|
import Dodge.Placement.Instance.Block
|
|
import Dodge.Base.CardinalPoint
|
|
import Dodge.Room.Modify
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Dodge.Default
|
|
import Control.Monad
|
|
import Data.Maybe
|
|
import qualified Data.Set as S
|
|
import Dodge.Cleat
|
|
import Dodge.Creature
|
|
import Dodge.Data.GenWorld
|
|
import Dodge.Default.Door
|
|
import Dodge.Default.Room
|
|
import Dodge.Door.PutSlideDoor
|
|
import Dodge.LevelGen.PlacementHelper
|
|
import Dodge.LevelGen.Switch
|
|
import Dodge.LightSource
|
|
import Dodge.Placement.Instance
|
|
import Dodge.PlacementSpot
|
|
import Dodge.Room.Door
|
|
import Dodge.Room.Link
|
|
import Dodge.Room.Procedural
|
|
import Dodge.RoomLink
|
|
import Dodge.Terminal
|
|
import Dodge.Tree
|
|
import Geometry
|
|
import LensHelp
|
|
import Linear
|
|
import Picture
|
|
import RandomHelp
|
|
import ShapePicture
|
|
|
|
twinSlowDoorRoom ::
|
|
-- | Half width
|
|
Float ->
|
|
-- | Half height
|
|
Float ->
|
|
-- | Inner width
|
|
Float ->
|
|
Room
|
|
twinSlowDoorRoom w h x =
|
|
defaultRoom
|
|
{ _rmPolys = ps
|
|
, _rmLinks =
|
|
map
|
|
(uncurry outLink)
|
|
[ (V2 w (h / 2), negate $ pi / 2)
|
|
, (V2 (- w) (h / 2), pi / 2)
|
|
]
|
|
++ [inLink (V2 0 (- h)) pi]
|
|
, _rmPath = mempty
|
|
, _rmPmnts =
|
|
[ pContID (PS (V2 0 (h -5)) pi) (PutButton $ makeButton col NoWorldEffect) $
|
|
\btid -> jsps0J (putSlideDr (thedoor btid) thewall 1 (V2 x 1) (V2 x h)) $
|
|
ps0 (putSlideDr (thedoor btid) thewall 1 (V2 (- x) 1) (V2 (- x) h)) $
|
|
\_ -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h -1) lampheight))) $
|
|
const Nothing -- jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (WdBlDoorMoving did) (V2 0 (h -1)) lampheight
|
|
]
|
|
, _rmBound = ps
|
|
, _rmName = "twinSlowDoorRoom"
|
|
, _rmViewpoints = [V2 0 h]
|
|
}
|
|
where
|
|
--thewall = switchWallCol red
|
|
thewall = defaultDoorWall
|
|
lampheight = 41
|
|
ps =
|
|
[ rectNSWE h 0 (- w) w
|
|
, rectNSWE 20 (- h) (negate x) x
|
|
]
|
|
thedoor btid =
|
|
defaultDoor
|
|
& drUpdate . drLerpSpeed .~ 0.5
|
|
& drTrigger .~ WdBlBtOn btid
|
|
col = dim $ dim $ bright red
|
|
|
|
twinSlowDoorChasers :: RandomGen g => State g Room
|
|
twinSlowDoorChasers = do
|
|
ps <- takeN 4 $ [V2 x y | x <- [-65, 65], y <- [20, 40 .. 180]]
|
|
let plmnts = map (\p -> sPS p 0 $ PutCrit chaseCrit) ps
|
|
return $ twinSlowDoorRoom 80 200 40 & rmPmnts %~ (plmnts ++)
|
|
|
|
southPillarsRoom :: RandomGen g => Float -> Float -> Float -> State g Room
|
|
southPillarsRoom x y h = addSouthPillars x h =<< roomRectAutoLights x y
|
|
|
|
addSouthPillars :: RandomGen g => Float -> Float -> Room -> State g Room
|
|
addSouthPillars x h r = do
|
|
let pillarsa = []
|
|
pillarsb = concat [putBlockRect (i * x / 5 -20) (i * x / 5 + 20) (h / 2 -20) (h / 2 + 20) | i <- [1 .. 4]]
|
|
pillarsc = concat [putBlockRect (i * x / 3 -20) (i * x / 3 + 20) (h / 2 -20) (h / 2 + 20) | i <- [1, 2]]
|
|
pillars <- takeOne [pillarsa, pillarsb, pillarsc]
|
|
return $ r & rmPmnts .++~ pillars
|
|
|
|
-- should just be able to attach the mounts to the door directly
|
|
addButtonSlowDoor :: RandomGen g => Float -> Float -> Room -> State g Room
|
|
addButtonSlowDoor x h =
|
|
shuffleLinks
|
|
. setOutLinksPD (f (> h + 40))
|
|
. setInLinksPD (f (< h - 40))
|
|
. (rmPmnts <>~ [butDoor, theterminal])
|
|
. (rmBound .:~ openDoorBound)
|
|
where
|
|
f g y = g $ y ^. _1 . _y
|
|
theterminal =
|
|
putMessageTerminal (simpleTermMessage themessage)
|
|
& plSpot
|
|
.~ rprBoolShift
|
|
(isUnusedLnkType InLink)
|
|
(shiftByV2 (V2 0 (-10)) <&> (,S.singleton UsedPosLow))
|
|
themessage = ["WARNING:", "LARGE BIOMASS DETECTED"]
|
|
openDoorBound = reverse $ rectNSWE (h + 5) (h - 5) (3 * x / 2) (- x / 2)
|
|
butDoor = putLitButOnPos
|
|
(dim $ light red)
|
|
(rprBool (isUnusedLnkType InLink))
|
|
$ \btplmnt -> Just
|
|
. putDoubleDoorThen
|
|
defaultDoorWall
|
|
30
|
|
(V2 0 h)
|
|
(V2 x h)
|
|
(defaultDoor & drTrigger .~ WdBlBtOn (fromJust $ _plMID btplmnt)
|
|
& drUpdate . drLerpSpeed .~ 0.5)
|
|
$ \dr1 dr2 ->
|
|
Just
|
|
. sps0
|
|
. PutWorldUpdate
|
|
. const
|
|
. const
|
|
$ domount dr1 id . domount dr2 negate
|
|
domount drx g =
|
|
gwWorld . cWorld . lWorld . doors . ix (drx ^?! plMID . _Just)
|
|
. drMounts
|
|
.~ [ MountedSPic (noPic $ aBar 50 $ g <$> [V2 lsx 9, V2 lsx ly, lp])
|
|
, MountedLight (V3 (lx - 1) ly 50 & _xy %~ g) 200 0.5
|
|
]
|
|
lsx = 30
|
|
lp@(V2 lx ly) = V2 100 (-20)
|
|
|
|
makeDumbSwitch :: Int -> Button
|
|
makeDumbSwitch i = defaultButton & btEvent .~ ButtonDumbSwitch i
|
|
|
|
slowCrushRoom :: RandomGen g => State g Room
|
|
slowCrushRoom = do
|
|
rm <- shuffleLinks =<< roomRectAutoLights 220 100
|
|
let rm' = removeLights rm
|
|
& rmPmnts .~ [spanLightI (V2 0 60) (V2 35 100)
|
|
, spanLightI (V2 220 60) (V2 185 100)
|
|
]
|
|
crs <- takeOne [[]
|
|
, [sPS (V2 200 10) (0.8* pi) randC1]
|
|
, [sPS (V2 200 10) (0.8* pi) randC1 , sPS (V2 210 20) (0.8* pi) randC1]
|
|
, [sPS (V2 200 80) pi randC1]
|
|
, [sPS (V2 200 80) pi randC1 , sPS (V2 210 90) pi randC1]
|
|
]
|
|
return $ rm'
|
|
& rmBound .:~ rectNSWE 0 (-50) 0 220
|
|
& rmLinks %~ setOutLinks (\rl -> onside East $ rl ^. rlType)
|
|
& rmLinks %~ setInLinks (\rl -> onside West $ rl ^. rlType)
|
|
& rmPmnts <>~
|
|
[ps0 (PutTrigger False) $ \i -> Just $
|
|
pContID (apos West) (PutButton $ makeDumbSwitch i) $ \_ -> Just $
|
|
pContID (apos East) (PutButton $ makeDumbSwitch i) $ \_ -> Just $
|
|
sps0 (PutDoor (dr & drTrigger .~ WdTrig i) defaultDoorWall) & plIDCont . mapped . mapped ?~
|
|
sps0 (PutDoor (dr1 & drTrigger .~ WdTrig i) defaultDoorWall)
|
|
] <> crs
|
|
where
|
|
onside x s = (OnEdge x `S.member` s)
|
|
|| (OnEdge South `S.member` s && FromEdge x 0 `S.member` s)
|
|
|| (OnEdge North `S.member` s && FromEdge x 0 `S.member` s)
|
|
dr = defaultDoor
|
|
& drUpdate .~ DoorLerp 0.01
|
|
& drZeroPos .~ (V2 75 (-40), 0)
|
|
& drOnePos .~ (V2 75 50, 0)
|
|
& drFootPrint .~ IM.fromDistinctAscList (zip [0..] (loopPairs . reverse $ rectWH 34 50))
|
|
dr1 = dr
|
|
& drOnePos .~ (V2 145 (-40), 0)
|
|
& drZeroPos .~ (V2 145 50, 0)
|
|
apos edge = rprBool (t edge) & psSelect . mapped . mapped . _Just . _1 %~ f
|
|
f ps = case ps of
|
|
PS _ r -> ps & psRot +~ pi & psPos +~ rotateV r (V2 0 (-5))
|
|
_ -> ps
|
|
t edge rp _ = case _rpType rp of
|
|
UnusedLink s -> onside edge s
|
|
_ -> False
|
|
|
|
pushCaverns :: RandomGen g => State g Room
|
|
pushCaverns = do
|
|
rm <- shuffleLinks . removeLights =<< roomRectAutoLights 250 100
|
|
iside <- takeOne [North,South]
|
|
oside <- takeOne [North,South]
|
|
crs <- takeOne [[] ]
|
|
l <- takeOne
|
|
[ [MountedLight (V3 55 0 50) 200 0.5 , MountedSPic (noPic $ aBar 55 [V2 10 0,V2 60 0])]
|
|
, [MountedLight (V3 20 0 50) 200 0.5 , MountedSPic (noPic $ aBar 55 [V2 10 0,V2 22 0])]
|
|
, [MountedLight (V3 30 45 50) 200 0.5 , MountedSPic (noPic $ aBar 55 [V2 10 45,V2 32 45])]
|
|
, [MountedLight (V3 20 45 50) 200 0.5
|
|
, MountedSPic (noPic $ aBar 55 [V2 10 45,V2 60 45])
|
|
, MountedSPic (noPic $ aBar 55 [V2 10 (-45),V2 60 (-45)])]
|
|
]
|
|
let lts = [spanColLightI (V3 0.5 0 0) 40 (V2 5 (g iside)) (V2 10 (g iside - dorot' iside 10))
|
|
& plType . putLS . lsParam . lsRad .~ 30
|
|
,spanColLightI (V3 0.5 0 0) 40 (V2 245 (g oside)) (V2 240 (g oside - dorot' oside 10))
|
|
& plType . putLS . lsParam . lsRad .~ 30]
|
|
return $ rm
|
|
& rmPolys <>~ [dorot iside (trapTBH 20 10 10) & each +~ V2 20 (g iside)
|
|
,dorot oside (trapTBH 20 10 10) & each +~ V2 230 (g oside)]
|
|
& rmBound .~
|
|
rectNSWE 100 0 (-10) 260:
|
|
[dorot iside (trapTBH 20 10 10) & each +~ V2 20 (g iside)
|
|
,dorot oside (trapTBH 20 10 10) & each +~ V2 230 (g oside)]
|
|
& rmLinks %~ setInLinks (\rl -> slinks West iside $ rl ^. rlType)
|
|
& rmLinks %~ setOutLinks (\rl -> slinks East oside $ rl ^. rlType)
|
|
& rmPmnts <>~
|
|
[ps0 (PutTrigger False) $ \i -> Just $
|
|
pContID (spos (slinks West $ cardReverse iside) f) (PutButton $ makeDumbSwitch i) $ \_ -> Just $
|
|
pContID (spos (slinks East $ cardReverse oside) f) (PutButton $ makeDumbSwitch i) $ \_ -> Just $
|
|
sps0 (PutDoor (dr & drTrigger .~ WdTrig i
|
|
& drMounts .~ l) defaultDoorWall) & plIDCont . mapped . mapped ?~
|
|
sps0 (PutDoor (dr1 & drTrigger .~ WdTrig i
|
|
& drMounts .~ (l & each . moPos . _xy %~ rotateV pi)) defaultDoorWall)
|
|
, psPtPl (spos (slinks West $ cardReverse iside) f') (lowBlock Stone (greyN 0.5) 10 $ rectWH 20 10)
|
|
, psPtPl (spos (slinks East $ cardReverse oside) f') (lowBlock Stone (greyN 0.5) 10 $ rectWH 20 10)
|
|
]
|
|
<> lts
|
|
<> crs
|
|
where
|
|
dorot = \case
|
|
North -> id
|
|
_ -> fmap negate
|
|
dorot' = \case
|
|
North -> id
|
|
_ -> negate
|
|
slinks x y s = (FromEdge x 0 `S.member` s) && OnEdge y `S.member` s
|
|
dr = defaultDoor
|
|
& drUpdate .~ DoorLerp 0.005
|
|
& drZeroPos .~ (V2 (-5) 50, 0)
|
|
& drOnePos .~ (V2 145 50, 0)
|
|
& drFootPrint .~ IM.fromDistinctAscList (zip [0..] (loopPairs . reverse $ rectWH 10 47))
|
|
dr1 = dr
|
|
& drOnePos .~ (V2 255 50, 0)
|
|
& drZeroPos .~ (V2 105 50, 0)
|
|
f ps = case ps of
|
|
PS _ r -> ps & psRot +~ pi & psPos +~ rotateV r (V2 0 5)
|
|
_ -> ps
|
|
f' ps = case ps of
|
|
PS _ r -> ps & psRot +~ pi & psPos +~ rotateV r (V2 0 10)
|
|
_ -> ps
|
|
spos h f'' = rprBool (t' h) & psSelect . mapped . mapped . _Just . _1 %~ f''
|
|
t' h rp _ = case _rpType rp of
|
|
UnusedLink s -> h s
|
|
_ -> False
|
|
g = \case
|
|
North -> 0
|
|
_ -> 100
|
|
|
|
|
|
slowCrush90 :: RandomGen g => State g Room
|
|
slowCrush90 = do
|
|
rm <- shuffleLinks =<< roomRectAutoLights 170 100
|
|
(ilinks, olinks) <- shufflePair (cornlinks,onside West)
|
|
let rm' = removeLights rm
|
|
& rmPmnts .~ [spanLightI (V2 0 60) (V2 35 100)
|
|
, spanLightL (V2 120 39) (V2 170 39) (V2 120 0)
|
|
]
|
|
crs <- takeOne [[] ]
|
|
return $ rm'
|
|
& rmBound <>~ [rectNSWE 0 (-55) 0 110
|
|
, rectNSWE 100 40 170 220
|
|
]
|
|
& rmLinks %~ setOutLinks (\rl -> olinks $ rl ^. rlType)
|
|
& rmLinks %~ setInLinks (\rl -> ilinks $ rl ^. rlType)
|
|
& rmPmnts <>~
|
|
[ps0 (PutTrigger False) $ \i -> Just $
|
|
pContID (spos ilinks) (PutButton $ makeDumbSwitch i) $ \_ -> Just $
|
|
pContID (spos olinks) (PutButton $ makeDumbSwitch i) $ \_ -> Just $
|
|
sps0 (PutDoor (dr & drTrigger .~ WdTrig i) defaultDoorWall) & plIDCont . mapped . mapped ?~
|
|
sps0 (PutDoor (dr1 & drTrigger .~ WdTrig i) defaultDoorWall)
|
|
] <> crs
|
|
where
|
|
onside x s = (OnEdge x `S.member` s)
|
|
|| (OnEdge South `S.member` s && FromEdge x 0 `S.member` s)
|
|
|| (OnEdge North `S.member` s && FromEdge x 0 `S.member` s)
|
|
cornlinks s =
|
|
(OnEdge South `S.member` s && FromEdge East 0 `S.member` s)
|
|
|| (OnEdge East `S.member` s && FromEdge South 0 `S.member` s)
|
|
dr = defaultDoor
|
|
& drUpdate .~ DoorLerp 0.01
|
|
& drZeroPos .~ (V2 75 (-5), 0)
|
|
& drOnePos .~ (V2 75 50, 0)
|
|
& drFootPrint .~ IM.fromDistinctAscList (zip [0..] (loopPairs . reverse $ rectWH 34 50))
|
|
dr1 = dr
|
|
& drOnePos .~ (V2 190 70, 0)
|
|
& drZeroPos .~ (V2 140 70, 0)
|
|
& drFootPrint .~ IM.fromDistinctAscList (zip [0..] (loopPairs . reverse $ rectWH 30 29))
|
|
f ps = case ps of
|
|
PS _ r -> ps & psRot +~ pi & psPos +~ rotateV r (V2 0 (-5))
|
|
_ -> ps
|
|
spos h = rprBool (t' h) & psSelect . mapped . mapped . _Just . _1 %~ f
|
|
t' h rp _ = case _rpType rp of
|
|
UnusedLink s -> h s
|
|
_ -> False
|
|
|
|
slowDoorRoom :: RandomGen g => State g Room
|
|
slowDoorRoom = do
|
|
x <- state $ randomR (400, 800)
|
|
y <- state $ randomR (400, 800)
|
|
h <- state $ randomR (200, min (y -100) 500)
|
|
let n = 25
|
|
xs <- replicateM n $ state $ randomR (10, x -10)
|
|
ys <- replicateM n $ state $ randomR (h + 20, y)
|
|
rs <- replicateM n $ state $ randomR (0, 2 * pi)
|
|
let ps = zipWith V2 xs ys
|
|
xs' <- replicateM 5 $ state $ randomR (10, x -10)
|
|
ys' <- replicateM 5 $ state $ randomR (h + 20, y)
|
|
let crits = zipWith (\p r -> sPS p r randC1) ps rs
|
|
barrels = zipWith (\x' y' -> sPS (V2 x' y') 0 $ PutCrit explosiveBarrel) xs' ys'
|
|
proom <- southPillarsRoom x y h
|
|
addButtonSlowDoor x h (proom & rmPmnts <>~ (crits <> barrels))
|
|
|
|
slowDoorRoomRunPast :: RandomGen g => State g (MetaTree Room String)
|
|
slowDoorRoomRunPast = do
|
|
r <- slowDoorRoom
|
|
rToOnward "slowDoorRoomRunPast" $
|
|
treeFromTrunk [door] $
|
|
Node
|
|
r
|
|
[ pure $ cleatOnward door
|
|
, return (cleatLabel 0 $ door & rmConnectsTo .~ S.member InLink)
|
|
]
|