Start to remove explicit "outplacements"
This commit is contained in:
File diff suppressed because one or more lines are too long
@@ -81,6 +81,7 @@ data Placement = Placement
|
||||
{ _plSpot :: PlacementSpot
|
||||
, _plType :: PSType
|
||||
, _plMID :: Maybe Int
|
||||
, _plExternalID :: Maybe Int
|
||||
, _plIDCont :: GenWorld -> Placement -> Maybe Placement
|
||||
}
|
||||
|
||||
|
||||
+1
-1
@@ -91,7 +91,7 @@ doRoomInPlacements w rm = foldr f (w, rm) $ _rmInPmnt rm
|
||||
doOutPlacements :: GenWorld -> GenWorld
|
||||
doOutPlacements w =
|
||||
let ((pmnts, gw), rms) = mapAccumR doRoomOutPlacements (IM.empty, w) (_genRooms w)
|
||||
in gw & genRooms .~ rms & genPmnt .~ pmnts
|
||||
in gw & genRooms .~ rms & genPmnt <>~ pmnts
|
||||
|
||||
doRoomOutPlacements ::
|
||||
(IM.IntMap [Placement], GenWorld) ->
|
||||
|
||||
@@ -7,34 +7,34 @@ import Geometry
|
||||
|
||||
--spNoID
|
||||
psPtPl :: PlacementSpot -> PSType -> Placement
|
||||
psPtPl ps pst = Placement ps pst Nothing (const . const Nothing)
|
||||
psPtPl ps pst = Placement ps pst Nothing Nothing (const . const Nothing)
|
||||
|
||||
psPtJpl :: PlacementSpot -> PSType -> Maybe Placement
|
||||
psPtJpl ps = Just . psPtPl ps
|
||||
|
||||
pContID :: PlacementSpot -> PSType -> (Int -> Maybe Placement) -> Placement
|
||||
pContID ps pt = Placement ps pt Nothing . contToIDCont
|
||||
pContID ps pt = Placement ps pt Nothing Nothing . contToIDCont
|
||||
|
||||
psPtCont :: PlacementSpot -> PSType -> (Placement -> Maybe Placement) -> Placement
|
||||
psPtCont ps pt = Placement ps pt Nothing . const
|
||||
psPtCont ps pt = Placement ps pt Nothing Nothing . const
|
||||
|
||||
ptCont :: PSType -> (Placement -> Maybe Placement) -> Placement
|
||||
ptCont = psPtCont (PS 0 0)
|
||||
|
||||
psPt :: PlacementSpot -> PSType -> Placement
|
||||
psPt ps pt = Placement ps pt Nothing (const . const Nothing)
|
||||
psPt ps pt = Placement ps pt Nothing Nothing (const . const Nothing)
|
||||
|
||||
sPS :: Point2 -> Float -> PSType -> Placement
|
||||
sPS p a pt = Placement (PS p a) pt Nothing (const . const Nothing)
|
||||
sPS p a pt = Placement (PS p a) pt Nothing Nothing (const . const Nothing)
|
||||
|
||||
sps :: PlacementSpot -> PSType -> Placement
|
||||
sps ps pt = Placement ps pt Nothing (const . const Nothing)
|
||||
sps ps pt = Placement ps pt Nothing Nothing (const . const Nothing)
|
||||
|
||||
plRRpt :: Int -> PSType -> Placement
|
||||
plRRpt i pt = Placement (PSRoomRand i (uncurry PS)) pt Nothing (const . const Nothing)
|
||||
plRRpt i pt = Placement (PSRoomRand i (uncurry PS)) pt Nothing Nothing (const . const Nothing)
|
||||
|
||||
jsps :: Point2 -> Float -> PSType -> Maybe Placement
|
||||
jsps p a pst = Just $ Placement (PS p a) pst Nothing $ const . const Nothing
|
||||
jsps p a pst = Just $ Placement (PS p a) pst Nothing Nothing $ const . const Nothing
|
||||
|
||||
jsps0 :: PSType -> Maybe Placement
|
||||
jsps0 = Just . sPS (V2 0 0) 0
|
||||
@@ -43,51 +43,51 @@ sps0 :: PSType -> Placement
|
||||
sps0 = sPS (V2 0 0) 0
|
||||
|
||||
jspsJ :: Point2 -> Float -> PSType -> Placement -> Maybe Placement
|
||||
jspsJ p a pst plm = Just $ Placement (PS p a) pst Nothing $ \_ _ -> Just plm
|
||||
jspsJ p a pst plm = Just $ Placement (PS p a) pst Nothing Nothing $ \_ _ -> Just plm
|
||||
|
||||
jsps0J :: PSType -> Placement -> Maybe Placement
|
||||
jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst Nothing $ \_ _ -> Just plm
|
||||
jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst Nothing Nothing $ \_ _ -> Just plm
|
||||
|
||||
ps0 :: PSType -> (Int -> Maybe Placement) -> Placement
|
||||
ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing . contToIDCont
|
||||
ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing Nothing . contToIDCont
|
||||
|
||||
pt0 :: PSType -> (Placement -> Maybe Placement) -> Placement
|
||||
pt0 pst = Placement (PS (V2 0 0) 0) pst Nothing . const
|
||||
pt0 pst = Placement (PS (V2 0 0) 0) pst Nothing Nothing . const
|
||||
|
||||
contToIDCont :: (Int -> Maybe Placement) -> GenWorld -> Placement -> Maybe Placement
|
||||
contToIDCont f _ = f . fromJust . _plMID
|
||||
|
||||
jps0' :: PSType -> (Placement -> Maybe Placement) -> Maybe Placement
|
||||
jps0' pst = Just . Placement (PS (V2 0 0) 0) pst Nothing . const
|
||||
jps0' pst = Just . Placement (PS (V2 0 0) 0) pst Nothing Nothing . const
|
||||
|
||||
jps0PushPS :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
|
||||
jps0PushPS pst f = Just . Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing $
|
||||
jps0PushPS pst f = Just . Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing Nothing $
|
||||
\_ plmnt -> f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt
|
||||
|
||||
ps0j :: PSType -> Placement -> Placement
|
||||
ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (\_ -> const $ Just plmnt)
|
||||
ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing Nothing (\_ -> const $ Just plmnt)
|
||||
|
||||
psj :: PlacementSpot -> PSType -> Placement -> Placement
|
||||
psj ps pst plmnt = Placement ps pst Nothing (\_ -> const $ Just plmnt)
|
||||
psj ps pst plmnt = Placement ps pst Nothing Nothing (\_ -> const $ Just plmnt)
|
||||
|
||||
-- the NoShiftCont is necessary when shifting then combining rooms
|
||||
ps0jPushPS :: PSType -> Placement -> Placement
|
||||
ps0jPushPS pst plmnt = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing $
|
||||
ps0jPushPS pst plmnt = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing Nothing $
|
||||
\_ p -> Just $ plmnt & plSpot .~ _plSpot p
|
||||
|
||||
-- the NoShiftCont is necessary when shifting then combining rooms
|
||||
ps0PushPS :: PSType -> (Placement -> Maybe Placement) -> Placement
|
||||
ps0PushPS pst f = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing $
|
||||
ps0PushPS pst f = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing Nothing $
|
||||
\_ pl -> f pl & _Just . plSpot %~ const (_plSpot pl)
|
||||
|
||||
ps0PushPSw :: PSType -> (GenWorld -> Placement -> Maybe Placement) -> Placement
|
||||
ps0PushPSw pst f = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing $
|
||||
ps0PushPSw pst f = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing Nothing $
|
||||
\w pl -> f w pl & _Just . plSpot %~ const (_plSpot pl)
|
||||
|
||||
addPlmnt :: Placement -> Placement -> Placement
|
||||
addPlmnt pl pl2 = case pl2 of
|
||||
-- (RandomPlacement rp) -> RandomPlacement $ fmap (addPlmnt pl) rp
|
||||
(Placement ps pt mi f) -> Placement ps pt mi (fmap (fmap g) f)
|
||||
(Placement ps pt mi mj f) -> Placement ps pt mi mj (fmap (fmap g) f)
|
||||
where
|
||||
g Nothing = Just pl
|
||||
g (Just pl') = Just $ addPlmnt pl pl'
|
||||
|
||||
@@ -76,8 +76,8 @@ divideDoorPane mid wl cond soff speed ppairs g = case ppairs of
|
||||
& drPushedBy .~ maybe PushesItself PushedBy mid
|
||||
|
||||
putAutoDoor :: Point2 -> Point2 -> Placement
|
||||
putAutoDoor a b = Placement (PS 0 0) (PutCoord a) Nothing $ \_ apl ->
|
||||
Just $ Placement (PS 0 0) (PutCoord b) Nothing $ \w bpl ->
|
||||
putAutoDoor a b = Placement (PS 0 0) (PutCoord a) Nothing Nothing $ \_ apl ->
|
||||
Just $ Placement (PS 0 0) (PutCoord b) Nothing Nothing $ \w bpl ->
|
||||
let x = w ^?! gwWorld . coordinates . ix (apl ^?! plMID . _Just)
|
||||
y = w ^?! gwWorld . coordinates . ix (bpl ^?! plMID . _Just)
|
||||
in Just $ putDoubleDoor
|
||||
|
||||
@@ -174,7 +174,7 @@ spanLSLightI ls h a b =
|
||||
|
||||
spanLS :: LightSource -> Point2 -> Point2 -> Placement
|
||||
spanLS ls a b =
|
||||
Placement (PS (V2 x y) 0) (PutLS ls) Nothing $
|
||||
Placement (PS (V2 x y) 0) (PutLS ls) Nothing Nothing $
|
||||
const $ const $ Just $ sps0 $ putShape $ thinHighBar h a b
|
||||
where
|
||||
V3 _ _ h = _lsPos (_lsParam ls) + 5
|
||||
|
||||
@@ -6,6 +6,7 @@
|
||||
-}
|
||||
module Dodge.Placement.PlaceSpot (placeSpot) where
|
||||
|
||||
import Data.Maybe
|
||||
import Color
|
||||
import Control.Monad.State
|
||||
import Data.Bifunctor
|
||||
@@ -41,9 +42,13 @@ placePlainPSSpot
|
||||
placePlainPSSpot w rm plmnt shift =
|
||||
let (i, w') = placeSpotID rm (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
|
||||
newplmnt = plmnt & plMID ?~ i
|
||||
in maybe ((w', rm & rmPmnts .:~ newplmnt), [newplmnt])
|
||||
((gw,rm'),plist) = maybe ((w', rm & rmPmnts .:~ newplmnt), [newplmnt])
|
||||
(recrPlace newplmnt w') (_plIDCont plmnt w' newplmnt)
|
||||
in ((f newplmnt gw,rm'),plist)
|
||||
where
|
||||
f x gw = fromMaybe gw $ do
|
||||
j <- x ^. plExternalID
|
||||
return $ gw & genPmnt . at j ?~ [x]
|
||||
recrPlace newplmnt w' pl =
|
||||
let (wr, newplmnts) = placeSpot (w', rm & rmPmnts .:~ newplmnt) pl
|
||||
in (wr, newplmnt : newplmnts)
|
||||
|
||||
@@ -155,9 +155,9 @@ twoRoomPoss ::
|
||||
(RoomPos -> Room -> Bool) ->
|
||||
(PlacementSpot -> PlacementSpot -> Placement) ->
|
||||
Placement
|
||||
twoRoomPoss cond1 cond2 f = Placement (rprBool cond1) PutNothing Nothing $
|
||||
twoRoomPoss cond1 cond2 f = Placement (rprBool cond1) PutNothing Nothing Nothing $
|
||||
\_ pl1 -> Just $
|
||||
Placement (rprBool cond2) PutNothing Nothing $
|
||||
Placement (rprBool cond2) PutNothing Nothing Nothing $
|
||||
\_ pl2 -> Just $ f (_plSpot pl1) (_plSpot pl2)
|
||||
|
||||
--isUnusedLnk :: RoomPos -> Bool
|
||||
|
||||
@@ -39,9 +39,10 @@ decontamRoom i =
|
||||
\_ _ -> Just $ putDoubleDoor DoorObstacle thewall (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)
|
||||
-- & rmOutPmnt . at i ?~
|
||||
-- analyser (NoItemZone ps) (PS 50 0) (PS mcpos 0)
|
||||
& rmInPmnt .~ [f]
|
||||
& rmBound .~ [rectNSWE 75 15 0 40, switchcut]
|
||||
where
|
||||
|
||||
@@ -42,8 +42,9 @@ lightSensInsideDoor i rm =
|
||||
.++~ [ psPt atFstLnkOut (PutForeground $ floorWire (V2 20 0) (V2 20 (-100)))
|
||||
, psPt atFstLnkOut (PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100)))
|
||||
, psPt atFstLnkOut (PutForeground $ verticalWire (V2 20 0) 0 80)
|
||||
, sensAboveDoor LaserSensor 10 (atFstLnkOutShiftInward 100) & plExternalID ?~ i
|
||||
]
|
||||
& rmOutPmnt . at i ?~ sensAboveDoor LaserSensor 10 (atFstLnkOutShiftInward 100)
|
||||
-- & rmOutPmnt . at i ?~ sensAboveDoor LaserSensor 10 (atFstLnkOutShiftInward 100)
|
||||
|
||||
lightSensByDoor :: Int -> Room -> Room
|
||||
lightSensByDoor i rm =
|
||||
@@ -52,8 +53,9 @@ lightSensByDoor i rm =
|
||||
.++~ [ 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
|
||||
]
|
||||
& rmOutPmnt . at i ?~ sensAboveDoor LaserSensor 20 (atFstLnkOutShiftBy sensorshift)
|
||||
-- & rmOutPmnt . at i ?~ sensAboveDoor LaserSensor 20 (atFstLnkOutShiftBy sensorshift)
|
||||
where
|
||||
covershape = rectNSWE 10 (-10) (-20) 20
|
||||
sensorshift (p, a) = (p +.+ rotateV a (V2 60 (-20)), a)
|
||||
@@ -81,12 +83,17 @@ analyserByNthLink n proxreq i rm =
|
||||
rm
|
||||
& rmPmnts
|
||||
.++~ [ psPt (atNthLinkOut n) $ PutForeground $ verticalWire (V2 20 0) 0 80
|
||||
]
|
||||
& rmOutPmnt . at i ?~
|
||||
analyser
|
||||
, analyser
|
||||
(SensorWithRequirement proxreq)
|
||||
(atNthLnkOutShiftBy n (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
|
||||
(atNthLnkOutShiftBy n sensorshift)
|
||||
& plExternalID ?~ i
|
||||
]
|
||||
-- & rmOutPmnt . at i ?~
|
||||
-- analyser
|
||||
-- (SensorWithRequirement proxreq)
|
||||
-- (atNthLnkOutShiftBy n (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
|
||||
-- (atNthLnkOutShiftBy n sensorshift)
|
||||
where
|
||||
sensorshift (p, a) = (p +.+ rotateV a (V2 (-30) (-10)), a)
|
||||
|
||||
@@ -96,12 +103,18 @@ analyserByNthLinkWithPrompt n l proxreq i rm =
|
||||
rm
|
||||
& rmPmnts
|
||||
.++~ [ psPt (atNthLinkOut n) $ PutForeground $ verticalWire (V2 20 0) 0 80
|
||||
]
|
||||
& rmOutPmnt . at i ?~
|
||||
,
|
||||
analyserWithPrompt l
|
||||
(SensorWithRequirement proxreq)
|
||||
(atNthLnkOutShiftBy n (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
|
||||
(atNthLnkOutShiftBy n sensorshift)
|
||||
& plExternalID ?~ i
|
||||
]
|
||||
-- & rmOutPmnt . at i ?~
|
||||
-- analyserWithPrompt l
|
||||
-- (SensorWithRequirement proxreq)
|
||||
-- (atNthLnkOutShiftBy n (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
|
||||
-- (atNthLnkOutShiftBy n sensorshift)
|
||||
where
|
||||
sensorshift (p, a) = (p +.+ rotateV a (V2 (-30) (-10)), a)
|
||||
|
||||
|
||||
@@ -126,5 +126,5 @@ roomPillars pillarsize w h wn hn = do
|
||||
where
|
||||
pilw = ((w - 40 * (fromIntegral wn + 1)) / fromIntegral wn) - pillarsize
|
||||
pilh = ((h - 40 * (fromIntegral hn + 1)) / fromIntegral hn) - pillarsize
|
||||
testchasm = Placement (PS 0 0) (PutChasm (map (+V2 50 120) (rectWH 50 25))) Nothing
|
||||
testchasm = Placement (PS 0 0) (PutChasm (map (+V2 50 120) (rectWH 50 25))) Nothing Nothing
|
||||
(\_ _ -> Nothing)
|
||||
|
||||
@@ -51,8 +51,9 @@ lockedStart i = do
|
||||
map (over root $ rmConnectsTo .~ S.member theedge) doorrooms
|
||||
++ [ return
|
||||
smallRoom
|
||||
{ _rmOutPmnt = IM.singleton i (putLitButOnPosExtTrig red useUnusedLnk)
|
||||
, _rmPmnts = [plRRpt 0 (PutFlIt theweapon)]
|
||||
{ --_rmOutPmnt = IM.singleton i (putLitButOnPosExtTrig red useUnusedLnk)
|
||||
_rmPmnts = [plRRpt 0 (PutFlIt theweapon)
|
||||
,(putLitButOnPosExtTrig red useUnusedLnk) & plExternalID ?~ i]
|
||||
, _rmBound = [rectNSWE 70 30 0 40]
|
||||
}
|
||||
]
|
||||
|
||||
@@ -66,5 +66,6 @@ sensInsideDoor senseType i rm = rm
|
||||
, putMessageTerminal terminalColor
|
||||
(textTerminal & tmCommands .:~ TCDamageCommand)
|
||||
& plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10)
|
||||
, sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100) & plExternalID ?~ i
|
||||
]
|
||||
& rmOutPmnt . at i ?~ sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)
|
||||
-- & rmOutPmnt . at i ?~ sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)
|
||||
|
||||
@@ -166,7 +166,7 @@ tutRezBox = do
|
||||
roomRect 40 60 1 1
|
||||
& rmPmnts
|
||||
.~ [ sPS (V2 20 1) 0 $ PutLS ls
|
||||
, Placement (PS 0 0) PutNothing Nothing $ \w _ -> Just $ putImmediateMessageTerminal
|
||||
, Placement (PS 0 0) PutNothing Nothing Nothing $ \w _ -> Just $ putImmediateMessageTerminal
|
||||
terminalColor
|
||||
( defaultTerminal & tmBootLines .~ s w
|
||||
<> tlSetStatus (TerminalPressTo "QUIT")
|
||||
|
||||
@@ -35,7 +35,8 @@ addDoorToggleTerminal = addDoorAtNthLinkToggleTerminal 0
|
||||
|
||||
addDoorAtNthLinkToggleTerminal :: Int -> [TerminalLine] -> Int -> Room -> Room
|
||||
addDoorAtNthLinkToggleTerminal j xs i = (rmName .++~ "doorToggle-")
|
||||
. (rmOutPmnt . at i ?~ outplace)
|
||||
-- . (rmOutPmnt . at i ?~ outplace)
|
||||
. (rmPmnts .:~ outplace)
|
||||
where
|
||||
outplace =
|
||||
extTrigLitPos
|
||||
@@ -43,7 +44,7 @@ addDoorAtNthLinkToggleTerminal j xs i = (rmName .++~ "doorToggle-")
|
||||
( Just . set plSpot (rprShift (moveToSideNthOutLink j))
|
||||
. putMessageTerminal terminalColor
|
||||
. termMessages
|
||||
)
|
||||
) & plExternalID ?~ i
|
||||
termMessages trpl =
|
||||
lineOutputTerminal xs --(makeColorTermLine red "WARNING" : makeTermPara str)
|
||||
& tmToggles .~ M.fromList
|
||||
|
||||
Reference in New Issue
Block a user