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

Cleanup, fix damage code terminal bug

Browse Source
This commit is contained in:
justin
2025-08-20 15:59:22 +01:00
parent 9daa27ee8b
commit 4bf9ce59d5
12 changed files with 153 additions and 177 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Room/SensorDoor.hs
+16 -27
View File
@@ -1,7 +1,5 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.SensorDoor where
--import Dodge.RoomLink
module Dodge.Room.SensorDoor (sensAboveDoor,sensorRoomRunPast) where
import qualified Data.Set as S
import Dodge.Annotation.Data
@@ -28,8 +26,7 @@ sensorRoom :: RandomGen g => SensorType -> Int -> State g (Tree Room)
sensorRoom senseType n = do
rm <- takeOne [roomNgon 8 200, roomRectAutoLinks 200 200]
cenroom <- shuffleLinks $ sensInsideDoor senseType n rm
return $
treePost
return $ treePost
[ door
, cenroom & rmLinkEff .~ f
, triggerDoorRoom n
@@ -48,17 +45,9 @@ sensorRoom senseType n = do
sensorRoomRunPast :: RandomGen g => SensorType -> Int -> State g MTRS
sensorRoomRunPast dt n = do
t <- sensorRoom dt n
rToOnward "sensorRoomRunPast" $
t
& applyToSubforest
[0]
( ++
[ treePost
[ door & rmConnectsTo .~ (\s -> S.member InLink s && not (S.member BlockedLink s))
, cleatLabel n corridor
]
]
)
rToOnward "sensorRoomRunPast" $ t
& applyToSubforest [0]
( ++ [ treePost [ door & rmConnectsTo .~ (\s -> S.member InLink s && not (S.member BlockedLink s)) , cleatLabel n corridor ] ])
sensAboveDoor :: SensorType -> Float -> PlacementSpot -> Placement
sensAboveDoor sensetype wth ps =
@@ -67,14 +56,14 @@ sensAboveDoor sensetype wth ps =
(\tp -> Just $ damageSensor sensetype wth (_plMID tp) ps)
sensInsideDoor :: SensorType -> Int -> Room -> Room
sensInsideDoor senseType outplid rm =
rm
& rmName .++~ take 4 (show senseType)
& rmPmnts
.++~ [ 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
, putMessageTerminal terminalColor (textTerminal & tmCommands .:~ TCDamageCommand)
& plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10)
]
& rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid]
sensInsideDoor senseType outplid rm = rm
& rmName .++~ take 4 (show senseType)
& rmPmnts
.++~ [ 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
, putMessageTerminal terminalColor
(textTerminal & tmCommands .:~ TCDamageCommand)
& plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10)
]
& rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid]
src/Dodge/Room/Warning.hs
+28 -22
View File
@@ -1,5 +1,5 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.Warning where
module Dodge.Room.Warning (warningRooms) where
import Dodge.Data.BlBl
import Color
@@ -21,10 +21,6 @@ import Geometry
import LensHelp
import RandomHelp
--import Data.Char
--import Data.Tree
--import qualified Data.Text as T
warningRooms :: RandomGen g => String -> Int -> State g (MetaTree Room String)
warningRooms str n = do
rm <- do
@@ -34,8 +30,7 @@ warningRooms str n = do
rToOnward "warningRooms" $ treePost [door, cenroom, triggerDoorRoom n, cleatOnward door]
addWarningTerminal :: String -> Int -> Room -> Room
addWarningTerminal str outplid =
(rmName .++~ "warningTerm-")
addWarningTerminal str outplid = (rmName .++~ "warningTerm-")
. (rmOutPmnt .~ [OutPlacement outplace outplid])
where
outplace =
@@ -48,21 +43,32 @@ addWarningTerminal str outplid =
termMessages trpl =
lineOutputTerminal (makeColorTermLine red "WARNING" : makeTermPara str)
& tmCommands .:~ TCToggles
& tmToggles
.~ M.fromList
& tmToggles .~ M.fromList
[("DOOR", TerminalToggle (fromJust $ _plMID trpl) (BlConst True))]
moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2, Float)
moveToSideFirstOutLink rp rm = case rp ^? rpLinkStatus . rplsChildNum of
Just 0 ->
let rppos = _rpPos rp
rpdir = _rpDir rp
inpos = rppos +.+ rotateV rpdir (V2 0 (-12.5))
rtpos = inpos +.+ rotateV rpdir (V2 30 0)
ltpos = inpos +.+ rotateV rpdir (V2 (-30) 0)
in 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...
Just (rtpos, rpdir)
else Just (ltpos, rpdir)
_ -> Nothing
moveToSideFirstOutLink rp rm = do
0 <- rp ^? rpLinkStatus . rplsChildNum
let rppos = _rpPos rp
rpdir = _rpDir rp
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)
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)
--moveToSideFirstOutLink rp rm = case rp ^? rpLinkStatus . rplsChildNum of
-- Just 0 ->
-- let rppos = _rpPos rp
-- rpdir = _rpDir rp
-- inpos = rppos +.+ rotateV rpdir (V2 0 (-12.5))
-- rtpos = inpos +.+ rotateV rpdir (V2 30 0)
-- ltpos = inpos +.+ rotateV rpdir (V2 (-30) 0)
-- in 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...
-- Just (rtpos, rpdir)
-- else Just (ltpos, rpdir)
-- _ -> Nothing