justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Allow to log position of placement spot

Browse Source
This commit is contained in:
justin
2025-09-29 22:34:44 +01:00
parent bf9a2250da
commit a2eb0e026b
13 changed files with 180 additions and 152 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Room.hs
+2 -1
View File
@@ -16,7 +16,7 @@ data RoomPos = RoomPos
, _rpDir :: Float
, _rpType :: S.Set RoomPosType
, _rpLinkStatus :: RPLinkStatus
, _rpPlacementUse :: Int
, _rpPlacementUse :: S.Set UsedPos
}
deriving (Eq, Ord, Show)
@@ -80,6 +80,7 @@ data UsedPos
= UsedPosLow
| UsedPosMid
| UsedPosHigh
| UsedPosFloor
deriving (Eq, Ord, Show)
makeLenses ''RoomLink
src/Dodge/PlacementSpot.hs
+32 -28
View File
@@ -61,17 +61,17 @@ randDirPS ps = do
isUnusedLnk :: RoomPos -> Room -> Bool
isUnusedLnk rp _ = case _rpLinkStatus rp of
UnusedLink{} -> _rpPlacementUse rp == 0
UnusedLink{} -> null $ _rpPlacementUse rp
_ -> False
anyUnusedSpot :: PlacementSpot
anyUnusedSpot = rprBool $ \rp _ -> _rpLinkStatus rp == NotLink && _rpPlacementUse rp == 0
anyUnusedSpot = rprBool $ \rp _ -> _rpLinkStatus rp == NotLink && null (_rpPlacementUse rp)
psposAddLabel :: RoomPosType -> PlacementSpot -> PlacementSpot
psposAddLabel lab = psSelect %~ (\f rp r -> f rp r & _Just . _2 . rpType %~ S.insert lab)
rprBool :: (RoomPos -> Room -> Bool) -> PlacementSpot
rprBool t = PSPos (useRoomPosRoomCond t) (const id) Nothing
rprBool t = PSPos (useRoomPosRoomCond (S.singleton UsedPosLow) t) (const id) Nothing
rpIsOnPath :: RoomPos -> Bool
rpIsOnPath = any f . _rpType
@@ -99,34 +99,34 @@ rpOnPathFromEdge pe = any f . _rpType
resetPLUse :: PlacementSpot -> PlacementSpot
resetPLUse (PSPos f g fallback) = PSPos f' g fallback
where
f' rp = fmap (second (rpPlacementUse .~ 0)) . f rp
f' rp = fmap (second (rpPlacementUse .~ mempty)) . f rp
resetPLUse _ = error "Tried to reset _rpPlacementUse of non PSPos placement"
rprShift ::
(RoomPos -> Room -> Maybe (Point2, Float)) ->
(RoomPos -> Room -> Maybe ((Point2, Float), S.Set UsedPos)) ->
PlacementSpot
rprShift t = PSPos f (const id) Nothing
where
f rp r = case t rp r of
Just (p, a) -> Just (PS p a, rp & rpPlacementUse +~ 1)
Just ((p, a), xs) -> Just (PS p a, rp & rpPlacementUse <>~ xs)
Nothing -> Nothing
rprBoolShift ::
(RoomPos -> Room -> Bool) ->
((Point2, Float) -> (Point2, Float)) ->
((Point2, Float) -> ((Point2, Float), S.Set UsedPos)) ->
PlacementSpot
rprBoolShift t shift = PSPos f (const id) Nothing
where
f rp r
| t rp r = Just (PS p a, rp & rpPlacementUse +~ 1)
| t rp r = Just (PS p a, rp & rpPlacementUse <>~ xs)
| otherwise = Nothing
where
(p, a) = shift (_rpPos rp, _rpDir rp)
((p, a), xs) = shift (_rpPos rp, _rpDir rp)
unusedSpotAwayFromLink :: Float -> PlacementSpot
unusedSpotAwayFromLink x = rprBool $ \rp r ->
_rpLinkStatus rp == NotLink
&& _rpPlacementUse rp == 0
&& null (_rpPlacementUse rp)
&& all ((> x) . dist (_rpPos rp)) (usedRoomLinkPoss r)
setFallback :: Placement -> Placement -> Placement
@@ -137,14 +137,14 @@ setFallback fallback =
unusedOffPathAwayFromLink :: Float -> PlacementSpot
unusedOffPathAwayFromLink x = rprBool $ \rp r ->
_rpPlacementUse rp == 0
null (_rpPlacementUse rp)
&& all ((> x) . dist (_rpPos rp)) (usedRoomLinkPoss r)
&& rpIsOffPath rp
unusedSpotAwayFromInLink :: Float -> PlacementSpot
unusedSpotAwayFromInLink x = rprBool $ \rp r ->
_rpLinkStatus rp == NotLink
&& _rpPlacementUse rp == 0
&& null (_rpPlacementUse rp)
&& all ((> x) . dist (_rpPos rp)) (usedRoomInLinkPoss r)
--twoUnusedLinks :: (PlacementSpot -> PlacementSpot -> Placement) -> Placement
@@ -167,12 +167,12 @@ twoRoomPoss cond1 cond2 f = Placement (rprBool cond1) PutNothing Nothing Nothing
isInLnk :: RoomPos -> Bool
isInLnk rp = case _rpLinkStatus rp of
UsedInLink{} -> _rpPlacementUse rp == 0
UsedInLink{} -> null $ _rpPlacementUse rp
_ -> False
isOutLnk :: RoomPos -> Bool
isOutLnk rp = case _rpLinkStatus rp of
UsedOutLink{} -> _rpPlacementUse rp == 0
UsedOutLink{} -> null $ _rpPlacementUse rp
_ -> False
useUnusedLnk :: PlacementSpot
@@ -180,27 +180,30 @@ useUnusedLnk = rprBool isUnusedLnk
isUsedLnkUnplaced :: RoomPos -> Bool
isUsedLnkUnplaced rp = case _rpLinkStatus rp of
UsedOutLink{} -> _rpPlacementUse rp == 0
UsedInLink{} -> _rpPlacementUse rp == 0
UsedOutLink{} -> null (_rpPlacementUse rp)
UsedInLink{} -> null (_rpPlacementUse rp)
_ -> False
useRoomPosCond :: (RoomPos -> Room -> Bool) -> RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
useRoomPosCond f = useRoomPosRoomCond $ \rp r -> f rp r
useRoomPosCond f = useRoomPosRoomCond (S.singleton UsedPosLow) $ \rp r -> f rp r
useRoomPosRoomCond :: (RoomPos -> Room -> Bool) -> RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
useRoomPosRoomCond t rp r
| t rp r = Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse +~ 1)
useRoomPosRoomCond :: S.Set UsedPos
-> (RoomPos -> Room -> Bool) -> RoomPos -> Room
-> Maybe (PlacementSpot, RoomPos)
useRoomPosRoomCond xs t rp r
| t rp r = Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse <>~ xs)
| otherwise = Nothing
isUnusedLnkType :: RoomLinkType -> RoomPos -> Room -> Bool
isUnusedLnkType rlt rp _ = case _rpLinkStatus rp of
UnusedLink{_rplsType = rlts} -> rlt `S.member` rlts && _rpPlacementUse rp == 0
UnusedLink{_rplsType = rlts} -> rlt `S.member` rlts
&& null (_rpPlacementUse rp)
_ -> False
unusedSpotNearInLink :: Float -> PlacementSpot
unusedSpotNearInLink x = rprBool $ \rp r ->
_rpLinkStatus rp == NotLink
&& _rpPlacementUse rp == 0
&& null (_rpPlacementUse rp)
&& any ((< x) . dist (_rpPos rp)) (usedRoomInLinkPoss r)
usedRoomInLinkPoss :: Room -> [Point2]
@@ -224,7 +227,8 @@ atFstLnkOut = atNthLinkOut 0
atNthLinkOut :: Int -> PlacementSpot
atNthLinkOut n = rprBool $ \rp _ -> rp ^? rpLinkStatus . rplsChildNum == Just n
atNthLnkOutShiftBy :: Int -> ((Point2, Float) -> (Point2, Float)) -> PlacementSpot
atNthLnkOutShiftBy :: Int -> ((Point2, Float) -> ((Point2, Float),S.Set UsedPos))
-> PlacementSpot
atNthLnkOutShiftBy n = rprBoolShift $
\rp _ -> rp ^? rpLinkStatus . rplsChildNum == Just n
@@ -237,7 +241,7 @@ atNthLnkOutShiftBy n = rprBoolShift $
-- where
-- (p,a) = theshift (_rpPos rp,_rpDir rp)
atFstLnkOutShiftBy :: ((Point2, Float) -> (Point2, Float)) -> PlacementSpot
atFstLnkOutShiftBy :: ((Point2, Float) -> ((Point2, Float), S.Set UsedPos)) -> PlacementSpot
atFstLnkOutShiftBy = atNthLnkOutShiftBy 0
atFstLnkOutShiftInward :: Float -> PlacementSpot
@@ -245,7 +249,7 @@ atFstLnkOutShiftInward = atNthLnkOutShiftInward 0
atNthLnkOutShiftInward :: Int -> Float -> PlacementSpot
atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n $
\(p, a) -> (p +.+ rotateV a (V2 0 (negate x)), a)
\(p, a) -> ((p +.+ rotateV a (V2 0 (negate x)), a), S.singleton UsedPosLow)
shiftInBy :: Float -> (Point2, Float) -> (Point2, Float)
shiftInBy x (p, a) = (p +.+ rotateV a (V2 0 (negate x)), a)
@@ -255,9 +259,9 @@ shiftByV2 x (p, a) = (p +.+ rotateV a x, a)
-- this should probably check the placement use, but so should others: should
-- unify these
useLnkRoomPos :: RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
useLnkRoomPos rp _ = case _rpLinkStatus rp of
UnusedLink{} -> Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse +~ 1)
useLnkRoomPos :: S.Set UsedPos -> RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
useLnkRoomPos xs rp _ = case _rpLinkStatus rp of
UnusedLink{} -> Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse <>~ xs)
_ -> Nothing
psRandRanges :: (Float, Float) -> (Float, Float) -> (Float, Float) -> State StdGen (Point2, Float)
src/Dodge/Room/LasTurret.hs
+9 -6
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
module Dodge.Room.LasTurret where
--import Dodge.Item.Held.Cane
@@ -27,7 +28,7 @@ cenLasTur = do
roomNgon 8 200 <&> rmPmnts
.~ [ putLasTurret 0.02
, heightWallPS
(resetPLUse $ rprBoolShift (const . isInLnk) (shiftInBy 100))
(resetPLUse $ rprBoolShift (const . isInLnk) (shiftInBy 100 <&> (,S.singleton UsedPosLow)))
30
covershape
, thelight
@@ -60,7 +61,7 @@ lightSensByDoor i rm =
-- & rmOutPmnt . at i ?~ sensAboveDoor LaserSensor 20 (atFstLnkOutShiftBy sensorshift)
covershape = rectNSWE 10 (-10) (-20) 20
sensorshift (p, a) = (p +.+ rotateV a (V2 60 (-20)), a)
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
@@ -87,12 +88,13 @@ analyserByNthLink n proxreq i rm =
.++~ [ psPt (atNthLinkOut n) $ PutForeground $ verticalWire (V2 20 0) 0 80
, analyser
(SensorWithRequirement proxreq)
(atNthLnkOutShiftBy n (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
(atNthLnkOutShiftBy n (\(p, a) ->
((p +.+ rotateV a (V2 18.5 (-2.5)), a), S.singleton UsedPosLow)))
(atNthLnkOutShiftBy n sensorshift)
& plExternalID ?~ i
]
where
sensorshift (p, a) = (p +.+ rotateV a (V2 (-30) (-10)), a)
sensorshift (p, a) = ((p +.+ rotateV a (V2 (-30) (-10)), a), S.singleton UsedPosLow)
analyserByNthLinkWithPrompt ::
Int -> [TerminalLine] -> ProximityRequirement -> Int -> Placement
@@ -103,12 +105,13 @@ analyserByNthLinkWithPrompt n l proxreq i =
analyserWithPrompt
l
(SensorWithRequirement proxreq)
(atNthLnkOutShiftBy n (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
(atNthLnkOutShiftBy n (\(p, a) ->
((p +.+ rotateV a (V2 18.5 (-2.5)), a),S.singleton UsedPosLow)))
(atNthLnkOutShiftBy n sensorshift)
& plExternalID ?~ i
-- ]
where
sensorshift (p, a) = (p +.+ rotateV a (V2 (-30) (-10)), a)
sensorshift (p, a) = ((p +.+ rotateV a (V2 (-30) (-10)), a), S.singleton UsedPosLow)
analyserByDoor :: ProximityRequirement -> Int -> Room -> Room
analyserByDoor = analyserByNthLink 0
src/Dodge/Room/LongDoor.hs
+3 -1
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
-- | Rooms containing long doors, probably with a big reveal behind them.
module Dodge.Room.LongDoor where
@@ -105,7 +106,8 @@ addButtonSlowDoor x h rm = do
where
theterminal =
putMessageTerminal terminalColor (simpleTermMessage themessage)
& plSpot .~ rprBoolShift (isUnusedLnkType InLink) (shiftByV2 (V2 0 (-10)))
& plSpot .~ rprBoolShift (isUnusedLnkType InLink)
(shiftByV2 (V2 0 (-10)) <&> (,S.singleton UsedPosLow))
themessage =
[ "WARNING:"
, "LARGE BIOMASS DETECTED"
src/Dodge/Room/Pillar.hs
+2 -2
View File
@@ -87,7 +87,7 @@ roomPillarsSquare = do
++ concatMap (replicate nlns . makepill) [East, West]
where
makepill edge = sps (rprBool $ \rp _ -> t edge rp) smallPillar
t edge rp = any (f edge) (_rpType rp) && _rpPlacementUse rp == 0
t edge rp = any (f edge) (_rpType rp) && null (_rpPlacementUse rp)
f edge rpt = maybe False (PathFromEdge edge 0 `S.member`) (rpt ^? offPathFromEdges)
roomPillarsPassage :: RandomGen g => State g Room
@@ -114,7 +114,7 @@ roomPillars pillarsize w h wn hn = do
.~ rprBool
( \rp _ ->
rpIsOffPath rp
&& _rpPlacementUse rp == 0
&& null (_rpPlacementUse rp)
&& _rpLinkStatus rp == NotLink
)
)
src/Dodge/Room/Procedural.hs
+7 -5
View File
@@ -96,7 +96,8 @@ roomRect x y xn yn =
zipWith (lnkBothAnd (OnEdge edge) edgefrom1 edgefrom2) [0 ..]
. zipCountDown
pth = linksAndPath' lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
makeonpos (p, a) = RoomPos p 0 (S.singleton $ RoomPosOnPath $ makerpedges a) NotLink 0
makeonpos (p, a) = RoomPos p 0 (S.singleton $ RoomPosOnPath $ makerpedges a)
NotLink mempty
makerpedges (a, b) =
S.fromList
[ PathFromEdge South b
@@ -106,7 +107,8 @@ roomRect x y xn yn =
]
posps' = map (over _1 (+.+ V2 20 20)) $ gridPoints'' xd (xn + 1) yd (yn + 1)
interposps' = map (over _1 (+.+ V2 (20 + xd / 2) (20 + yd / 2))) $ gridPoints'' xd xn yd yn
makeoffpos (p, a) = RoomPos p 0 (S.singleton $ RoomPosOffPath $ makerpedges' a) NotLink 0
makeoffpos (p, a) = RoomPos
p 0 (S.singleton $ RoomPosOffPath $ makerpedges' a) NotLink mempty
makerpedges' (a, b) =
S.fromList
[ PathFromEdge South b
@@ -203,8 +205,8 @@ quarterRoomTri w = do
]
, _rmPmnts = b ++ [mntLS iShape (V2 (w -20) w) (V3 (w -20) (w -20) 70)]
, _rmPos =
[ RoomPos (V2 (w -20) (w -20)) pi S.empty NotLink 0
, RoomPos (V2 (w -15) (w -25)) pi S.empty NotLink 0
[ RoomPos (V2 (w -20) (w -20)) pi S.empty NotLink mempty
, RoomPos (V2 (w -15) (w -25)) pi S.empty NotLink mempty
]
, _rmBound = [[V2 0 0, V2 w w, V2 (- w) w]]
}
@@ -252,7 +254,7 @@ quarterRoomSquare w = do
]
, _rmPmnts = b ++ [blockLine (V2 (w / 2) (w / 2)) (V2 0 w)]
, _rmPos =
[ RoomPos p pi S.empty NotLink 0
[ RoomPos p pi S.empty NotLink mempty
| p <- [V2 20 (2 * w -40), V2 25 (2 * w -45)]
]
, --, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
src/Dodge/Room/Room.hs
+4 -4
View File
@@ -201,7 +201,7 @@ weaponBetweenPillars = do
let wpPos = rprBool $ \rp r ->
and
[ rpIsOnPath rp
, _rpPlacementUse rp == 0
, null $ _rpPlacementUse rp
, _rpLinkStatus rp == NotLink
, any ((< 100) . dist (_rpPos rp)) (usedRoomInLinkPoss r)
]
@@ -211,7 +211,7 @@ weaponBetweenPillars = do
randDirPS $
rprBool $ \rp r ->
rpIsOnPath rp
&& _rpPlacementUse rp == 0
&& null (_rpPlacementUse rp)
&& all ((> 100) . dist (_rpPos rp)) (usedRoomLinkPoss r)
( roomPillars 30 w h wn hn
<&> rmPmnts .++~ map (`sps` randC1) critPlacementSpots ++ [sps wpPos (PutFlIt wp)]
@@ -329,7 +329,7 @@ pistolerRoom = do
.++~ replicate
3
( psPtPl
(rprBool $ \rp _ -> _rpPlacementUse rp == 0 && rpIsOnPath rp)
(rprBool $ \rp _ -> null (_rpPlacementUse rp) && rpIsOnPath rp)
(PutCrit chaseCrit)
)
@@ -369,7 +369,7 @@ spawnerRoom = do
roomC x y <&> rmPmnts
.:~ psPtPl
( rprBool $ \rp _ ->
_rpPlacementUse rp == 0 && rpIsOnPath rp
null (_rpPlacementUse rp) && rpIsOnPath rp
&& xV2 (_rpPos rp) < x / 2
&& yV2 (_rpPos rp) < y / 2
)
src/Dodge/Room/SensorDoor.hs
+3 -3
View File
@@ -1,4 +1,4 @@
--{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TupleSections #-}
module Dodge.Room.SensorDoor (sensAboveDoor,sensorRoomRunPast) where
import Dodge.Data.MTRS
@@ -53,7 +53,7 @@ sensorRoomRunPast dt n = do
sensAboveDoor :: SensorType -> Float -> PlacementSpot -> Placement
sensAboveDoor sensetype wth ps =
extTrigLitPos
(atFstLnkOutShiftBy (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
(atFstLnkOutShiftBy (\(p, a) -> ((p +.+ rotateV a (V2 18.5 (-2.5)), a), S.singleton UsedPosHigh)))
(\tp -> Just $ damageSensor sensetype wth (_plMID tp) ps)
sensInsideDoor :: SensorType -> Int -> Room -> Room
@@ -65,7 +65,7 @@ sensInsideDoor senseType i rm = rm
, psPt atFstLnkOut . PutForeground $ verticalWire (V2 20 0) 0 80
, putMessageTerminal terminalColor
(textTerminal & tmCommands .:~ TCDamageCommand)
& plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10)
& plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10 <&> (, S.singleton UsedPosHigh))
, sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100) & plExternalID ?~ i
]
-- & rmOutPmnt . at i ?~ sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)
src/Dodge/Room/Tanks.hs
+2 -2
View File
@@ -56,7 +56,7 @@ randEdgeTank = do
& plSpot
.~ rprBool
( \rp _ ->
_rpPlacementUse rp == 0
null (_rpPlacementUse rp)
&& rpOffPathFromEdge (PathFromEdge edge 0) rp
)
@@ -85,7 +85,7 @@ randEdgeTanks i = do
& plSpot
.~ rprBool
( \rp _ ->
_rpPlacementUse rp == 0
null (_rpPlacementUse rp)
&& rpOffPathFromEdge (PathFromEdge edge 0) rp
)
src/Dodge/Room/Tutorial.hs
+3 -2
View File
@@ -1,5 +1,6 @@
module Dodge.Room.Tutorial where
import qualified Data.Set as S
import ShortShow
import Dodge.Data.MTRS
import Dodge.Room.Room
@@ -86,7 +87,7 @@ tutDrop = do
terminalColor
(defaultTerminal & tmBootLines .~ ss <> tlSetStatus (TerminalPressTo $ show x <>"QUIT") <> tlDoEffect TmWdWdPowerDownTerminal)
& plSpot .~ rprBoolShift isUnusedLnk
(\(p, a) -> (p + 10 *.* unitVectorAtAngle (a - pi/2), a))
(\(p, a) -> ((p + 10 *.* unitVectorAtAngle (a - pi/2), a), S.singleton UsedPosLow))
ss =
[makeTermLine "--------------------------------------------"
,makeTermLine "YOU CAN ONLY CARRY A LIMITED AMOUNT OF ITEMS"
@@ -151,7 +152,7 @@ tutHub = do
terminalColor
(defaultTerminal & tmBootLines .~ ss' <> tlSetStatus (TerminalPressTo "QUIT") <> tlDoEffect TmWdWdPowerDownTerminal)
& plSpot .~ rprBoolShift isUnusedLnk
(\(p, a) -> (p + 10 *.* unitVectorAtAngle (a - pi/2), a))
(\(p, a) -> ((p + 10 *.* unitVectorAtAngle (a - pi/2), a),S.singleton UsedPosLow))
ss' =
[ makeTermLine "---------------------------------------------"
, makeTermLine "HOLD [CAPS] AND SCROLL"
src/Dodge/Room/Warning.hs
+29 -19
View File
@@ -1,15 +1,19 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.Warning (warningRooms,addDoorToggleTerminal
, addDoorAtNthLinkToggleTerminal) where
module Dodge.Room.Warning (
warningRooms,
addDoorToggleTerminal,
addDoorAtNthLinkToggleTerminal,
) where
import Control.Monad
import Dodge.Default.Terminal
import Dodge.Data.BlBl
import Color
import Control.Monad
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Set as S
import Dodge.Cleat
import Dodge.Data.BlBl
import Dodge.Data.GenWorld
import Dodge.Default.Terminal
import Dodge.Placement.Instance
import Dodge.PlacementSpot
import Dodge.Room.Door
@@ -34,32 +38,37 @@ addDoorToggleTerminal :: [TerminalLine] -> Int -> Room -> Room
addDoorToggleTerminal = addDoorAtNthLinkToggleTerminal 0
addDoorAtNthLinkToggleTerminal :: Int -> [TerminalLine] -> Int -> Room -> Room
addDoorAtNthLinkToggleTerminal j xs i = (rmName .++~ "doorToggle-")
-- . (rmOutPmnt . at i ?~ outplace)
addDoorAtNthLinkToggleTerminal j xs i =
(rmName .++~ "doorToggle-")
-- . (rmOutPmnt . at i ?~ outplace)
. (rmPmnts .:~ outplace)
where
outplace =
extTrigLitPos
(atNthLnkOutShiftBy j (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
( Just . set plSpot (rprShift (moveToSideNthOutLink j))
(atNthLnkOutShiftBy j (\(p, a) -> ((p +.+ rotateV a (V2 18.5 (-2.5)), a), S.singleton UsedPosLow)))
( Just . set plSpot (rprShift (moveToSideNthOutLink (S.singleton UsedPosLow) j))
. putMessageTerminal terminalColor
. termMessages
) & plExternalID ?~ i
)
& plExternalID
?~ i
termMessages trpl =
lineOutputTerminal xs --(makeColorTermLine red "WARNING" : makeTermPara str)
& tmToggles .~ M.fromList
& tmToggles
.~ M.fromList
[("DOOR", TerminalToggle (fromJust $ _plMID trpl) (BlConst True))]
addWarningTerminal :: String -> Int -> Room -> Room
addWarningTerminal str = addDoorToggleTerminal
(makeColorTermLine red "WARNING" : makeTermPara str)
addWarningTerminal str =
addDoorToggleTerminal
(makeColorTermLine red "WARNING" : makeTermPara str)
lineOutputTerminal :: [TerminalLine] -> Terminal
lineOutputTerminal tls = defaultTerminal & tmBootLines .~ textInputBlurb tls
moveToSideNthOutLink :: Int -> RoomPos -> Room -> Maybe (Point2, Float)
moveToSideNthOutLink i rp rm = do
moveToSideNthOutLink :: S.Set UsedPos
-> Int -> RoomPos -> Room -> Maybe ((Point2, Float), S.Set UsedPos)
moveToSideNthOutLink xs i rp rm = do
j <- rp ^? rpLinkStatus . rplsChildNum
guard $ i == j
let rppos = _rpPos rp
@@ -67,11 +76,12 @@ moveToSideNthOutLink i rp rm = do
inpos = rppos +.+ rotateV rpdir (V2 0 (-12.5))
rtpos = inpos +.+ rotateV rpdir (V2 30 0)
ltpos = inpos +.+ rotateV rpdir (V2 (-30) 0)
return $ if any (isJust . intersectSegPolyFirst inpos ltpos) (_rmPolys rm)
return $
if any (isJust . intersectSegPolyFirst inpos ltpos) (_rmPolys rm)
then -- the above test may not work properly if the room polys are
-- complicated, it should really use created walls...
(rtpos, rpdir)
else (ltpos, rpdir)
((rtpos, rpdir), xs)
else ((ltpos, rpdir), xs)
--moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2, Float)
--moveToSideFirstOutLink rp rm = do
src/Dodge/Tree/Shift.hs
+3 -3
View File
@@ -91,7 +91,7 @@ posRms prs parenti@(parent, _) ((numChild, t@(Node childi _)) : its) tseq = do
, _rpDir = snd (lnkPosDir outlnk)
, _rpType = S.empty
, _rpLinkStatus = UsedOutLink (_rlType outlnk) numChild (snd childi)
, _rpPlacementUse = 0
, _rpPlacementUse = mempty
}
& rmChildren .:~ snd childi
shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk
@@ -106,7 +106,7 @@ posRms prs parenti@(parent, _) ((numChild, t@(Node childi _)) : its) tseq = do
, _rpDir = snd (lnkPosDir il)
, _rpType = S.empty
, _rpLinkStatus = UsedInLink (_rlType il) (snd parenti)
, _rpPlacementUse = 0
, _rpPlacementUse = mempty
}
shiftedt =
over
@@ -123,7 +123,7 @@ createUnusedLinkPos rm = rm & rmPos .++~ map f (_rmLinks rm)
, _rpDir = _rlDir rl
, _rpType = S.empty
, _rpLinkStatus = UnusedLink $ _rlType rl
, _rpPlacementUse = 0
, _rpPlacementUse = mempty
}
zipCount :: [a] -> [(Int, a)]