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

Cleanup

Browse Source
This commit is contained in:
justin
2025-08-19 17:29:36 +01:00
parent 2f9cea1b69
commit b07280e50c
13 changed files with 107 additions and 280 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Button/Event.hs
+1 -2
View File
@@ -5,7 +5,6 @@ import Control.Lens
import Dodge.Data.World
import Dodge.SoundLogic
import Dodge.WorldEffect
import Sound.Data
doButtonEvent :: ButtonEvent -> Button -> World -> World
doButtonEvent = \case
@@ -18,5 +17,5 @@ doButtonEvent = \case
buttonFlip :: WdWd -> Button -> World -> World
buttonFlip f bt =
doWdWd f
. soundWithStatus ToStart (LeverSound 0) (bt ^. btPos) click1S Nothing
. soundStart (ButtonSound (bt ^. btID)) (bt ^. btPos) click1S Nothing
. over (cWorld . lWorld . buttons . ix (bt ^. btID) . btEvent . btOn) not
src/Dodge/Data/Button.hs
-1
View File
@@ -32,7 +32,6 @@ data Button = Button
, _btRot :: Float
, _btEvent :: ButtonEvent
, _btID :: Int
-- , _btTermMID :: Maybe Int
}
makeLenses ''Button
src/Dodge/Data/SoundOrigin.hs
+1 -1
View File
@@ -34,7 +34,7 @@ data SoundOrigin
| GlassBreakSound Int
| MaterialSound Material Int
| TeleSound Int
| LeverSound Int
| ButtonSound Int
| Explosion Int
| Tap Int
| EBSound Int
src/Dodge/Default.hs
+2 -7
View File
@@ -46,16 +46,11 @@ defaultMachine =
}
defaultButton :: Button
defaultButton =
Button
{ _btPos = V2 0 0
defaultButton = Button
{ _btPos = 0
, _btRot = 0
, _btEvent = ButtonPress False NoWorldEffect (dark red)
, _btID = 0
-- , _btState = BtOff
-- , _btTermMID = Nothing
-- , _btName = ""
-- , _btColor = red
}
defaultPP :: PressPlate
src/Dodge/Inventory.hs
-1
View File
@@ -116,7 +116,6 @@ rmInvItem cid invid w =
| x > invid || Just x == maxk = max 0 $ x - 1
| otherwise = x
-- this looks ugly...
updateCloseObjects :: World -> World
updateCloseObjects w =
src/Dodge/Placement/Instance/Terminal.hs
+1 -10
View File
@@ -17,7 +17,7 @@ putTerminal :: Color -> Machine -> Terminal -> Placement
putTerminal col mc tm =
ps0PushPS (PutTerminal (tm & tmExternalColor .~ col)) $
\tmpl -> Just $
ps0PushPS (PutButton termButton) $
ps0PushPS (PutButton defaultButton) $
\btpl -> Just $
pt0
( PutMachine
@@ -48,14 +48,5 @@ putMessageTerminal col =
& mcType .~ McTerminal
& mcHP .~ 100
termButton :: Button
termButton =
Button
{ _btPos = 0
, _btRot = 0
, _btEvent = ButtonAccessTerminal 0
, _btID = 0
}
terminalColor :: Color
terminalColor = dark magenta
src/Dodge/Render/HUD.hs
+5 -7
View File
@@ -343,13 +343,12 @@ combineInventoryExtra ::
Configuration ->
World ->
Picture
combineInventoryExtra sss msel cfig w = fromMaybe mempty $ do
combineInventoryExtra sss msel cfig w = fold $ do
(i, j) <- msel
si <- sss ^? ix i . ssItems . ix j
let col = _siColor si
lnks <- si ^? siPayload . ciInvIDs
return (lnkMidPosInvSelsCol cfig w j col lnks)
<> foldMap invcursor lnks
return (lnkMidPosInvSelsCol cfig w j col lnks) <> foldMap invcursor lnks
where
invcursor i = do
sss' <- w ^? hud . hudElement . diSections
@@ -362,12 +361,12 @@ combineInventoryExtra sss msel cfig w = fromMaybe mempty $ do
(Just (0, i))
drawTerminalDisplay :: Int -> Configuration -> LWorld -> Picture
drawTerminalDisplay tid cfig w = fromMaybe mempty $ do
drawTerminalDisplay tid cfig w = fold $ do
tm <- w ^? terminals . ix tid
let tsize = getMaxLinesTM + 1
return $
invHead cfig ("T-" ++ show tid)
<> drawSelectionList secondColumnParams cfig (thesellist tm)
<> drawSelectionList secondColumnParams cfig (f tm)
<> color
(withAlpha 0.5 green) -- consider integrating termScreenColor somehow
(drawSelectionListBackground secondColumnParams cfig tsize)
@@ -375,8 +374,7 @@ drawTerminalDisplay tid cfig w = fromMaybe mempty $ do
where
toselitm (str, col) = SelectionItem [str] 1 55 True col 0 ()
-- not sure if the width (55) is correct here
thesellist tm = thelist tm
thelist tm =
f tm =
map toselitm . displayTermInput tm
. reverse
. take getMaxLinesTM
src/Dodge/SoundLogic.hs
+1 -1
View File
@@ -11,7 +11,7 @@ module Dodge.SoundLogic (
soundContinueVol,
soundMultiFrom,
stopSoundFrom,
soundWithStatus,
-- soundWithStatus,
-- * helper to determine the angle of a sound given a world position
soundAngle,
src/Dodge/Terminal.hs
+13 -187
View File
@@ -3,8 +3,6 @@
module Dodge.Terminal (
makeTermLine,
connectionBlurbLines,
powerDownTerminal,
deactivateTerminal,
textTerminal,
simpleTermMessage,
damageCodeCommand,
@@ -14,14 +12,10 @@ module Dodge.Terminal (
toggleCommand,
terminalReturnEffect,
getCommands,
makeColorTermPara,
commandColor,
tabComplete,
tlSetStatus,
) where
--import Dodge.Data.WorldEffect
import Color
import Data.Char
import qualified Data.List as List
@@ -42,10 +36,7 @@ import LensHelp
import Sound.Data
textTerminal :: Terminal
textTerminal =
defaultTerminal
{ _tmBootLines = connectionBlurb
}
textTerminal = defaultTerminal{_tmBootLines = connectionBlurb}
connectionBlurbLines :: [TerminalLine] -> [TerminalLine]
connectionBlurbLines tls =
@@ -55,53 +46,6 @@ connectionBlurbLines tls =
++ tls
++ [TLine 10 [TerminalLineConst "READY FOR INPUT" termTextColor] (TmTmSetStatus (TerminalTextInput ""))]
-- ++ [TerminalLineEffect 0 (TmTmSetStatus (TerminalTextInput "" 0))]
--quitCommand :: TerminalCommand
--quitCommand =
-- TerminalCommand
-- { _tcString = "QUIT"
-- , _tcAlias = ["Q", "EXIT", "X", "SHUTDOWN", ""]
-- , _tcHelp = "Disconnects the terminal."
-- , _tcEffect = TerminalCommandArguments $ NoArguments [TLine 0 [] TmWdWdDisconnectTerminal]
-- }
--helpCommand :: TerminalCommand
--helpCommand =
-- TerminalCommand
-- { _tcString = "HELP"
-- , _tcAlias = ["H", "MAN"]
-- , _tcHelp = "Displays help for a specific command."
-- , _tcEffect = TerminalCommandEffectHelp -- \tm -> OneArgument "AN AVAILABLE COMMAND" . getCommandsHelp tm
-- }
--getCommandsHelp :: Terminal -> World -> M.Map String [TerminalLine]
--getCommandsHelp tm w = foldr f mempty $ getCommands tm
-- where
-- f tc =
-- M.insert
-- (_tcString tc)
-- ( [ makeTermLine "Command:"
-- , makeColorTermLine commandColor (_tcString tc)
-- , makeTermLine "Aliases:"
-- , makeColorTermLine commandColor (unwords (_tcAlias tc))
-- ]
-- ++ case argumentHelp tc tm w of
-- (arghelp, Nothing) -> makeTermPara $ _tcHelp tc ++ " " ++ arghelp
-- (arghelp, Just args) ->
-- makeTermPara (_tcHelp tc ++ " " ++ arghelp)
-- ++ [makeColorTermLine commandColor $ unwords args]
-- )
--commandsCommand :: TerminalCommand
--commandsCommand =
-- TerminalCommand
-- { _tcString = "COMMANDS"
-- , _tcAlias = ["COMMAND", "COM"]
-- , _tcHelp = "Displays available commands."
-- , _tcEffect = TerminalCommandEffectCommands
-- }
connectionBlurb :: [TerminalLine]
connectionBlurb = connectionBlurbLines []
@@ -208,97 +152,6 @@ tabComplete s' tm = case PTE.lookup s $ getCommands tm of
<> [TLine 1 [] . TmTmSetStatus $ TerminalTextInput s]
)
--doTerminalCommandEffect :: TerminalCommandEffect -> Terminal -> World -> EffectArguments
--doTerminalCommandEffect tce = case tce of
-- TerminalCommandArguments eas -> \_ _ -> eas
-- TerminalCommandEffectDamageCoding -> \_ -> OneArgument "a damage type" . getDamageCoding
-- TerminalCommandEffectSensorParameter -> \tm -> OneArgument "a sensor parameter" . sensorInfoMap tm
-- TerminalCommandEffectLinkedObject -> \tm _ -> OneArgument "a linked object" (togglesToEffects tm)
-- TerminalCommandEffectHelp -> \tm -> OneArgument "an available command" . getCommandsHelp tm
-- TerminalCommandEffectNoArgumentsStr str -> \_ _ -> NoArguments (makeTermPara str)
-- TerminalCommandEffectCommands -> \tm _ ->
-- NoArguments
-- ( makeTermLine "Available commands:" :
-- makeColorTermPara commandColor (unwords (map _tcString $ getCommands tm))
-- )
-- TerminalCommandEffectSingleCommand eff followingLines -> \_ _ -> NoArguments $ TLine 0 [] (TmWdWdfromWdWd eff) : map makeTermLine followingLines
-- TerminalCommandEffectNone -> \_ _ -> NoArguments []
--argumentHelp :: TerminalCommand -> Terminal -> World -> (String, Maybe [String])
--argumentHelp tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of
-- NoArguments{} -> ("Any arguments provided to this command are ignored.", Nothing)
-- OneArgument argtype argm ->
-- ( "Expects " ++ argtype ++ " as argument. Available arguments: "
-- , Just (M.keys argm)
-- )
--infoCommand :: String -> TerminalCommand
--infoCommand str =
-- TerminalCommand
-- { _tcString = "INFORMATION"
-- , _tcAlias = ["INFO", "I"]
-- , _tcHelp = "DISPLAYS INFORMATION CONCERNING THE TERMINAL."
-- , _tcEffect = TerminalCommandEffectNoArgumentsStr str -- \_ _ -> NoArguments (makeTermPara str)
-- }
--singleCommand :: [String] -> String -> [String] -> String -> WdWd -> TerminalCommand
--singleCommand followingLines command aliases htext eff =
-- TerminalCommand
-- { _tcString = command
-- , _tcAlias = aliases
-- , _tcHelp = htext
-- , _tcEffect = TerminalCommandEffectSingleCommand eff followingLines
-- }
--getDamageCoding :: World -> M.Map String [TerminalLine]
--getDamageCoding = decodedtmap . _sensorCoding . _cwgParams . _cwGen . _cWorld
--sensorInfoMap :: Terminal -> World -> M.Map String [TerminalLine]
--sensorInfoMap tm w =
-- M.fromList
-- [ ("Requirement", getSensor _proxRequirement tm w)
-- , ("Distance", getSensor _proxDist tm w)
-- , ("Currentstatus", getSensor _proxStatus tm w)
-- , ("Paststatus", getSensor _sensToggle tm w)
-- ]
--getSensor :: Show a => (Sensor -> a) -> Terminal -> World -> [TerminalLine]
--getSensor f tm w =
-- maybe
-- []
-- (makeTermPara . map toLower . show . f)
-- (w ^? cWorld . lWorld . machines . ix (_tmMachineID tm) . mcType . _McSensor)
--sensorCommand :: TerminalCommand
--sensorCommand =
-- TerminalCommand
-- { _tcString = "SENSOR"
-- , _tcAlias = ["SEN"]
-- , _tcHelp = "Access information concerning the connected sensor."
-- , _tcEffect = TerminalCommandEffectSensorParameter -- \tm -> OneArgument "A SENSOR PARAMETER" . sensorInfoMap tm
-- }
powerDownTerminal :: Terminal -> World -> World
powerDownTerminal tm =
(cWorld . lWorld . terminals . ix (_tmID tm) . tmStatus .~ TerminalOff)
. ( cWorld . lWorld . terminals . ix (_tmID tm) . tmDisplayedLines .~ []
)
. exitTerminalSubInv
deactivateTerminal :: Terminal -> World -> World
deactivateTerminal tm =
(cWorld . lWorld . terminals . ix (_tmID tm) . tmStatus .~ TerminalOff)
. ( cWorld . lWorld . terminals . ix (_tmID tm) . tmDisplayedLines .~ []
)
. exitTerminalSubInv
exitTerminalSubInv :: World -> World
exitTerminalSubInv w = case w ^? hud . hudElement . subInventory . termID of
Just _ ->
w & hud . hudElement . subInventory
.~ NoSubInventory --MouseInvNothing
_ -> w
--damageCodeCommand :: TerminalCommand
--damageCodeCommand =
-- TerminalCommand
@@ -323,47 +176,20 @@ exitTerminalSubInv w = case w ^? hud . hudElement . subInventory . termID of
simpleTermMessage :: [String] -> Terminal
simpleTermMessage strs = defaultTerminal & tmBootLines .~ map makeTermLine strs
--commandFutureLines :: String -> Terminal -> World -> [TerminalLine]
--commandFutureLines s tm w = fromMaybe [errline "^ Invalid command"] $ do
-- (str, args) <- safeUncons $ words s
-- command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) (getCommands tm)
-- case doTerminalCommandEffect (_tcEffect command) tm w of
-- NoArguments tls -> Just tls
-- OneArgument argtype m ->
-- let setpartial
-- | null (_tmPartialCommand tm) =
-- TLine 0 [] (TmTmSetPartialCommand (Just command)) :
-- makeTermPara ("Expects " ++ argtype ++ " as an argument")
-- | otherwise =
-- TLine 0 [] (TmTmSetPartialCommand Nothing) :
-- makeTermPara "No argument input, cancelling"
-- in Just $
-- fromMaybe setpartial $
-- safeHead args >>= (m M.!?)
-- where
-- errline = makeColorTermLine red
terminalReturnEffect :: Int -> World -> World
terminalReturnEffect tmid w = fromMaybe w $ do
tm <- w ^? cWorld . lWorld . terminals . ix tmid
s <- tm ^? tmStatus . tiText
return $
runTerminalInput s tm $
w
& cWorld . lWorld . terminals . ix tmid . tmDisplayedLines
.:~ (getPromptTM ++ s, termTextColor)
runTerminalInput :: String -> Terminal -> World -> World
runTerminalInput s tm w =
w & cWorld . lWorld . terminals . ix (_tmID tm)
%~ ( (tmFutureLines ++.~ ss <> [TLine 1 [] (TmTmSetStatus $ TerminalTextInput "")])
. (tmCommandHistory %~ take 10 . (s :))
. (tmStatus .~ TerminalLineRead)
)
let ss = fromMaybe [makeTermLine "ERROR: INPUT NOT RECOGNISED"] $ do
let args = words s
x <- args ^? ix 0
teff <- PTE.lookup x (getCommands tm)
let y = fromMaybe "" (args ^? ix 1)
PTE.lookup y teff
return $ w
& totm . tmDisplayedLines .:~ (getPromptTM ++ s, termTextColor)
& totm . tmFutureLines .~ ss <> tlSetStatus (TerminalTextInput "")
& totm . tmCommandHistory %~ take 10 . (s :)
& totm . tmStatus .~ TerminalLineRead
where
ss = fromMaybe [makeTermLine "ERROR: INPUT NOT RECOGNISED"] $ do
let args = words s
x <- args ^? ix 0
teff <- PTE.lookup x (getCommands tm)
let y = fromMaybe "" (args ^? ix 1)
PTE.lookup y teff
totm = cWorld . lWorld . terminals . ix tmid
src/Dodge/TestString.hs
+1 -2
View File
@@ -28,8 +28,7 @@ import qualified IntMapHelp as IM
import qualified Data.Map.Strict as M
testStringInit :: Universe -> [String]
testStringInit u = [show $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crHP
, show $ u ^? uvWorld . timeFlow . respawnDelay]
testStringInit u = map show $ u ^.. uvWorld . cWorld . lWorld . terminals . each . tmStatus
-- map shortShow (u ^.. uvWorld . cWorld . lWorld . debris . each . to g)
-- where
-- g db = (pz,z,norm v)
src/Dodge/WorldEffect.hs
+30 -10
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.WorldEffect (
doWdWd,
accessTerminal,
@@ -52,10 +53,9 @@ doWdWd we = case we of
return $ heldEffectMuzzles loc cr w
accessTerminal :: Int -> World -> World
accessTerminal tid w = fromMaybe w $ do -- should possibly check the terminal actually exists
return $
w & hud . hudElement . subInventory .~ DisplayTerminal tid
& cWorld . lWorld . terminals . ix tid %~ tryToBoot
accessTerminal tid =
(hud . hudElement . subInventory .~ DisplayTerminal tid)
. (cWorld . lWorld . terminals . ix tid %~ tryToBoot)
where
tryToBoot tm = case _tmStatus tm of
TerminalTextInput{} -> tm
@@ -98,17 +98,18 @@ doTmWdWd tmwdwd = case tmwdwd of
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
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
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 ""
-- 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)))
@@ -124,11 +125,30 @@ doTmWdWd tmwdwd = case tmwdwd of
TmWdWdDoDeathTriggers -> doDeathTriggers
TmWdWdfromWdWd f -> \_ -> doWdWd f
powerDownTerminal :: Terminal -> World -> World
powerDownTerminal tm =
(cWorld . lWorld . terminals . ix (_tmID tm) . tmStatus .~ TerminalOff)
. (cWorld . lWorld . terminals . ix (_tmID tm) . tmDisplayedLines .~ [])
. exitTerminalSubInv
deactivateTerminal :: Terminal -> World -> World
deactivateTerminal tm =
(cWorld . lWorld . terminals . ix (_tmID tm) . tmStatus .~ TerminalDeactivated)
. (cWorld . lWorld . terminals . ix (_tmID tm) . tmDisplayedLines .~ [])
. exitTerminalSubInv
exitTerminalSubInv :: World -> World
exitTerminalSubInv w = case w ^? hud . hudElement . subInventory . termID of
Just _ ->
w & hud . hudElement . subInventory
.~ 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