Automatically order placements
This commit is contained in:
@@ -27,12 +27,12 @@ roomsContaining' crs its = do
|
||||
endroom <-
|
||||
join $
|
||||
takeOne
|
||||
[ roomPillarsSquare <&> rmPmnts ++.~ crsItmsUnused crs its
|
||||
, randomFourCornerRoomCrsIts crs its
|
||||
, tanksRoom crs its
|
||||
, tanksPipesRoom <&> rmPmnts ++.~ crsItmsUnused crs its
|
||||
, roomPillarsContaining crs its
|
||||
, roomPillarsPassage <&> rmPmnts ++.~ crsItmsUnused crs its
|
||||
[-- roomPillarsSquare <&> rmPmnts ++.~ crsItmsUnused crs its
|
||||
--, randomFourCornerRoomCrsIts crs its
|
||||
--, tanksRoom crs its
|
||||
-- tanksPipesRoom <&> rmPmnts ++.~ crsItmsUnused crs its
|
||||
roomPillarsContaining crs its
|
||||
-- , roomPillarsPassage <&> rmPmnts ++.~ crsItmsUnused crs its
|
||||
]
|
||||
return (pure $ cleatOnward endroom)
|
||||
|
||||
|
||||
+308
-243
@@ -14,18 +14,15 @@ module Dodge.Room.LasTurret (
|
||||
lasCenRunClose1,
|
||||
lasCenRunCloseLongCor,
|
||||
lasRunRand,
|
||||
setRoomInt,
|
||||
storeRoomID,
|
||||
) where
|
||||
|
||||
import Color
|
||||
import Control.Monad
|
||||
import Data.Foldable
|
||||
import Data.Maybe
|
||||
import Color
|
||||
import Shape
|
||||
import Dodge.Placement.Instance.LightSource
|
||||
import Dodge.Room.Path
|
||||
import Control.Monad
|
||||
--import Data.Foldable (fold)
|
||||
import Dodge.Room.Procedural
|
||||
-- import Data.Foldable (fold)
|
||||
|
||||
import qualified Data.Set as S
|
||||
import Dodge.Cleat
|
||||
import Dodge.Data.GenWorld
|
||||
@@ -38,6 +35,8 @@ 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
|
||||
@@ -45,54 +44,49 @@ import Dodge.Wire
|
||||
import Geometry
|
||||
import LensHelp
|
||||
import RandomHelp
|
||||
import Shape
|
||||
|
||||
-- no lights!
|
||||
cenLasTur :: (RandomGen g) => State g Room
|
||||
cenLasTur = do
|
||||
-- lshape <- takeOne [vShape, lShape, jShape, liShape]
|
||||
-- let lightn i = mntLSCond (fmap (fmap $ colorSH black) lshape)
|
||||
-- $ rprBool $ const . (\rp -> PolyEdge i `S.member` (fold (rp ^? rpType . rplsType)))
|
||||
-- thelight <- mntLightLnkCond $ rprBool $ const . isInLnk
|
||||
roomNgon 8 200
|
||||
<&> rmPmnts
|
||||
.~ [ putLasTurret 0.02
|
||||
, heightWallPS
|
||||
(resetPLUse $ rprBoolShift (const . isInLnk) (shiftInBy 100 <&> (,S.singleton UsedPosLow)))
|
||||
(resetPLUse $ rprBoolShift (const . isInLnk) (shiftInBy 120 <&> (,S.singleton UsedPosLow)))
|
||||
30
|
||||
covershape
|
||||
-- , lightn 0
|
||||
-- , lightn 3
|
||||
-- , lightn 6
|
||||
(rectWH 20 10)
|
||||
]
|
||||
<&> rmPath %~ addNodesCrossingCirc 0 30
|
||||
where
|
||||
covershape = rectNSWE 10 (-10) (-20) 20
|
||||
<&> rmPath
|
||||
%~ addNodesCrossingCirc 0 30
|
||||
|
||||
lightSensInsideDoor :: Int -> Room -> Room
|
||||
lightSensInsideDoor i rm =
|
||||
rm
|
||||
& rmPmnts
|
||||
.++~ [ psPt atFstLnkOut (PutForeground $ floorWire (V2 20 0) (V2 20 (-100)))
|
||||
, psPt atFstLnkOut (PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100)))
|
||||
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 100) & plExternalID ?~ i
|
||||
, sensAboveDoor LaserSensor 10 (atFstLnkOutShiftInward x) & plExternalID ?~ i
|
||||
]
|
||||
where
|
||||
x = 120
|
||||
|
||||
-- & rmOutPmnt . at i ?~ sensAboveDoor LaserSensor 10 (atFstLnkOutShiftInward 100)
|
||||
|
||||
lightSensByDoor :: Int -> Room -> Room
|
||||
lightSensByDoor i rm =
|
||||
rm
|
||||
& rmPmnts
|
||||
.++~ [ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80
|
||||
, heightWallPS (atNthLnkOutShiftInward 1 100) 30 covershape
|
||||
, heightWallPS (atFstLnkOutShiftInward 100) 30 covershape
|
||||
, sensAboveDoor LaserSensor 20 (atFstLnkOutShiftBy sensorshift) & plExternalID ?~ i
|
||||
]
|
||||
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
|
||||
-- & rmOutPmnt . at i ?~ sensAboveDoor LaserSensor 20 (atFstLnkOutShiftBy sensorshift)
|
||||
|
||||
covershape = rectNSWE 10 (-10) (-20) 20
|
||||
sensorshift (p, a) = ((p +.+ rotateV a (V2 60 (-20)), a), S.singleton UsedPosLow)
|
||||
|
||||
keyCardRoomRunPast :: (RandomGen g) => Int -> Int -> State g (MetaTree Room String)
|
||||
@@ -148,34 +142,32 @@ lasSensorTurretTest :: State LayoutVars (MetaTree Room String)
|
||||
lasSensorTurretTest = do
|
||||
n <- nextLayoutInt
|
||||
cenroom' <- shuffleLinks . lightSensInsideDoor n =<< cenLasTur
|
||||
(i,cenroom'') <- setRoomInt cenroom'
|
||||
(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, alight pi . f i)
|
||||
,(0, alight (0.5*pi) . f i)
|
||||
,(0, alight (1.5*pi) . f i)]
|
||||
let alight a rp = mntLSCond (fmap (fmap $ colorSH black) lshape) (PS (rotateV a $ _rpPos rp) (a + _rpDir rp))
|
||||
let cenroom =
|
||||
cenroom''
|
||||
& rmInPmnt
|
||||
<>~ [ (0, alight pi . f i)
|
||||
, (0, alight (0.5 * pi) . f i)
|
||||
, (0, alight (1.5 * pi) . f i)
|
||||
]
|
||||
rToOnward "lasSensorTurretTest" $
|
||||
treePost
|
||||
[door, cenroom, triggerDoorRoom n, cleatOnward door]
|
||||
where
|
||||
f i gw = fromJust $ find (isused ._rpType) (gw ^?! genRooms . ix (gw ^?! genInts . ix i) . rmPos)
|
||||
isused UsedOutLink{_rplsChildNum = 0} = True
|
||||
isused _ = False
|
||||
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
|
||||
cenroom' <- (shuffleLinks . lightSensByDoor n =<< cenLasTur)
|
||||
(i,cenroom'') <- setRoomInt cenroom'
|
||||
(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))
|
||||
let cenroom = cenroom''
|
||||
& rmInPmnt <>~
|
||||
[(0, alight pi . f i)
|
||||
,(0, alight (0.5*pi) . f i)
|
||||
,(0, alight (1.5*pi) . f i)]
|
||||
let alight a rp = mntLSCond (fmap (fmap $ colorSH black) lshape) (PS (rotateV a $ _rpPos rp) (a + _rpDir rp))
|
||||
blight a = (0, 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] $
|
||||
@@ -185,270 +177,343 @@ lasCenSensEdge n = do
|
||||
, treePost [door, cleatLabel n corridor]
|
||||
]
|
||||
where
|
||||
f i gw = fromJust $ find (isused ._rpType) (gw ^?! genRooms . ix (gw ^?! genInts . ix i) . rmPos)
|
||||
isused UsedOutLink{_rplsChildNum = 0} = True
|
||||
isused _ = False
|
||||
f i gw = fromJust $ find (isused . _rpType) (getRoomFromID i gw ^. rmPos)
|
||||
isused UsedOutLink{_rplsChildNum = 0} = True
|
||||
isused _ = False
|
||||
|
||||
setRoomInt :: Room -> State LayoutVars (Int, Room)
|
||||
setRoomInt x = do
|
||||
storeRoomID :: Room -> State LayoutVars (Int, Room)
|
||||
storeRoomID x = do
|
||||
i <- nextLayoutInt
|
||||
return (i, x & rmPmnts .:~ sps0 (PutWorldUpdate (f i)))
|
||||
where
|
||||
f i rid _ gw = gw & genInts . at i ?~ (gw ^?! genRooms . ix rid . rmMID . _Just)
|
||||
|
||||
-- unsafe! assumes that storeRoomID has been called
|
||||
getRoomFromID :: Int -> GenWorld -> Room
|
||||
getRoomFromID i gw = gw ^?! genRooms . ix (gw ^?! genInts . ix i)
|
||||
|
||||
lasRunYinYang :: (RandomGen g) => State g (MetaTree Room String)
|
||||
lasRunYinYang = do
|
||||
npoly <- takeOne [6,8,10,12]
|
||||
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))
|
||||
)
|
||||
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 v = heightWallPS (PS x 0) 30 v
|
||||
--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)) (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)) (fmap (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))
|
||||
angwall a = awall (V2 0 100 + rotateV a (V2 0 100)) (fmap (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))) (fmap (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)))
|
||||
a = a' + pi / 16
|
||||
f = rotateV (pi / 4 + a * 0.8)
|
||||
bngwall a = awall (V2 0 (-100) + rotateV a (V2 0 (-100))) (fmap (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)
|
||||
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]
|
||||
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))
|
||||
)
|
||||
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 v = heightWallPS (PS x 0) 30 v
|
||||
--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)) (fmap (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))
|
||||
-- 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)) (fmap (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))) (fmap (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)))
|
||||
a = a' + pi / 16
|
||||
f = rotateV (pi / 4 + a * 0.8)
|
||||
bngwall a = awall (V2 0 (-100) + rotateV a (V2 0 (-100))) (fmap (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)
|
||||
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]
|
||||
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
|
||||
]
|
||||
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]])
|
||||
)
|
||||
<&> 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
|
||||
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]
|
||||
(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) )
|
||||
)
|
||||
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 v = heightWallPS (PS x 0) 30 v
|
||||
memtest a b x = let y = _rlType x
|
||||
in a `S.member` y && b `S.member` y
|
||||
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]
|
||||
-- (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) ]
|
||||
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)
|
||||
]]
|
||||
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)
|
||||
, awall (V2 65 25) (rectWH 10 50)
|
||||
, outwall
|
||||
, awall (V2 95 150) (rectWH 10 20)
|
||||
, awall (V2 155 150) (rectWH 10 20)
|
||||
, 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)
|
||||
-- , 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
|
||||
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
|
||||
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))
|
||||
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 v = heightWallPS (PS x 0) 30 v
|
||||
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
|
||||
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]
|
||||
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]
|
||||
(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) )
|
||||
)
|
||||
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))
|
||||
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 v = heightWallPS (PS x 0) 30 v
|
||||
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
|
||||
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
|
||||
|
||||
@@ -53,8 +53,7 @@ tutAnoTree = do
|
||||
foldMTRS
|
||||
[ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
|
||||
, corDoor
|
||||
, lasSensorTurretTest
|
||||
--ccc , passthroughLockKeyLists lockRoomKeyItems itemRooms
|
||||
, passthroughLockKeyLists lockRoomKeyItems itemRooms
|
||||
--bbb , -- , return . tToBTree "door" $ treePost [corridor, cleatOnward door]
|
||||
--bbb corDoor
|
||||
--bbb , -- , tToBTree "cor" . return <$> shuffleLinks (cleatOnward corridor)
|
||||
@@ -107,7 +106,7 @@ foldMTRS xs = do
|
||||
|
||||
setTreeInts :: Tree Room -> State LayoutVars ([Int], Tree Room)
|
||||
setTreeInts x = do
|
||||
y <- traverse setRoomInt x
|
||||
y <- traverse storeRoomID x
|
||||
return (foldMap ((: []) . fst) y, fmap snd y)
|
||||
|
||||
tutDrop :: State LayoutVars (MetaTree Room String)
|
||||
@@ -115,7 +114,7 @@ tutDrop = do
|
||||
x <- shuffleLinks =<< roomNgon 6 100
|
||||
i <- nextLayoutInt
|
||||
-- let y = decontamRoom i
|
||||
(j, y) <- setRoomInt (decontamRoom i)
|
||||
(j, y) <- storeRoomID (decontamRoom i)
|
||||
rm <- roomRectAutoLights 40 100
|
||||
return $
|
||||
tToBTree "TutDrop" $
|
||||
|
||||
Reference in New Issue
Block a user