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/Data/Machine/Sensor.hs
-1
View File
@@ -36,7 +36,6 @@ data Sensor
data ProximityRequirement
= RequireHealth {_proxReqMinHealth :: Int}
| RequireEquipment {_proxReqEquipment :: ItemType}
| RequireImpossible
deriving (Show)
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
src/Dodge/Data/Terminal.hs
+2 -2
View File
@@ -14,7 +14,7 @@ import Data.Aeson
import Data.Aeson.TH
import qualified Data.Map.Strict as M
import Dodge.Data.BlBl
import Dodge.Data.Machine.Sensor.Type
--import Dodge.Data.Machine.Sensor.Type
import Dodge.Data.Terminal.Status
import Dodge.Data.WorldEffect
import Sound.Data
@@ -63,7 +63,7 @@ data TmWdWd
| TmWdWdDoDeathTriggers
| TmTmClearDisplayedLines
| TmTmSetStatus TerminalStatus
| TmGetDamageCoding SensorType
-- | TmGetDamageCoding SensorType
| TmGetSensor String
makeLenses ''Terminal
src/Dodge/Default.hs
+1 -1
View File
@@ -69,6 +69,6 @@ defaultProximitySensor =
ProximitySensor
{ _proxStatus = NotClose
, _proxDist = 40
, _proxRequirement = RequireImpossible
, _proxRequirement = RequireHealth 0
, _sensToggle = False
}
src/Dodge/Placement/Instance/Analyser.hs
+2 -8
View File
@@ -1,6 +1,4 @@
module Dodge.Placement.Instance.Analyser (
analyser,
) where
module Dodge.Placement.Instance.Analyser (analyser) where
import Color
import Dodge.Data.GenWorld
@@ -9,11 +7,7 @@ import Dodge.Placement.Instance
import Dodge.Terminal
import LensHelp
analyser ::
ProximityRequirement ->
PlacementSpot ->
PlacementSpot ->
Placement
analyser :: ProximityRequirement -> PlacementSpot -> PlacementSpot -> Placement
analyser proxreq pslight psmc = extTrigLitPos pslight $ \tp ->
Just $
plSpot .~ psmc $
src/Dodge/Placement/Instance/Sensor.hs
+1 -6
View File
@@ -12,12 +12,7 @@ import Dodge.LevelGen.PlacementHelper
import Dodge.LightSource
import Geometry
damageSensor ::
SensorType ->
Float ->
Maybe Int ->
PlacementSpot ->
Placement
damageSensor :: SensorType -> Float -> Maybe Int -> PlacementSpot -> Placement
damageSensor dt wdth mtrid ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1) $
\lsid -> psPtJpl ps
. PutUsingGenParams
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
src/Dodge/Terminal.hs
+28 -20
View File
@@ -52,38 +52,46 @@ termSoundLine sid = TLine 0 [] (TmWdWdTermSound sid)
termTextColor :: Color
termTextColor = greyN 0.9
getCommands :: Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
getCommands tm = foldMap (getCommand tm) $ tm ^. tmCommands
getCommands :: World -> Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
getCommands w tm = foldMap (getCommand w tm) $ tm ^. tmCommands
getCommand :: Terminal -> TCom -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
getCommand tm = \case
getCommand :: World
-> Terminal -> TCom -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
getCommand w tm = \case
TCInfo x z -> PTE.singleton x (PTE.singleton "" (makeTermPara z))
TCBase -> helpCommand <> quitCommand
TCDamageCommand -> damageCodeCommand
TCDamageCommand -> damageCodeCommand w
TCToggles -> toggleCommand tm
TCSensorInfo -> sensorCommand
TCSensorInfo -> sensorCommand w tm
damageCodeCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
damageCodeCommand = PTE.singleton "DAMAGECODE" $ PTE.fromList $ mapMaybe f [minBound ..]
damageCodeCommand :: World -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
damageCodeCommand w = PTE.singleton "DAMAGECODE" $ PTE.fromList $ mapMaybe f [minBound ..]
where
f :: SensorType -> Maybe (String, [TerminalLine])
f st = do
s <- g st
return (s, [TLine 0 [] $ TmGetDamageCoding st])
return (s, decodeSensorType st w)
g =
fmap (map toUpper . reverse) . List.stripPrefix (reverse "Sensor")
. reverse
. show
decodeSensorType :: SensorType -> World -> [TerminalLine]
decodeSensorType st w = fromMaybe [] $ do
x <- w ^? cWorld . cwGen . cwgParams . sensorCoding . ix st
return [makeTermLine $ show x]
-- ugly, when changing check getSensorInfo
sensorCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
sensorCommand =
PTE.singleton "SENSOR" $
PTE.fromList
[ ("REQUIREMENT", [])
, ("DISTANCE", [])
, ("STATUS", [])
sensorCommand :: World -> Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
sensorCommand w tm = PTE.singleton "SENSOR" $ fromMaybe mempty $ do
ProximitySensor _ d r b <- w ^? cWorld . lWorld . machines . ix (tm ^. tmMachineID) . mcType . _McSensor
return $ PTE.fromList
[ ("REQUIREMENT", [makeTermLine $ show r] )
, ("RADIUS", [makeTermLine $ show d])
, ("STATUS", [makeTermLine $ show b])
]
toggleCommand :: Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
toggleCommand tm =
@@ -132,10 +140,10 @@ commandColor :: Color
commandColor = yellow
-- ugly
tabComplete :: String -> Terminal -> Terminal
tabComplete s' tm = case PTE.lookup s $ getCommands tm of
tabComplete :: String -> World -> Terminal -> Terminal
tabComplete s' w tm = case PTE.lookup s $ getCommands w tm of
Just m -> f (s ++ " ") $ PTE.toList $ PTE.lookupPrefix a m
Nothing -> f "" $ PTE.toList $ PTE.lookupPrefix s $ getCommands tm
Nothing -> f "" $ PTE.toList $ PTE.lookupPrefix s $ getCommands w tm
where
ss = words s'
s = fromMaybe "" $ ss ^? ix 0
@@ -183,7 +191,7 @@ terminalReturnEffect tmid w = fromMaybe w $ do
let ss = fromMaybe [makeTermLine "ERROR: INPUT NOT RECOGNISED"] $ do
let args = words s
x <- args ^? ix 0
teff <- PTE.lookup x (getCommands tm)
teff <- PTE.lookup x (getCommands w tm)
let y = fromMaybe "" (args ^? ix 1)
PTE.lookup y teff
return $ w
src/Dodge/Update/Input/InGame.hs
+1 -1
View File
@@ -407,7 +407,7 @@ updateKeysTextInputTerminal tmid u =
tryTabComplete
| u ^. uvWorld . input . pressedKeys . at ScancodeTab == Just 0 = fromMaybe id $ do
s <- u ^? uvWorld . cWorld . lWorld . terminals . ix tmid . tmStatus . tiText
return $ uvWorld . cWorld . lWorld . terminals . ix tmid %~ tabComplete s
return $ uvWorld . cWorld . lWorld . terminals . ix tmid %~ tabComplete s (u ^. uvWorld)
| otherwise = id
updateKeyInGame :: Universe -> Scancode -> Int -> Universe
src/Dodge/Update/Scroll.hs
+2 -2
View File
@@ -138,13 +138,13 @@ terminalWheelEvent yi tmid w
wrapup s coms = PTE.findSuccessor s coms <|> PTE.findMin coms
wrapdown s coms = PTE.findPredecessor s coms <|> PTE.findMax coms
f tm = fromMaybe tm $ do
let coms = getCommands tm
let coms = getCommands w tm
x <- tm ^? tmStatus . tiText
let s = fromMaybe "" $ x ^? to words . ix 0
(s',_) <- dowrap s coms
return $ tm & tmStatus . tiText .~ s'
g tm = fromMaybe tm $ do
let coms = getCommands tm
let coms = getCommands w tm
x <- tm ^? tmStatus . tiText
let s = fromMaybe "" $ x ^? to words . ix 0
y = fromMaybe "" $ x ^? to words . ix 1
src/Dodge/WorldEffect.hs
+7 -20
View File
@@ -101,26 +101,18 @@ doTmWdWd tmwdwd = case tmwdwd of
TmTmClearDisplayedLines -> \tm -> fromMaybe id $ do
tid <- tm ^? tmID
return $ cWorld . lWorld . terminals . ix tid . tmDisplayedLines .~ []
TmGetDamageCoding st -> \tm w -> fromMaybe w $ do
tid <- tm ^? tmID
return $
w & cWorld . lWorld . terminals . ix tid . tmFutureLines
.~ decodeSensorType st w
-- TmGetDamageCoding st -> \tm w -> fromMaybe w $ do
-- tid <- tm ^? tmID
-- return $
-- w & cWorld . lWorld . terminals . ix tid . tmFutureLines
-- .~ decodeSensorType st w
TmGetSensor s -> \tm w -> fromMaybe w $ do
tid <- tm ^? tmID
return $ w & cWorld . lWorld . terminals . ix tid . tmFutureLines .~ getSensorInfo w tm s
return $ w & cWorld . lWorld . terminals . ix tid . tmFutureLines
.~ getSensorInfo w tm s
TmTmSetStatus x -> \tm -> fromMaybe id $ do
tid <- tm ^? tmID
return $ cWorld . lWorld . terminals . ix tid . tmStatus .~ x
-- TmDisplayCommands -> \tm -> fromMaybe id $ do
-- tid <- tm ^? tmID
-- return $ cWorld . lWorld . terminals . ix tid %~ tabComplete ""
--return $ cWorld . lWorld . terminals . ix tid . tmFutureLines .~
-- makeColorTermPara commandColor
-- (unwords (map fst (PTE.toList $ getCommands tm)))
-- TmTmSetPartialCommand x -> \tm -> fromMaybe id $ do
-- tid <- tm ^? tmID
-- return $ cWorld . lWorld . terminals . ix tid . tmPartialCommand .~ x
TmWdId -> const id
TmWdWdPowerDownTerminal -> powerDownTerminal
TmWdWdDeactivateTerminal -> deactivateTerminal
@@ -149,11 +141,6 @@ exitTerminalSubInv w = case w ^? hud . hudElement . subInventory . termID of
.~ NoSubInventory --MouseInvNothing
_ -> w
decodeSensorType :: SensorType -> World -> [TerminalLine]
decodeSensorType st w = fromMaybe [] $ do
x <- w ^? cWorld . cwGen . cwgParams . sensorCoding . ix st
return [makeTermLine $ show x]
-- ugly, when changing check sensorCommand
getSensorInfo :: World -> Terminal -> String -> [TerminalLine]
getSensorInfo w tm = \case