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
2022-06-07 14:20:13 +01:00
parent cc5d431d4c
commit c8c299cfb5
8 changed files with 61 additions and 67 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/YourControl.hs
+1 -1
View File
@@ -17,7 +17,7 @@ import Data.Maybe
{- | The AI equivalent for your control. -} {- | The AI equivalent for your control. -}
yourControl :: Creature -> World -> World yourControl :: Creature -> World -> World
yourControl cr w yourControl cr w
| hasTerminalFocus w = w | inTermFocus w = w
| otherwise = w | otherwise = w
& creatures . ix (_crID cr) %~ & creatures . ix (_crID cr) %~
(wasdWithAiming w (_mvSpeed $ _crMvType cr) . mouseActionsCr (_mouseButtons w)) (wasdWithAiming w (_mvSpeed $ _crMvType cr) . mouseActionsCr (_mouseButtons w))
src/Dodge/Event.hs
+3 -3
View File
@@ -96,7 +96,7 @@ handlePressedMouseButton but w = case (_hudElement (_hud w), but) of
(DisplayCarte,_) -> w & clickMousePos .~ _mousePos w (DisplayCarte,_) -> w & clickMousePos .~ _mousePos w
(_,ButtonMiddle) -> w & clickMousePos .~ _mousePos w (_,ButtonMiddle) -> w & clickMousePos .~ _mousePos w
( DisplayInventory (DisplayTerminal tmid) , ButtonLeft) ( DisplayInventory (DisplayTerminal tmid) , ButtonLeft)
| hasTerminalFocus w -> doTerminalEffectLB (w ^?! terminals . ix tmid) w | inTermFocus w -> doTerminalEffectLB (w ^?! terminals . ix tmid) w
| otherwise -> w & terminals . ix tmid . tmInput . tiFocus %~ const True | otherwise -> w & terminals . ix tmid . tmInput . tiFocus %~ const True
( DisplayInventory (CombineInventory mi) , ButtonLeft) ( DisplayInventory (CombineInventory mi) , ButtonLeft)
-> maybe (hud . hudElement .~ DisplayInventory NoSubInventory) doCombine mi w -> maybe (hud . hudElement .~ DisplayInventory NoSubInventory) doCombine mi w
@@ -144,9 +144,9 @@ wheelEvent y w = case _hudElement $ _hud w of
DisplayInventory (CombineInventory _) -> w DisplayInventory (CombineInventory _) -> w
& hud . hudElement . subInventory . combineInvSel . _Just %~ ((`mod` numcombs) . subtract yi) & hud . hudElement . subInventory . combineInvSel . _Just %~ ((`mod` numcombs) . subtract yi)
DisplayInventory (DisplayTerminal tmid) DisplayInventory (DisplayTerminal tmid)
| rbDown && hasTerminalFocus w -> w | rbDown && inTermFocus w -> w
& terminals . ix tmid %~ updatetermsubsel & terminals . ix tmid %~ updatetermsubsel
| hasTerminalFocus w -> w | inTermFocus w -> w
& terminals . ix tmid %~ updatetermsel & terminals . ix tmid %~ updatetermsel
_ -> w _ -> w
where where
src/Dodge/Event/Keyboard.hs
+7 -7
View File
@@ -68,8 +68,8 @@ handlePressedKey _ scode u = case scode of
ScancodeF9 -> return . Just $ loadSaveSlot QuicksaveSlot u ScancodeF9 -> return . Just $ loadSaveSlot QuicksaveSlot u
ScancodeSemicolon -> return . Just $ gotoTerminal u ScancodeSemicolon -> return . Just $ gotoTerminal u
_ | null (_menuLayers u) -> case u ^? uvWorld . hud . hudElement . subInventory of _ | null (_menuLayers u) -> case u ^? uvWorld . hud . hudElement . subInventory of
Just (DisplayTerminal tmid) Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u)
| hasTerminalFocus (_uvWorld u) -> return $ uvWorld (handlePressedKeyTerminal tmid scode) u -> return $ uvWorld (Just . handlePressedKeyTerminal tmid scode) u
_ -> return $ uvWorld (Just . handlePressedKeyInGame scode) u _ -> return $ uvWorld (Just . handlePressedKeyInGame scode) u
_ -> handlePressedKeyInMenu (head $ _menuLayers u) scode u _ -> handlePressedKeyInMenu (head $ _menuLayers u) scode u
@@ -88,14 +88,14 @@ handlePressedKeyInGame scode w = case scode of
_ -> w _ -> w
handlePressedKeyTerminal :: Int -> Scancode -> World -> Maybe World handlePressedKeyTerminal :: Int -> Scancode -> World -> World
handlePressedKeyTerminal tmid scode w = case scode of handlePressedKeyTerminal tmid scode w = case scode of
ScancodeEscape -> Just $ w & terminals . ix tmid . tmInput . tiFocus %~ const False ScancodeEscape -> w & terminals . ix tmid . tmInput . tiFocus %~ const False
ScancodeReturn -> Just $ w & doTerminalEffect (w ^?! terminals . ix tmid) ScancodeReturn -> w & terminalReturnEffect (w ^?! terminals . ix tmid)
ScancodeBackspace -> Just $ w ScancodeBackspace -> w
& terminals . ix tmid . tmInput . tiText %~ doBackspace & terminals . ix tmid . tmInput . tiText %~ doBackspace
& backspaceTimer .~ 5 & backspaceTimer .~ 5
_ -> Just w _ -> w
where where
doBackspace t = case T.unsnoc t of doBackspace t = case T.unsnoc t of
Nothing -> t Nothing -> t
src/Dodge/InputFocus.hs
+2 -2
View File
@@ -4,8 +4,8 @@ import LensHelp
import Data.Maybe import Data.Maybe
hasTerminalFocus :: World -> Bool inTermFocus :: World -> Bool
hasTerminalFocus w = fromMaybe False $ do inTermFocus w = fromMaybe False $ do
tmid <- w ^? hud . hudElement . subInventory . termID tmid <- w ^? hud . hudElement . subInventory . termID
w ^? terminals . ix tmid . tmInput . tiFocus w ^? terminals . ix tmid . tmInput . tiFocus
src/Dodge/Placement/Instance/Analyser.hs
+1 -1
View File
@@ -48,7 +48,7 @@ analyser proxreq pslight psmc = extTrigLitPos pslight $ \tp ->
where where
tparams = basicTerminal & tmScrollCommands .:~ sensorCommand tparams = basicTerminal & tmScrollCommands .:~ sensorCommand
linksensortotrigger tp _ mc linksensortotrigger tp _ mc
= (triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc)) = triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc)
themachine = defaultMachine & mcColor .~ aquamarine themachine = defaultMachine & mcColor .~ aquamarine
& mcUpdate .~ mcProximitySensorUpdate & mcUpdate .~ mcProximitySensorUpdate
& mcDraw .~ terminalSPic & mcDraw .~ terminalSPic
src/Dodge/Placement/Instance/Terminal.hs
+1 -4
View File
@@ -33,7 +33,7 @@ putTerminal''
putTerminal'' mc tm mcf = ps0PushPS (PutTerminal tm) putTerminal'' mc tm mcf = ps0PushPS (PutTerminal tm)
$ \tmpl -> Just $ ps0PushPS (PutButton termButton) $ \tmpl -> Just $ ps0PushPS (PutButton termButton)
$ \btpl -> Just $ pt0 (PutMachine (reverse $ square 10) $ \btpl -> Just $ pt0 (PutMachine (reverse $ square 10)
(mc & mcUpdate %~ (\fmu mc' -> (mcf (fromJust $ _plMID btpl) mc' . fmu mc')) . machineAddSound fridgeHumS (mc & mcUpdate %~ (\fmu mc' -> mcf (fromJust $ _plMID btpl) mc' . fmu mc') . machineAddSound fridgeHumS
& mcDeath %~ (\fd mc' -> mcKillTerm mc' . (buttons . at (fromJust (_plMID btpl)) .~ Nothing) . fd mc') & mcDeath %~ (\fd mc' -> mcKillTerm mc' . (buttons . at (fromJust (_plMID btpl)) .~ Nothing) . fd mc')
) ) ) )
$ \mcpl -> Just $ sps0 $ PutWorldUpdate $ const (setids tmpl btpl mcpl) $ \mcpl -> Just $ sps0 $ PutWorldUpdate $ const (setids tmpl btpl mcpl)
@@ -48,9 +48,6 @@ putTerminal'' mc tm mcf = ps0PushPS (PutTerminal tm)
btid = fromJust (_plMID btpl) btid = fromJust (_plMID btpl)
mcid = fromJust (_plMID mcpl) mcid = fromJust (_plMID mcpl)
mcKillLinked :: Machine -> World -> World
mcKillLinked mc = mcKillTerm mc
mcKillTerm :: Machine -> World -> World mcKillTerm :: Machine -> World -> World
mcKillTerm mc w = fromMaybe w $ do mcKillTerm mc w = fromMaybe w $ do
tmid <- _mcTermMID mc tmid <- _mcTermMID mc
src/Dodge/Room/LasTurret.hs
+2 -2
View File
@@ -16,7 +16,7 @@ import Dodge.Placement.Instance
import Dodge.Placement.Instance.Analyser import Dodge.Placement.Instance.Analyser
import Dodge.Default.Room import Dodge.Default.Room
import Dodge.Item.Consumable import Dodge.Item.Consumable
import Dodge.Machine --import Dodge.Machine
--import Dodge.Item.Weapon.Utility --import Dodge.Item.Weapon.Utility
--import Dodge.LevelGen.Data --import Dodge.LevelGen.Data
--import Geometry.Data --import Geometry.Data
@@ -26,7 +26,7 @@ import Color
import Shape import Shape
import LensHelp import LensHelp
import Dodge.RandomHelp import Dodge.RandomHelp
import Dodge.SoundLogic --import Dodge.SoundLogic
import qualified Data.Set as S import qualified Data.Set as S
import Data.Maybe import Data.Maybe
src/Dodge/Terminal.hs
+37 -40
View File
@@ -13,7 +13,7 @@ import Data.Maybe
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
import qualified Data.Text as T import qualified Data.Text as T
import Text.Read --import Text.Read
import Data.List (find) import Data.List (find)
quitCommand :: TerminalCommand quitCommand :: TerminalCommand
@@ -52,11 +52,6 @@ getDamageCoding = decodedtmap . _sensorCoding . _genParams
decodedtmap :: M.Map DamageType (PaletteColor,DecorationShape) decodedtmap :: M.Map DamageType (PaletteColor,DecorationShape)
-> M.Map String [TerminalLine] -> M.Map String [TerminalLine]
decodedtmap = M.mapKeys show . M.map ((:[]) . makeTermLine . show) decodedtmap = M.mapKeys show . M.map ((:[]) . makeTermLine . show)
where
f args _ w = fromMaybe (Left "") $ do
dtype <- safeHead args >>= readMaybe
dinfo <- _sensorCoding (_genParams w) M.!? dtype
return $ Right [makeTermLine $ show (fst dinfo) ++ " " ++ show (snd dinfo)]
sensorCommand :: TerminalCommand sensorCommand :: TerminalCommand
sensorCommand = TerminalCommand sensorCommand = TerminalCommand
@@ -106,18 +101,24 @@ helpCommand :: TerminalCommand
helpCommand = TerminalCommand helpCommand = TerminalCommand
{ _tcString = "HELP" { _tcString = "HELP"
, _tcAlias = ["H","MAN"] , _tcAlias = ["H","MAN"]
, _tcHelp = "DISPLAYS HELP FOR A SPECIFIC COMMAND. TO DISPLAY AVAILABLE COMMANDS USE \"COMMANDS\"." , _tcHelp = "DISPLAYS HELP FOR A SPECIFIC COMMAND."
, _tcEffect = \tm w -> OneArgument "AN AVAILABLE COMMAND" $ getCommandsHelp tm w , _tcEffect = \tm -> OneArgument "AN AVAILABLE COMMAND" . getCommandsHelp tm
} }
getCommandsHelp :: Terminal -> World -> M.Map String [TerminalLine] getCommandsHelp :: Terminal -> World -> M.Map String [TerminalLine]
getCommandsHelp tm w = fromMaybe mempty $ do --getCommandsHelp tm w = fromMaybe mempty $ do
tcs <- getCommands tm w -- tcs <- getCommands tm w
return $ foldr f mempty tcs -- return $ foldr f mempty tcs
getCommandsHelp tm w = maybe mempty (foldr f mempty) (getCommands tm w)
where where
f tc = M.insert (_tcString tc) f tc = M.insert (_tcString tc)
( [makeTermLine ("COMMAND:" ++ _tcString tc) ( [makeTermLine "COMMAND:"
,makeTermLine ("ALIASES:" ++ unwords (_tcAlias tc)) ] , makeColorTermLine yellow (_tcString tc)
++ (makeTermPara $ _tcHelp tc) ,makeTermLine "ALIASES:"
, makeColorTermLine yellow ( unwords (_tcAlias tc)) ]
++ case argumentHelp tc tm w of
(arghelp,Nothing) -> makeTermPara $ _tcHelp tc ++ " " ++ arghelp
(arghelp,Just args) -> makeTermPara (_tcHelp tc ++ " " ++ arghelp)
++ [makeColorTermLine yellow $ unwords args]
) )
getCommands :: Terminal -> World -> Maybe [TerminalCommand] getCommands :: Terminal -> World -> Maybe [TerminalCommand]
getCommands tm w = do getCommands tm w = do
@@ -132,10 +133,11 @@ infoClearInput tm tls = terminals . ix (_tmID tm) %~
) )
) )
argumentHelp :: Maybe String -> String argumentHelp :: TerminalCommand -> Terminal -> World -> (String,Maybe [String])
argumentHelp mstr = case mstr of argumentHelp tc tm w = case _tcEffect tc tm w of
Nothing -> "ANY ARGUMENTS PROVIDED TO THIS COMMAND ARE IGNORED." NoArguments {} -> ("ANY ARGUMENTS PROVIDED TO THIS COMMAND ARE IGNORED.",Nothing)
Just str -> "EXPECTS " ++ str ++ " AS ARGUMENT." OneArgument argtype argm -> ("EXPECTS " ++ argtype ++ " AS ARGUMENT. AVAILABLE ARGUMENTS: "
, Just (M.keys argm) )
makeTermPara :: String -> [TerminalLine] makeTermPara :: String -> [TerminalLine]
makeTermPara = map makeTermLine . makeParagraph 60 makeTermPara = map makeTermLine . makeParagraph 60
@@ -144,7 +146,7 @@ makeColorTermLine :: Color -> String -> TerminalLine
makeColorTermLine col str = TerminalLineDisplay 0 $ const (str,col) makeColorTermLine col str = TerminalLineDisplay 0 $ const (str,col)
makeTermLine :: String -> TerminalLine makeTermLine :: String -> TerminalLine
makeTermLine = makeColorTermLine white makeTermLine = makeColorTermLine (greyN 0.9)
termSoundLine :: SoundID -> TerminalLine termSoundLine :: SoundID -> TerminalLine
termSoundLine sid = TerminalLineEffect 0 termsound termSoundLine sid = TerminalLineEffect 0 termsound
@@ -183,38 +185,33 @@ singleCommand followingLines command aliases htext eff = TerminalCommand
doTerminalEffectLB :: Terminal -> World -> World doTerminalEffectLB :: Terminal -> World -> World
doTerminalEffectLB tm w = fromMaybe w $ do doTerminalEffectLB tm w = fromMaybe w $ do
s <- fmap T.unpack $ w ^? terminals . ix (_tmID tm) . tmInput . tiText s <- fmap T.unpack $ w ^? terminals . ix (_tmID tm) . tmInput . tiText
if null (words s) then Just $ defocusTerminalInput w else return $ doTerminalEffect tm w if null (words s)
then Just $ defocusTerminalInput w
else return $ terminalReturnEffect tm w
doTerminalEffect :: Terminal -> World -> World terminalReturnEffect :: Terminal -> World -> World
doTerminalEffect tm w = fromMaybe w $ do terminalReturnEffect tm w = fromMaybe w $ do
s <- fmap T.unpack $ w ^? terminals . ix (_tmID tm) . tmInput . tiText s <- fmap T.unpack $ w ^? terminals . ix (_tmID tm) . tmInput . tiText
return $ doTerminalEffect' s tm $ w return $ runTerminalString s tm $ w
& terminals . ix (_tmID tm) . tmFutureLines .~ [makeColorTermLine (greyN 0.9) ('>':s)] & terminals . ix (_tmID tm) . tmFutureLines .~ [makeTermLine ('>':s)]
commandFutureLines :: String -> Terminal -> World -> [TerminalLine] commandFutureLines :: String -> Terminal -> World -> [TerminalLine]
commandFutureLines s tm w = fromMaybe [] $ do commandFutureLines s tm w = fromMaybe [errline "^ INVALID COMMAND"] $ do
commands <- getCommands tm w commands <- getCommands tm w
(str,args) <- safeUncons $ words s (str,args) <- safeUncons $ words s
command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) commands command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) commands
case _tcEffect command tm w of case _tcEffect command tm w of
NoArguments tls -> Just tls NoArguments tls -> Just tls
OneArgument argtype m -> case args of OneArgument argtype m -> Just $ fromMaybe [errline $ "^ INVALID ARGUMENT: EXPECTS "++ argtype]
(arg:_) -> M.lookup arg m $ safeHead args >>= (m M.!?)
[] -> Just [makeColorTermLine red $ "^ INVALID ARGUMENT: EXPECTS "++ argtype ]
doTerminalEffect' :: String -> Terminal -> World -> World
doTerminalEffect' s tm w = fromMaybe (w & badinput) $ do
if null (words s) then Just $ defocusTerminalInput w else do
let futlines = commandFutureLines s tm w
return $ w & terminals . ix (_tmID tm) %~
( (tmInput .~ TerminalInput T.empty True (0,0))
. (tmFutureLines ++.~ futlines)
. (tmCommandHistory %~ take 10 . (s:))
)
where where
badinput = terminals . ix (_tmID tm) %~ errline = makeColorTermLine red
runTerminalString :: String -> Terminal -> World -> World
runTerminalString s tm w = w & terminals . ix (_tmID tm) %~
( (tmInput .~ TerminalInput T.empty True (0,0)) ( (tmInput .~ TerminalInput T.empty True (0,0))
. (tmFutureLines ++.~ [makeColorTermLine red "^ INVALID INPUT" ]) . (tmFutureLines ++.~ commandFutureLines s tm w)
. (tmCommandHistory %~ take 10 . (s:))
) )
defocusTerminalInput :: World -> World defocusTerminalInput :: World -> World