564 lines
21 KiB
Haskell
564 lines
21 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Dodge.Room.LasTurret (
|
|
analyserByNthLink,
|
|
analyserByDoor,
|
|
lasCenSensEdge,
|
|
lasTunnelRunPast,
|
|
keyCardRoomRunPast,
|
|
lasSensorTurretTest,
|
|
healthTest,
|
|
lasRunYinYangCenter,
|
|
lasRunYinYang,
|
|
lasCenRunClose',
|
|
lasCenRunClose1,
|
|
lasCenRunCloseLongCor,
|
|
lasRunRand,
|
|
storeRoomID,
|
|
) where
|
|
|
|
import Dodge.Room.Warning
|
|
import Dodge.Room.Modify
|
|
import Color
|
|
import Control.Monad
|
|
import Data.Foldable
|
|
import Data.Maybe
|
|
-- import Data.Foldable (fold)
|
|
|
|
import qualified Data.Set as S
|
|
import Dodge.Cleat
|
|
import Dodge.Data.GenWorld
|
|
import Dodge.Default.Room
|
|
import Dodge.LevelGen.PlacementHelper
|
|
import Dodge.Placement.Instance
|
|
import Dodge.Placement.Instance.Analyser
|
|
import Dodge.PlacementSpot
|
|
import Dodge.Room.Corridor
|
|
import Dodge.Room.Door
|
|
import Dodge.Room.Link
|
|
import Dodge.Room.Ngon
|
|
import Dodge.Room.Path
|
|
import Dodge.Room.Procedural
|
|
import Dodge.Room.SensorDoor
|
|
import Dodge.RoomLink
|
|
import Dodge.Tree
|
|
import Dodge.Wire
|
|
import Geometry
|
|
import LensHelp
|
|
import RandomHelp
|
|
import Shape
|
|
|
|
-- no lights!
|
|
cenLasTur :: (RandomGen g) => State g Room
|
|
cenLasTur =
|
|
roomNgon 8 200
|
|
<&> rmPmnts
|
|
.~ [ putLasTurret 0.02
|
|
, heightWallPS
|
|
(resetPLUse $ rprBoolShift (const . isInLnk) (shiftInBy 120 <&> (,S.singleton UsedPosLow)))
|
|
30
|
|
(rectWH 20 10)
|
|
]
|
|
<&> rmPath
|
|
%~ addNodesCrossingCirc 0 30
|
|
|
|
lightSensInsideDoor :: Int -> Room -> Room
|
|
lightSensInsideDoor i =
|
|
rmPmnts
|
|
.++~ [ psPt atFstLnkOut (PutForeground $ floorWire (V2 20 0) (V2 20 (-x)))
|
|
, psPt atFstLnkOut (PutForeground $ floorWire (V2 0 (-x)) (V2 20 (-x)))
|
|
, psPt atFstLnkOut (PutForeground $ verticalWire (V2 20 0) 0 80)
|
|
, sensAboveDoor LaserSensor 10 (atFstLnkOutShiftInward x) & plExternalID ?~ i
|
|
]
|
|
where
|
|
x = 120
|
|
|
|
-- & rmOutPmnt . at i ?~ sensAboveDoor LaserSensor 10 (atFstLnkOutShiftInward 100)
|
|
|
|
lightSensByDoor :: Int -> Room -> State LayoutVars Room
|
|
lightSensByDoor i rm = do
|
|
x <- takeOne [100, 120, 140]
|
|
y <- takeOne [100, 110, 120]
|
|
sh1 <- takeOne [rectWH 20 10, square 20]
|
|
return $
|
|
rm
|
|
& rmPmnts
|
|
.++~ [ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80
|
|
, heightWallPS (atNthLnkOutShiftInward 1 x) 30 sh1
|
|
, heightWallPS (atFstLnkOutShiftInward y) 30 (rectWH 20 10)
|
|
, sensAboveDoor LaserSensor 20 (atFstLnkOutShiftBy sensorshift) & plExternalID ?~ i
|
|
]
|
|
where
|
|
sensorshift (p, a) = ((p +.+ rotateV a (V2 60 (-20)), a), S.singleton UsedPosLow)
|
|
|
|
keyCardRoomRunPast :: (RandomGen g) => Int -> Int -> State g (MetaTree Room String)
|
|
keyCardRoomRunPast keyid rmid = do
|
|
cenroom <- shuffleLinks . keyCardAnalyserByDoor keyid rmid =<< roomNgon 6 200
|
|
let doorroom = triggerDoorRoom rmid
|
|
rToOnward "keyCardRoomRunPast" $
|
|
treeFromTrunk [door] $
|
|
Node
|
|
cenroom
|
|
[ treeFromPost [doorroom] (cleatOnward door)
|
|
, treeFromPost [door] (cleatLabel rmid corridor)
|
|
]
|
|
|
|
keyCardAnalyserByDoor :: Int -> Int -> Room -> Room
|
|
keyCardAnalyserByDoor keyid = analyserByDoor (RequireEquipment (HELD (KEYCARD keyid)))
|
|
|
|
healthAnalyserByDoor :: Int -> Room -> Room
|
|
healthAnalyserByDoor = analyserByDoor (RequireHealth 1100)
|
|
|
|
analyserByNthLink :: Int -> ProximityRequirement -> Int -> Placement
|
|
analyserByNthLink n proxreq i =
|
|
analyser
|
|
(SensorWithRequirement proxreq)
|
|
-- (byNthLink n)
|
|
( atNthLnkOutShiftBy
|
|
n
|
|
( \(p, a) ->
|
|
((p +.+ rotateV a (V2 18.5 (-2.5)), a), S.singleton UsedPosLow)
|
|
)
|
|
)
|
|
(byNthLink n)
|
|
-- (atNthLnkOutShiftBy n sensorshift)
|
|
& plExternalID
|
|
?~ i
|
|
where
|
|
sensorshift (p, a) = ((p +.+ rotateV a (V2 (-30) (-10)), a), S.singleton UsedPosLow)
|
|
|
|
analyserByDoor :: ProximityRequirement -> Int -> Room -> Room
|
|
analyserByDoor pr i = rmPmnts .:~ analyserByNthLink 0 pr i
|
|
|
|
healthTest :: (RandomGen g) => Int -> State g (Tree Room)
|
|
healthTest n = do
|
|
cenroom <- shuffleLinks . healthAnalyserByDoor n =<< roomNgon 8 200
|
|
return $
|
|
treePost
|
|
[ door
|
|
, corridor -- & rmPmnts .:~ psPtPl (PS 20 0) (PutFlIt (medkit 100))
|
|
, cenroom
|
|
, triggerDoorRoom n
|
|
, cleatOnward door
|
|
]
|
|
|
|
lasSensorTurretTest :: State LayoutVars (MetaTree Room String)
|
|
lasSensorTurretTest = do
|
|
n <- nextLayoutInt
|
|
cenroom' <- shuffleLinks . lightSensInsideDoor n =<< cenLasTur
|
|
(i, cenroom'') <- storeRoomID cenroom'
|
|
lshape <- takeOne [vShape, lShape, jShape, liShape]
|
|
let alight a rp = mntLSCond (fmap (fmap $ colorSH black) lshape) (PS (rotateV a $ _rpPos rp) (a + _rpDir rp))
|
|
let cenroom =
|
|
cenroom''
|
|
& rmInPmnt
|
|
<>~ [ (0, return . alight pi . f i)
|
|
, (0, return . alight (0.5 * pi) . f i)
|
|
, (0, return . alight (1.5 * pi) . f i)
|
|
]
|
|
rToOnward "lasSensorTurretTest" $
|
|
treePost
|
|
[door, cenroom, triggerDoorRoom n, cleatOnward door]
|
|
where
|
|
f i gw = fromJust $ find (isused . _rpType) (getRoomFromID i gw ^. rmPos)
|
|
isused UsedOutLink{_rplsChildNum = 0} = True
|
|
isused _ = False
|
|
|
|
-- note the double usage of the int, shouldn't cause a problem
|
|
lasCenSensEdge :: Int -> State LayoutVars (MetaTree Room String)
|
|
lasCenSensEdge n = do
|
|
(i, cenroom') <- storeRoomID =<< shuffleLinks =<< lightSensByDoor n =<< cenLasTur
|
|
lshape <- takeOne [vShape, lShape, jShape, liShape]
|
|
let alight a rp = mntLSCond (fmap (fmap $ colorSH black) lshape) (PS (rotateV a $ _rpPos rp) (a + _rpDir rp))
|
|
blight a = (0, return . alight a . f i)
|
|
let cenroom = cenroom' & rmInPmnt <>~ map blight [pi, 0.5 * pi, 1.5 * pi]
|
|
let doorroom = triggerDoorRoom n
|
|
rToOnward "lasCenSensEdge" $
|
|
treeFromTrunk [door] $
|
|
Node
|
|
cenroom
|
|
[ treePost [doorroom, cleatOnward door]
|
|
, treePost [door, cleatLabel n corridor]
|
|
]
|
|
where
|
|
f i gw = fromJust $ find (isused . _rpType) (getRoomFromID i gw ^. rmPos)
|
|
isused UsedOutLink{_rplsChildNum = 0} = True
|
|
isused _ = False
|
|
|
|
|
|
lasRunYinYang :: (RandomGen g) => State g (MetaTree Room String)
|
|
lasRunYinYang = do
|
|
npoly <- takeOne [6, 8, 10, 12]
|
|
thelight <- mntLightLnkCond $ rprBool $ const . isInLnk
|
|
thelight1 <- mntLightLnkCond $ rprBool $ const . isOutLnk
|
|
thelight2 <-
|
|
mntLightLnkCond $
|
|
rprBool $
|
|
const
|
|
. ( \rp ->
|
|
PolyEdge ((npoly + 1) `div` 4)
|
|
`S.member` fold (rp ^? rpType . rplsType)
|
|
)
|
|
thelight3 <-
|
|
mntLightLnkCond $
|
|
rprBool $
|
|
const
|
|
. ( \rp ->
|
|
PolyEdge (3 * (npoly + 1) `div` 4)
|
|
`S.member` fold (rp ^? rpType . rplsType)
|
|
)
|
|
r <-
|
|
shuffleLinks
|
|
=<< ( roomNgon npoly 250
|
|
<&> rmPmnts
|
|
.~ [angwall a | a <- [0, pi / 8 .. pi - pi / 9]]
|
|
<> [bngwall a | a <- [0, pi / 8 .. pi - pi / 9]]
|
|
<> [ awall 0 (rectWH 15 5)
|
|
, putLasTurret 0.02 & plSpot . psPos .~ negate offxy
|
|
, putLasTurret 0.02 & plSpot . psPos .~ offxy
|
|
, -- , awall (V2 0 50) (square 10)
|
|
thelight
|
|
, thelight1
|
|
, thelight2
|
|
, thelight3
|
|
]
|
|
<&> rmPath
|
|
%~ ( addNodesCrossingCirc 0 30
|
|
. flip (foldr ($)) [apath a | a <- [0, pi / 8 .. pi - 2 * pi / 9]]
|
|
. flip (foldr ($)) [bpath a | a <- [0, pi / 8 .. pi - 2 * pi / 9]]
|
|
)
|
|
<&> rmLinks
|
|
%~ setInLinksByType (PolyEdge 0)
|
|
<&> rmLinks
|
|
%~ setOutLinksByType (PolyEdge (npoly `div` 2))
|
|
)
|
|
rToOnward "lasCenRunClose" $ return $ cleatOnward r
|
|
where
|
|
awall x = heightWallPS (PS x 0) 30
|
|
-- angwall a = awall (V2 0 100 + rotateV a (V2 0 100)) (fmap (rotateV (pi/4 + a/2)) $ rectWH 5 (25 - a*10/pi ))
|
|
rf = 0.8
|
|
offxy = V2 0 (-100)
|
|
angwall a = awall (V2 0 100 + rotateV a (V2 0 100)) (rotateV (pi / 4 + a * rf) <$> rectWH 5 (23 - a * 13 / pi))
|
|
apath a' = addNodesCrossing $ (\x -> (x + f (V2 0 100), x - f (V2 0 100))) (V2 0 100 + rotateV a (V2 0 100))
|
|
where
|
|
a = a' + pi / 16
|
|
f = rotateV (pi / 4 + a * 0.8)
|
|
bngwall a = awall (V2 0 (-100) + rotateV a (V2 0 (-100))) (rotateV (pi / 4 + a * rf) <$> rectWH 5 (23 - a * 13 / pi))
|
|
bpath a' = addNodesCrossing $ (\x -> (x + f (V2 0 100), x - f (V2 0 100))) (V2 0 (-100) + rotateV a (V2 0 (-100)))
|
|
where
|
|
a = a' + pi / 16
|
|
f = rotateV (pi / 4 + a * 0.8)
|
|
|
|
lasRunYinYangCenter :: (RandomGen g) => State g (MetaTree Room String)
|
|
lasRunYinYangCenter = do
|
|
npoly <- takeOne [6, 8, 10, 12]
|
|
thelight <- mntLightLnkCond $ rprBool $ const . isInLnk
|
|
thelight1 <- mntLightLnkCond $ rprBool $ const . isOutLnk
|
|
thelight2 <-
|
|
mntLightLnkCond $
|
|
rprBool $
|
|
const
|
|
. ( \rp ->
|
|
PolyEdge ((npoly + 1) `div` 4)
|
|
`S.member` fold (rp ^? rpType . rplsType)
|
|
)
|
|
thelight3 <-
|
|
mntLightLnkCond $
|
|
rprBool $
|
|
const
|
|
. ( \rp ->
|
|
PolyEdge (3 * (npoly + 1) `div` 4)
|
|
`S.member` fold (rp ^? rpType . rplsType)
|
|
)
|
|
-- thelight3 <- mntLightLnkCond $ rprBool $ const . isOutLnk
|
|
r <-
|
|
shuffleLinks
|
|
=<< ( roomNgon npoly 250
|
|
<&> rmPmnts
|
|
.~ [angwall a | a <- [0, pi / 8 .. pi - pi / 9]]
|
|
<> [bngwall a | a <- [0, pi / 8 .. pi - pi / 9]]
|
|
<> [ putLasTurret 0.02
|
|
, -- , awall (V2 0 50) (square 10)
|
|
thelight
|
|
, thelight1
|
|
, thelight2
|
|
, thelight3
|
|
]
|
|
<&> rmPath
|
|
%~ ( addNodesCrossingCirc 0 30
|
|
. flip (foldr ($)) [apath a | a <- [0, pi / 8 .. pi - 2 * pi / 9]]
|
|
. flip (foldr ($)) [bpath a | a <- [0, pi / 8 .. pi - 2 * pi / 9]]
|
|
)
|
|
<&> rmLinks
|
|
%~ setInLinksByType (PolyEdge 0)
|
|
<&> rmLinks
|
|
%~ setOutLinksByType (PolyEdge (npoly `div` 2))
|
|
)
|
|
rToOnward "lasCenRunClose" $ return $ cleatOnward r
|
|
where
|
|
awall x = heightWallPS (PS x 0) 30
|
|
-- angwall a = awall (V2 0 100 + rotateV a (V2 0 100)) (fmap (rotateV (pi/4 + a/2)) $ rectWH 5 (25 - a*10/pi ))
|
|
angwall a = awall (V2 0 100 + rotateV a (V2 0 100)) (rotateV (pi / 4 + a * 0.8) <$> rectWH 5 (23 - a * 13 / pi))
|
|
apath a' = addNodesCrossing $ (\x -> (x + f (V2 0 100), x - f (V2 0 100))) (V2 0 100 + rotateV a (V2 0 100))
|
|
where
|
|
a = a' + pi / 16
|
|
f = rotateV (pi / 4 + a * 0.8)
|
|
bngwall a = awall (V2 0 (-100) + rotateV a (V2 0 (-100))) (rotateV (pi / 4 + a * 0.8) <$> rectWH 5 (23 - a * 13 / pi))
|
|
bpath a' = addNodesCrossing $ (\x -> (x + f (V2 0 100), x - f (V2 0 100))) (V2 0 (-100) + rotateV a (V2 0 (-100)))
|
|
where
|
|
a = a' + pi / 16
|
|
f = rotateV (pi / 4 + a * 0.8)
|
|
|
|
lasCenRunClose' :: (RandomGen g) => State g (MetaTree Room String)
|
|
lasCenRunClose' = do
|
|
npoly <- takeOne [5 .. 12]
|
|
inwall <- takeOne obwalls
|
|
outwall <- takeOne obwalls
|
|
thelight <- mntLightLnkCond $ rprBool $ const . isInLnk
|
|
thelight1 <- mntLightLnkCond $ rprBool $ const . isOutLnk
|
|
r <-
|
|
shuffleLinks
|
|
=<< ( roomNgon npoly 250
|
|
<&> rmPmnts
|
|
.~ ( fmap (uncurry inlinkwall) inwall
|
|
<> fmap (uncurry outlinkwall) outwall
|
|
<> [ putLasTurret 0.02
|
|
, thelight
|
|
, thelight1
|
|
]
|
|
)
|
|
<&> rmPath
|
|
%~ addNodesCrossingCirc 0 30
|
|
<&> rmLinks
|
|
%~ setInLinksByType (PolyEdge 0)
|
|
<&> rmLinks
|
|
%~ setOutLinks (\rl -> or [PolyEdge i `S.member` _rlType rl | i <- [2 .. npoly - 2]])
|
|
)
|
|
rToOnward "lasCenRunClose" $ return $ cleatOnward r
|
|
where
|
|
swall =
|
|
[ (70, rectNSWE 10 (-10) (-10) 30)
|
|
, (125, rectNSWE 55 (-55) (-10) 10)
|
|
, (180, rectNSWE 10 (-10) (-30) 10)
|
|
]
|
|
zwall =
|
|
[ (70, rectNSWE 10 (-10) (-30) 10)
|
|
, (125, rectNSWE 55 (-55) (-10) 10)
|
|
, (180, rectNSWE 10 (-10) (-10) 30)
|
|
]
|
|
iwall =
|
|
[ (70, rectNSWE 10 (-10) (-15) 20)
|
|
, (180, rectNSWE 10 (-10) (-30) (-5))
|
|
]
|
|
jwall =
|
|
[ (70, rectNSWE 10 (-10) (-20) 15)
|
|
, (180, rectNSWE 10 (-10) 5 30)
|
|
]
|
|
uwall = [(180, rectNSWE 10 (-10) (-20) 20)]
|
|
obwalls = [swall, zwall, iwall, jwall, uwall]
|
|
linkwall f x =
|
|
heightWallPS
|
|
(resetPLUse $ rprBoolShift (const . f) (shiftInBy x <&> (,S.singleton UsedPosLow)))
|
|
30
|
|
inlinkwall = linkwall isInLnk
|
|
outlinkwall = linkwall isOutLnk
|
|
|
|
lasCenRunCloseLongCor :: (RandomGen g) => State g (MetaTree Room String)
|
|
lasCenRunCloseLongCor = do
|
|
(alinks, blinks) <- shufflePair (rlinks, llinks)
|
|
rdir <- takeOne [negate, id]
|
|
a <- takeOne [5 * pi / 16]
|
|
let h = 800
|
|
laspos <- takeOne [V2 (h / 2) 80]
|
|
ls <- mntLightLnkCond (PS (V2 (h / 2) 0) pi)
|
|
r <-
|
|
shuffleLinks
|
|
=<< ( roomRectAutoLights h 160
|
|
<&> rmPmnts
|
|
<>~ [ putLasTurret 0.02 & plSpot .~ PS laspos a
|
|
, awall (V2 (h / 4) 80) (rotateV (rdir pi / 16) <$> rectWH 180 10)
|
|
, awall (V2 (3 * h / 4) 80) (rotateV (rdir pi / 16) <$> rectWH 180 10)
|
|
, ls
|
|
]
|
|
<&> rmLinks
|
|
%~ setInLinks alinks
|
|
<&> rmLinks
|
|
%~ setOutLinks blinks
|
|
<&> rmPath
|
|
%~ ( addNodesCrossing (V2 (h / 2 - 10) 30, V2 (h / 2 + 50) 90)
|
|
. addNodesCrossing (V2 (h / 2 + 10) 130, V2 (h / 2 - 50) 70)
|
|
)
|
|
)
|
|
rToOnward "lasCenRunClose" $ return $ cleatOnward r
|
|
where
|
|
llinks = memtest (FromEdge South 1) (OnEdge West)
|
|
rlinks = memtest (FromEdge South 1) (OnEdge East)
|
|
awall x = heightWallPS (PS x 0) 30
|
|
memtest a b x =
|
|
let y = _rlType x
|
|
in a `S.member` y && b `S.member` y
|
|
|
|
lasCenRunClose1 :: (RandomGen g) => State g (MetaTree Room String)
|
|
lasCenRunClose1 = do
|
|
-- (alinks,blinks) <- shufflePair (bllinks,brlinks)
|
|
-- (alinks,blinks) <- shufflePair (bllinks,tmllink)
|
|
lnks <- shuffle [bllinks, brlinks, tmllink, tmrlink]
|
|
let alinks = lnks !! 0
|
|
blinks = lnks !! 1
|
|
outwall <-
|
|
takeOne
|
|
[ awall (V2 185 25) (rectWH 10 50)
|
|
, awall (V2 200 50) (rectWH 50 10)
|
|
]
|
|
let z = 35
|
|
r <-
|
|
roomRectAutoLights 250 200
|
|
<&> rmPolys
|
|
.~ [
|
|
[ V2 0 0
|
|
, V2 250 0
|
|
, V2 250 (200 - z)
|
|
, V2 (250 - z) 200
|
|
, V2 z 200
|
|
, V2 0 (200 - z)
|
|
]
|
|
]
|
|
<&> rmPmnts
|
|
<>~ [ putLasTurret 0.02 & plSpot .~ PS (V2 125 100) 0
|
|
, awall (V2 65 25) (rectWH 10 50)
|
|
, outwall
|
|
, awall (V2 95 150) (rectWH 10 20)
|
|
, awall (V2 155 150) (rectWH 10 20)
|
|
, sps0 $ putConvexChasm $ rectNSWE 200 110 105 145
|
|
-- , awall (V2 150 215) (rectWH 60 10)
|
|
]
|
|
<&> rmLinks
|
|
%~ setInLinks alinks
|
|
-- <&> rmLinks %~ setOutLinks (memtest (OnEdge South) (FromEdge West 3))
|
|
<&> rmLinks
|
|
%~ setOutLinks blinks
|
|
<&> rmLinks
|
|
. each
|
|
%~ mvlinks
|
|
<&> rmPath
|
|
%~ S.map (both %~ mvpath)
|
|
rToOnward "lasCenRunClose" $ return $ cleatOnward r
|
|
where
|
|
mvlinks lnk
|
|
| tmllink lnk = lnk & rlPos -~ V2 20 0
|
|
| tmrlink lnk = lnk & rlPos +~ V2 20 0
|
|
| otherwise = lnk
|
|
mvpath (V2 x y)
|
|
| y > 190, x > 50, x < 125 = V2 (x - 20) y
|
|
| y > 190, x > 125, x < 200 = V2 (x + 20) y
|
|
| otherwise = V2 x y
|
|
tmllink = memtest (FromEdge West 1) (OnEdge North)
|
|
tmrlink = memtest (FromEdge West 2) (OnEdge North)
|
|
bllinks =
|
|
etest
|
|
(memtest (FromEdge West 0) (OnEdge South))
|
|
(memtest (FromEdge South 0) (OnEdge West))
|
|
brlinks =
|
|
etest
|
|
(memtest (FromEdge East 0) (OnEdge South))
|
|
(memtest (FromEdge South 0) (OnEdge East))
|
|
awall x = heightWallPS (PS x 0) 30
|
|
etest f g x = f x || g x
|
|
memtest a b x =
|
|
let y = _rlType x
|
|
in a `S.member` y && b `S.member` y
|
|
|
|
lasRunRand :: (RandomGen g) => State g (MetaTree Room String)
|
|
lasRunRand = join $ takeOne [lasCenRunClose2, lasCenRunClose1]
|
|
|
|
lasCenRunClose2 :: (RandomGen g) => State g (MetaTree Room String)
|
|
lasCenRunClose2 = do
|
|
(alinks, blinks) <- shufflePair (bllinks, trlinks)
|
|
a <- takeOne [3 * pi / 2, 3 * pi / 4]
|
|
laspos <- takeOne [V2 60 190, V2 65 185]
|
|
r <-
|
|
shuffleLinks
|
|
=<< ( roomRectAutoLights 250 250
|
|
<&> rmPmnts
|
|
<>~ [ putLasTurret 0.02 & plSpot .~ PS laspos a
|
|
, awall (V2 35 100) (rectWH 10 60)
|
|
, awall (V2 150 215) (rectWH 60 10)
|
|
]
|
|
<&> rmLinks
|
|
%~ setInLinks alinks
|
|
<&> rmLinks
|
|
%~ setOutLinks blinks
|
|
<&> rmPath
|
|
%~ ( addNodesCrossing (V2 110 170, V2 30 250)
|
|
. addNodesCrossing (V2 70 150, V2 10 210)
|
|
)
|
|
)
|
|
rToOnward "lasCenRunClose" $ return $ cleatOnward r
|
|
where
|
|
bllinks =
|
|
etest
|
|
(memtest (FromEdge West 0) (OnEdge South))
|
|
(memtest (FromEdge South 0) (OnEdge West))
|
|
trlinks =
|
|
etest
|
|
(memtest (FromEdge East 0) (OnEdge North))
|
|
(memtest (FromEdge North 0) (OnEdge East))
|
|
awall x = heightWallPS (PS x 0) 30
|
|
etest f g x = f x || g x
|
|
memtest a b x =
|
|
let y = _rlType x
|
|
in a `S.member` y && b `S.member` y
|
|
|
|
lasTunnel :: (RandomGen g) => Float -> State g Room
|
|
lasTunnel y = do
|
|
extraPlmnts <-
|
|
takeOne
|
|
[
|
|
[ midWall (rectNSWE 115 90 0 60)
|
|
, midWall (rectNSWE 65 40 (-40) 25)
|
|
]
|
|
,
|
|
[ midWall (rectNSWE 125 100 0 25)
|
|
, midWall (rectNSWE 80 40 (-40) 0)
|
|
, midWall (rectNSWE 80 40 25 60)
|
|
]
|
|
]
|
|
return
|
|
defaultRoom
|
|
{ _rmPolys = polys
|
|
, _rmBound = polys
|
|
, _rmLinks =
|
|
[ outLink (V2 20 (190 + y)) (1.5 * pi)
|
|
, outLink (V2 0 (190 + y)) (0.5 * pi)
|
|
, inLink (V2 (-40) 20) (0.5 * pi)
|
|
, inLink (V2 60 20) (1.5 * pi)
|
|
, inLink (V2 10 0) pi
|
|
]
|
|
, _rmPmnts =
|
|
[ putLasTurret 0.005 & plSpot .~ PS (V2 10 (240 + y)) (1.5 * pi)
|
|
, -- , midWall (rectNSEW 65 40 0 25)
|
|
mntLS vShape (V2 60 145) (V3 40 125 90)
|
|
, mntLS vShape (V2 (-40) 145) (V3 (-20) 125 90)
|
|
]
|
|
++ extraPlmnts
|
|
, _rmName = "lasTunnel" ++ show y
|
|
}
|
|
where
|
|
polys =
|
|
[ rectNSWE (250 + y) 0 0 20
|
|
, rectNSWE 145 0 (-40) 60
|
|
]
|
|
|
|
-- a y value of 400 is probably "unrunnable"
|
|
lasTunnelRunPast :: (RandomGen g) => Float -> State g (MetaTree Room String)
|
|
lasTunnelRunPast y = do
|
|
r <- lasTunnel y
|
|
r1 <- takeOne [door, corridor]
|
|
r2 <- takeOne [door, corridor]
|
|
rToOnward "lasTunnelRunPast" $
|
|
Node
|
|
r
|
|
[ pure $ cleatOnward r1
|
|
, return (cleatLabel 0 $ r2 & rmConnectsTo .~ S.member InLink)
|
|
]
|