271 lines
8.9 KiB
Haskell
271 lines
8.9 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
|
|
{- Rooms that contain two doors and a switch alternating both. -}
|
|
module Dodge.Room.Airlock where
|
|
|
|
import Control.Lens
|
|
import Control.Monad
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Data.Maybe
|
|
import Dodge.Data.GenWorld
|
|
import Dodge.Default.Door
|
|
import Dodge.Default.Room
|
|
import Dodge.Default.Wall
|
|
import Dodge.LevelGen.DoorPane
|
|
import Dodge.LevelGen.PlacementHelper
|
|
import Dodge.LevelGen.Switch
|
|
import Dodge.Placement.Instance
|
|
import Dodge.Placement.Instance.Analyser
|
|
import Dodge.Room.Foreground
|
|
import Dodge.Room.Path
|
|
import Dodge.RoomLink
|
|
import Geometry
|
|
import Picture
|
|
import RandomHelp
|
|
import ShapePicture
|
|
|
|
-- | A passage with a switch that opens forward access while closing backwards access.
|
|
airlock :: RandomGen g => State g Room
|
|
airlock =
|
|
join $
|
|
takeOne [return airlock0, return airlock90, return airlockCrystal, airlockZ]
|
|
|
|
xSwitch :: PSType
|
|
xSwitch = PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect
|
|
where
|
|
col = dim $ dim $ bright red
|
|
|
|
decontamRoom :: Int -> Room
|
|
decontamRoom i =
|
|
defaultRoom
|
|
& rmPolys .~ cutps
|
|
& rmLinks .~ muout lnks ++ muin [last lnks]
|
|
& rmPath .~ foldMap doublePairSet [(V2 20 95, V2 20 45), (V2 20 45, V2 20 5)]
|
|
& rmPmnts
|
|
.~ [ pContID (PS (V2 (-35) 50) (negate $ pi / 2)) xSwitch $
|
|
\btid -> Just $
|
|
putDoubleDoorThen defaultDoorWall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $
|
|
\_ _ -> Just $ putDoubleDoor defaultDoorWall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2
|
|
, invisibleWall $ rectNSWE 60 40 (-40) (-30)
|
|
, spanLightI (V2 (-20) 30) (V2 (-20) 70)
|
|
, analyser (NoItemZone ps) (PS 50 0) (PS mcpos 0) & plExternalID ?~ i
|
|
]
|
|
-- & rmOutPmnt . at i ?~
|
|
-- analyser (NoItemZone ps) (PS 50 0) (PS mcpos 0)
|
|
& rmInPmnt .~ [(0, return . f)]
|
|
& rmBound .~ [rectNSWE 75 15 0 40, switchcut]
|
|
where
|
|
f gw = fromMaybe (error "tried to put a door using an empty placement list") $ do
|
|
pmnt <- gw ^? genPmnt . ix i
|
|
return $
|
|
putDoubleDoor
|
|
defaultDoorWall
|
|
(cond pmnt)
|
|
(V2 (-10) 35)
|
|
(V2 (-10) 65)
|
|
2
|
|
cond pmnt = WdTrig $ pmnt ^?! plMID . _Just
|
|
mcpos = V2 70 50
|
|
cutps = [rectNSWE 100 0 0 40, switchcut]
|
|
ps = (\p -> p - mcpos) <$> orderPolygon (concat cutps)
|
|
switchcut = rectNSWE 65 35 (-40) 80
|
|
lnks =
|
|
[ (V2 20 95, 0)
|
|
, (V2 20 5, pi)
|
|
]
|
|
|
|
-- | Straight airlock
|
|
airlock0 :: Room
|
|
airlock0 =
|
|
defaultRoom
|
|
{ _rmPolys = [rectNSWE 100 0 0 40, switchcut]
|
|
, _rmLinks = muout lnks ++ muin [last lnks]
|
|
, _rmPath = foldMap doublePairSet [(V2 20 95, V2 20 45), (V2 20 45, V2 20 5)]
|
|
, _rmPmnts =
|
|
[ pContID (PS (V2 (-35) 50) (negate $ pi / 2)) xSwitch $
|
|
\btid -> Just $
|
|
putDoubleDoorThen defaultDoorWall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $
|
|
\_ _ -> Just $ putDoubleDoor defaultDoorWall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2
|
|
, invisibleWall $ rectNSWE 60 40 (-40) (-30)
|
|
, spanLightI (V2 (-2) 30) (V2 (-2) 70)
|
|
, sps0 $ putShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
|
|
]
|
|
, _rmBound = [rectNSWE 75 15 0 40, switchcut]
|
|
}
|
|
where
|
|
switchcut = rectNSWE 65 35 (-40) 20
|
|
lnks =
|
|
[ (V2 20 95, 0)
|
|
, (V2 20 5, pi)
|
|
]
|
|
|
|
airlockDoubleDoor ::
|
|
WdBl ->
|
|
Float ->
|
|
Point2A ->
|
|
Point2A ->
|
|
Point2A ->
|
|
Point2A ->
|
|
Maybe Placement
|
|
airlockDoubleDoor cond l x1 y1 x2 y2 = jsps0J (pd x1 y1) $ sps0 (pd x2 y2)
|
|
where
|
|
pd = putDoor cond l
|
|
|
|
putDoor :: WdBl -> Float -> Point2A -> Point2A -> PSType
|
|
putDoor cond l p1 p2 = PutDoor dr defaultDoorWall
|
|
where
|
|
dr =
|
|
defaultDoor
|
|
& drTrigger .~ cond
|
|
& drUpdate .~ DoorLerp 0.01
|
|
& drZeroPos .~ p1
|
|
& drOnePos .~ p2
|
|
& drFootPrint
|
|
.~ IM.fromDistinctAscList
|
|
(zip [0 ..] (loopPairs $ mkRectangle 9 (V2 l 0)))
|
|
|
|
airlockSimple :: RandomGen g => State g Room
|
|
airlockSimple = do
|
|
light1 <-
|
|
join $
|
|
takeOne
|
|
[ mntLightLnkCond $ PS (V2 90 120) 0
|
|
, mntLightLnkCond $ PS (V2 90 0) pi
|
|
, return $ spanLightI (V2 90 0) (V2 90 120)
|
|
, return $ spanLightI (V2 0 60) (V2 180 60)
|
|
, takeOne [30, 60, 90] <&> \x ->
|
|
spanLightY (V2 90 (120 - x)) (V2 (90 - x) 120) (V2 (90 + x) 120) (V2 90 0)
|
|
]
|
|
return $
|
|
defaultRoom
|
|
{ _rmPolys = [rectNSWE 120 0 0 180]
|
|
, _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks]
|
|
, _rmPath = foldMap (doublePairSet . (V2 90 30,) . fst) lnks
|
|
, _rmPmnts =
|
|
[ light1
|
|
, pContID (PS (V2 90 115) pi) xSwitch $
|
|
\btid ->
|
|
airlockDoubleDoor
|
|
(WdBlBtOn btid)
|
|
55
|
|
(0, pi / 2)
|
|
(0, 0)
|
|
(V2 180 0, pi)
|
|
(V2 180 0, pi / 2)
|
|
]
|
|
, _rmBound = [rectNSWE 120 0 0 180]
|
|
}
|
|
where
|
|
lnks =
|
|
[ (V2 0 30, pi / 2)
|
|
, (V2 180 30, 1.5 * pi)
|
|
]
|
|
|
|
airlockZ :: RandomGen g => State g Room
|
|
airlockZ = do
|
|
let cenlight =
|
|
[ mntLS vShape (V2 90 60) (V3 90 40 50)
|
|
, mntLS vShape (V2 90 60) (V3 90 80 50)
|
|
]
|
|
cornlight =
|
|
[ mntLS vShape (V2 0 120) (V3 30 90 50)
|
|
, mntLS vShape (V2 180 120) (V3 150 90 50)
|
|
, sps0 (putShape (thinHighBar 50 (V2 30 90) (V2 150 90)))
|
|
]
|
|
lighting <- takeOne [cenlight, cornlight]
|
|
return
|
|
defaultRoom
|
|
{ _rmPolys = [rectNSWE 120 0 0 180]
|
|
, _rmLinks = lnks
|
|
, _rmPath = linksDAGToPath lnks $ loopPairs $ rectNSWE 100 40 40 140
|
|
, _rmPmnts =
|
|
[ pContID (PS (V2 90 115) pi) xSwitch $
|
|
\btid ->
|
|
airlockDoubleDoor
|
|
(WdBlBtOn btid)
|
|
61
|
|
(V2 0 60, - pi / 2)
|
|
(V2 0 60, 0)
|
|
(V2 180 60, - pi)
|
|
(V2 180 60, - pi / 2)
|
|
, sps0 $ PutWall (reverse $ rectNSWE 70 50 60 120) defaultWall
|
|
]
|
|
<> lighting
|
|
, _rmBound = [rectNSWE 120 0 0 180]
|
|
}
|
|
where
|
|
lnks = muout [(V2 0 30, pi / 2)] ++ muin [(V2 180 30, 1.5 * pi)]
|
|
|
|
airlock90 :: Room
|
|
airlock90 =
|
|
defaultRoom
|
|
{ _rmPolys =
|
|
[ rectNSWE 100 10 10 100
|
|
, rectNSWE 20 (-0.1) 20 60
|
|
, rectNSWE 20 60 20 0
|
|
, map
|
|
toV2
|
|
[ (10, 100)
|
|
, (100, 150)
|
|
, (150, 100)
|
|
, (100, 10)
|
|
]
|
|
]
|
|
, _rmLinks = lnks
|
|
, _rmPath = linksDAGToPath lnks [(40,80)]
|
|
, _rmPmnts =
|
|
[ pContID
|
|
(PS (V2 120 120) (3 * pi / 4))
|
|
xSwitch
|
|
$ \btid ->
|
|
jsps (V2 5 5) 0 $
|
|
putDoor (WdBlBtOn btid) l1 x1 y1
|
|
& putDoorDoor . drMounts .~ themounts
|
|
-- , mntLS vShape (V2 35 35) (V3 70 70 50)
|
|
]
|
|
, _rmBound =
|
|
pure
|
|
[ V2 10 10
|
|
, V2 10 100
|
|
, V2 100 150
|
|
, V2 150 100
|
|
, V2 100 10
|
|
]
|
|
, _rmName = "airlock90"
|
|
}
|
|
where
|
|
themounts =
|
|
[ MountedLight (V3 hl hl 50) 150 0.5
|
|
, MountedLight (V3 hl (- hl) 50) 150 0.5
|
|
, MountedSPic . noPic $ thinHighBar 55 (V2 hl (- hl')) (V2 hl hl')
|
|
]
|
|
lnks = muout [(V2 0 40, pi / 2)] ++ muin [(V2 40 0, pi)]
|
|
hl = 27.5
|
|
hl' = 30
|
|
l1 = 55
|
|
y1 = (0, 0)
|
|
x1 = (0, pi / 2)
|
|
|
|
airlockCrystal :: Room
|
|
airlockCrystal =
|
|
defaultRoom
|
|
{ _rmPolys = [rectNSWE 140 0 0 40, switchcutout]
|
|
, _rmLinks = lnks
|
|
, _rmPath = linksDAGToPath lnks $ loopPairs [V2 20 40, V2 100 70, V2 20 110]
|
|
, _rmPmnts =
|
|
[ pContID
|
|
(PS (V2 145 70) (pi / 2))
|
|
xSwitch
|
|
$ \btid -> jsps (V2 40 70) 0 $ putDoor (WdBlBtOn btid) l1 x1 y1
|
|
, crystalLine (V2 5 70) (V2 25.5 70)
|
|
, mntLS vShape (V2 150 70) (V3 110 70 70)
|
|
]
|
|
, _rmBound = [rectNSWE 120 20 0 40, switchcutout]
|
|
}
|
|
where
|
|
lnks = muout [(V2 20 130, 0)] ++ muin [(V2 20 0, pi)]
|
|
switchcutout = orderPolygon $ map toV2 [(39, 20), (150, 60), (150, 80), (39, 120)]
|
|
l1 = 55
|
|
x1 = (0, pi / 2)
|
|
y1 = (V2 0 (-55), pi / 2)
|