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-06 16:22:47 +01:00
parent 27a5b9b774
commit b92305798f
11 changed files with 116 additions and 77 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/YourControl.hs
+5 -3
View File
@@ -5,6 +5,7 @@ import Dodge.Data
import Dodge.Base.Coordinate
import Dodge.Creature.Impulse.Movement
import Dodge.Update.UsingInput
import Dodge.InputFocus
--import Dodge.Config.KeyConfig
import Geometry
@@ -15,12 +16,13 @@ import qualified Data.Set as S
import Data.Maybe
{- | The AI equivalent for your control. -}
yourControl :: Creature -> World -> World
yourControl cr w = case w ^? hud . hudElement . subInventory . onInputLine of
Just True -> w
_ -> w
yourControl cr w
| hasTerminalFocus w = w
| otherwise = w
& creatures . ix (_crID cr) %~
(wasdWithAiming w (_mvSpeed $ _crMvType cr) . mouseActionsCr (_mouseButtons w))
& updateUsingInput
-- note the order of operation, setting the posture first--this prevents the twist fire bug
{- | Turn key presses into creature movement. -}
src/Dodge/Data.hs
+10 -2
View File
@@ -204,7 +204,6 @@ data SubInventory
| LockedInventory
| DisplayTerminal
{_termID :: Int
,_onInputLine :: Bool
}
-- deriving (Eq,Ord,Show)
@@ -413,6 +412,10 @@ data TerminalLine
{_tlPause :: Int
,_tlString :: World -> (String, Color)
}
| TerminalLineTerminalEffect
{_tlPause :: Int
,_tlTermEffect :: Terminal -> Terminal
}
| TerminalLineInput
{_tlPause :: Int
-- ,_tlScrollCommands :: [TerminalCommand]
@@ -937,6 +940,10 @@ data Block = Block
}
data BlockMaterial = WoodBlock | DirtBlock | StoneBlock | GlassBlock | MetalBlock
data TerminalStatus = Connected | Disconnected
data TerminalInput = TerminalInput
{ _tiText :: T.Text
, _tiFocus :: Bool
}
data Terminal = Terminal
{ _tmID :: Int
, _tmProgram :: Terminal -> World -> [TerminalLine]
@@ -948,7 +955,7 @@ data Terminal = Terminal
, _tmMaxLines :: Int
, _tmTitle :: String
, _tmSel :: Maybe (Int,Int)
, _tmInput :: Maybe T.Text
, _tmInput :: Maybe TerminalInput
, _tmScrollCommands :: [TerminalCommand]
, _tmWriteCommands :: [TerminalCommand]
, _tmDeathEffect :: Terminal -> World -> World
@@ -1606,6 +1613,7 @@ makeLenses ''AllocateEquipment
makeLenses ''ActivateEquipment
makeLenses ''EquipParams
makeLenses ''TerminalCommand
makeLenses ''TerminalInput
makeLenses ''GenParams
makeLenses ''CreatureSkin
makeLenses ''Corpse
src/Dodge/Event.hs
+49 -34
View File
@@ -13,6 +13,7 @@ module Dodge.Event
( handleEvent
) where
import Dodge.Terminal
import Dodge.InputFocus
import Dodge.Combine
import Dodge.Event.Keyboard
--import Dodge.Event.Menu
@@ -63,7 +64,7 @@ handleMouseMotionEvent mmev u = Just $ u & uvWorld . mousePos .~ V2
handleMouseButtonEvent :: MouseButtonEventData -> Universe -> Maybe Universe
handleMouseButtonEvent mbev = case mouseButtonEventMotion mbev of
Released -> Just . updateButtons S.delete
Pressed -> handlePressedMouseButton thebutton . updateButtons S.insert
Pressed -> Just . over uvWorld (handlePressedMouseButton thebutton) . updateButtons S.insert
where
thebutton = mouseButtonEventButton mbev
updateButtons f = uvWorld . mouseButtons %~ f thebutton
@@ -90,18 +91,20 @@ handleResizeEvent sev u = return . Just $ u
V2 x' y' = windowSizeChangedEventSize sev
divRes = resFactorNum $ u ^. config . graphics_resolution_factor
handlePressedMouseButton :: MouseButton -> Universe -> Maybe Universe
handlePressedMouseButton but w = case (_hudElement (_hud $ _uvWorld w), but) of
(DisplayCarte,_) -> Just $ w & uvWorld . clickMousePos .~ _mousePos (_uvWorld w)
(_,ButtonMiddle) -> Just $ w & uvWorld . clickMousePos .~ _mousePos (_uvWorld w)
( DisplayInventory (DisplayTerminal tmid _) , ButtonLeft)
-> Just $ over uvWorld (doTerminalEffect (w ^?! uvWorld . terminals . ix tmid)) w
handlePressedMouseButton :: MouseButton -> World -> World
handlePressedMouseButton but w = case (_hudElement (_hud w), but) of
(DisplayCarte,_) -> w & clickMousePos .~ _mousePos w
(_,ButtonMiddle) -> w & clickMousePos .~ _mousePos w
( DisplayInventory (DisplayTerminal tmid) , ButtonLeft)
| hasTerminalFocus w -> doTerminalEffectLB (w ^?! terminals . ix tmid) w
| otherwise -> w & terminals . ix tmid . tmInput . _Just . tiFocus %~ const True
( DisplayInventory (CombineInventory mi) , ButtonLeft)
-> Just $ fromMaybe (w & uvWorld . hud . hudElement .~ DisplayInventory NoSubInventory)
$ do -- ugly
i <- mi
return $ over uvWorld (doCombine i) w
_ -> Just w
-> maybe (hud . hudElement .~ DisplayInventory NoSubInventory) doCombine mi w
-- -> fromMaybe (w & hud . hudElement .~ DisplayInventory NoSubInventory)
-- $ do -- ugly
-- i <- mi
-- return $ doCombine i w
_ -> w
-- note "sort" on the inventory indices; otherwise
-- lower items may be shifted up and items below these removed instead
@@ -144,30 +147,30 @@ wheelEvent y w = case _hudElement $ _hud w of
| otherwise -> w & moveTweakSel yi
DisplayInventory (CombineInventory _) -> w
& hud . hudElement . subInventory . combineInvSel . _Just %~ ((`mod` numcombs) . subtract yi)
-- DisplayInventory (DisplayTerminal tmid True)
-- | rbDown -> w
-- & terminals . ix tmid %~ updatetermsubsel
-- | otherwise -> w
-- & terminals . ix tmid %~ updatetermsel
DisplayInventory (DisplayTerminal tmid)
| rbDown && hasTerminalFocus w -> w
& terminals . ix tmid %~ updatetermsubsel
| hasTerminalFocus w -> w
& terminals . ix tmid %~ updatetermsel
_ -> w
where
-- updatetermsel tp = case _tmSel tp of
-- Nothing -> tp & tmSel ?~ (0,0)
-- & tmInput . _Just %~ replacewith tp 0
-- Just (i,_) -> let newi = ((`mod` length (_tmScrollCommands tp)) . subtract yi) i
-- in tp & tmSel . _Just .~ (newi,0)
-- & tmInput . _Just %~ replacewith tp newi
-- updatetermsubsel tp = case _tmSel tp of
-- Nothing -> tp
-- Just (i,j) -> let newj = (j - yi) `mod` (1 + length (_tcArguments (_tmScrollCommands tp !! i) tp w))
-- in tp & tmSel . _Just .~ (i,newj)
-- & tmInput . _Just %~ replacewith' tp i newj w
-- replacewith tp newi _ = T.pack (_tcString (_tmScrollCommands tp !! newi))
-- replacewith' tp i j w' _ = T.pack $ _tcString tc ++ " " ++ arg-- ++ ((_tcArguments tp) w !! j)
-- where
-- arg :: String
-- arg = ("": _tcArguments tc w' )!! j
-- tc = _tmScrollCommands tp !! i
updatetermsel tp = case _tmSel tp of
Nothing -> tp & tmSel ?~ (0,0)
& tmInput . _Just . tiText %~ replacewith tp 0
Just (i,_) -> let newi = ((`mod` length (scrollCommands tp)) . subtract yi) i
in tp & tmSel . _Just .~ (newi,0)
& tmInput . _Just . tiText %~ replacewith tp newi
updatetermsubsel tp = case _tmSel tp of
Nothing -> tp
Just (i,j) -> let newj = (j - yi) `mod` (1 + length (_tcArguments (scrollCommands tp !! i) tp w))
in tp & tmSel . _Just .~ (i,newj)
& tmInput . _Just . tiText %~ replacewith' tp i newj w
replacewith tp newi _ = T.pack (_tcString (scrollCommands tp !! newi))
replacewith' tp i j w' _ = T.pack $ _tcString tc ++ " " ++ arg-- ++ ((_tcArguments tp) w !! j)
where
arg :: String
arg = ("": _tcArguments tc tp w' )!! j
tc = scrollCommands tp !! i
numcombs = length $ combineItemListYou w
yi = round $ signum y
numLocs = (fst . IM.findMax $ _seenLocations w) + 1
@@ -175,6 +178,18 @@ wheelEvent y w = case _hudElement $ _hud w of
lbDown = ButtonLeft `S.member` _mouseButtons w
invKeyDown = ScancodeCapsLock `S.member` _keys w
scrollCommands :: Terminal -> [TerminalCommand]
scrollCommands = (nullCommand :) . _tmScrollCommands
nullCommand :: TerminalCommand
nullCommand = TerminalCommand
{ _tcString = ""
, _tcAlias = []
, _tcHelp = ""
, _tcArgumentType = Nothing
, _tcArguments = const (const [])
, _tcEffect = const $ \_ w -> Right $ w
}
scrollRBOption :: Float -> World -> World
scrollRBOption y w
| y < 0 = w & rbOptions . opSel %~ (min (length (_opEquip (_rbOptions w))-1) . (+1))
src/Dodge/Event/Keyboard.hs
+9 -5
View File
@@ -4,6 +4,7 @@ module Dodge.Event.Keyboard
, handleTextInput
) where
import Dodge.Terminal
import Dodge.InputFocus
import Dodge.Base
import Dodge.Combine
import Dodge.Creature.Action
@@ -35,8 +36,10 @@ handleTextInput text u = return . Just $ u
& updateTerminalText
where
updateTerminalText = case u ^? uvWorld . hud . hudElement . subInventory of
Just (DisplayTerminal tmid True) -> uvWorld . terminals . ix tmid . tmInput . _Just %~ updateText
_ -> id
Just (DisplayTerminal tmid) | hasfocus tmid
-> uvWorld . terminals . ix tmid . tmInput . _Just . tiText %~ updateText
_ -> id
hasfocus tmid = fromMaybe False $ u ^? uvWorld . terminals . ix tmid . tmInput . _Just . tiFocus
updateText s = case T.unpack text of
";" -> s
_ -> s `T.append` T.toUpper text
@@ -65,7 +68,8 @@ handlePressedKey _ scode u = case scode of
ScancodeF9 -> return . Just $ loadSaveSlot QuicksaveSlot u
ScancodeSemicolon -> return . Just $ gotoTerminal u
_ | null (_menuLayers u) -> case u ^? uvWorld . hud . hudElement . subInventory of
Just (DisplayTerminal tmid True) -> return $ uvWorld (handlePressedKeyTerminal tmid scode) u
Just (DisplayTerminal tmid)
| hasTerminalFocus (_uvWorld u) -> return $ uvWorld (handlePressedKeyTerminal tmid scode) u
_ -> return $ uvWorld (Just . handlePressedKeyInGame scode) u
_ -> handlePressedKeyInMenu (head $ _menuLayers u) scode u
@@ -86,10 +90,10 @@ handlePressedKeyInGame scode w = case scode of
handlePressedKeyTerminal :: Int -> Scancode -> World -> Maybe World
handlePressedKeyTerminal tmid scode w = case scode of
ScancodeEscape -> Just $ w & hud . hudElement . subInventory . onInputLine .~ False
ScancodeEscape -> Just $ w & terminals . ix tmid . tmInput . _Just . tiFocus %~ const False
ScancodeReturn -> Just $ w & doTerminalEffect (w ^?! terminals . ix tmid)
ScancodeBackspace -> Just $ w
& terminals . ix tmid . tmInput . _Just %~ doBackspace
& terminals . ix tmid . tmInput . _Just . tiText %~ doBackspace
& backspaceTimer .~ 5
_ -> Just w
where
src/Dodge/Placement/Instance/Analyser.hs
+3 -3
View File
@@ -49,12 +49,12 @@ analyser
-> PlacementSpot
-> PlacementSpot
-> Placement
analyser starts sucs fails afters upf pslight psmc = extTrigLitPos pslight $ \tp ->
analyser starts sucs _ afters upf pslight psmc = extTrigLitPos pslight $ \tp ->
Just $ plSpot .~ psmc $ putTerminal' aquamarine tparams (termupdate tp)
where
tparams = const $ defaultTermParams & tmFutureLines ++.~
tparams = defaultTermParams & tmFutureLines ++.~
(map makeTermLine starts ++ [makeTermLine sucs] ++ map makeTermLine afters)
termupdate tp btid =
termupdate tp _ =
(\mc -> upf mc . (triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc))
)
src/Dodge/Placement/Instance/Terminal.hs
+7 -11
View File
@@ -3,7 +3,6 @@ module Dodge.Placement.Instance.Terminal
( putTerminal
, putTerminal'
, simpleTermMessage
, genTermMessage
, topFlushStrings
, terminalColor
) where
@@ -25,10 +24,10 @@ import Data.Maybe
putTerminal''
:: Machine
-> (World -> Terminal)
-> Terminal
-> (Int -> Machine -> World -> World) -- | machine update, takes button id as input
-> Placement
putTerminal'' mc f mcf = ps0PushPS (PutTerminal theterminal) $ \tmpl -> Just $
putTerminal'' mc tm mcf = ps0PushPS (PutTerminal tm) $ \tmpl -> Just $
ps0PushPS (PutButton $ termButton)
$ \btpl -> Just $ pt0 (PutMachine (reverse $ square 10)
(mc & mcUpdate .~ machineAddSound fridgeHumS (mcf (fromJust $ _plMID btpl))
@@ -46,11 +45,10 @@ putTerminal'' mc f mcf = ps0PushPS (PutTerminal theterminal) $ \tmpl -> Just $
tmid = fromJust (_plMID tmpl)
btid = fromJust (_plMID btpl)
mcid = fromJust (_plMID mcpl)
theterminal = defaultTerminal & tmProgram .~ (\_ w -> _tmFutureLines (f w))
putTerminal'
:: Color
-> (World -> Terminal)
-> Terminal
-> (Int -> Machine -> World -> World) -- | machine update, takes button id as input
-> Placement
putTerminal' col = putTerminal'' (defaultMachine & mcColor .~ col)
@@ -59,7 +57,7 @@ putTerminal' col = putTerminal'' (defaultMachine & mcColor .~ col)
, _mcSensor = SensorCloseToggle NotClose False
}
putTerminal :: Color -> (World -> Terminal) -> Placement
putTerminal :: Color -> Terminal -> Placement
putTerminal col f = putTerminal'' (mc & mcColor .~ col) f (\_ -> basicMachineUpdate $ const id)
where
mc = defaultMachine
@@ -103,14 +101,14 @@ terminalShape mc = colorSH col (prismPoly
bootTerminal :: Maybe Int -> World -> World
bootTerminal mtmid w = case mtmid of
Nothing -> w
Just tmid -> w & hud . hudElement .~ DisplayInventory (DisplayTerminal tmid False)
Just tmid -> w & hud . hudElement .~ DisplayInventory (DisplayTerminal tmid)
& terminals . ix tmid . tmFutureLines ++.~ _tmProgram tm tm w
& terminals . ix tmid . tmStatus .~ Connected
where
tm = w ^?! terminals . ix tmid
simpleTermMessage :: [String] -> World -> Terminal
simpleTermMessage = genTermMessage . const
simpleTermMessage :: [String] -> Terminal
simpleTermMessage strs = defaultTerminal & tmFutureLines .~ map makeTermLine strs
--simpleTermMessage ss = const $ TerminalParams
-- {_termDisplayedLines = []
-- ,_termFutureLines = TerminalLineEffect 0 termsound
@@ -132,5 +130,3 @@ topFlushStrings = topFlush . maximum . map length
topFlush :: Int -> [String]
topFlush twidth = [replicate i ' ' ++ "*" | i <- [0, max 1 $ twidth `div` 5 .. twidth]]
genTermMessage :: (World -> [String]) -> World -> Terminal
genTermMessage f w = defaultTermParams & tmFutureLines ++.~ map makeTermLine (f w)
src/Dodge/Render/HUD.hs
+4 -4
View File
@@ -84,12 +84,12 @@ subInventoryDisplay subinv cfig w = case subinv of
, invHead cfig "TWEAK"
, listTextPicturesAt subInvX 60 cfig $ map text (ammoTweakStrings it)
]
DisplayTerminal {_termID = tid,_onInputLine=inputstatus} ->
DisplayTerminal {_termID = tid} ->
let tp = w ^?! terminals . ix tid
in pictures
[ invHead cfig (_tmTitle tp ++ ":T" ++ show tid)
, renderListAt subInvX 60 cfig
. displayTermInput inputstatus tp
. displayTermInput tp
-- . (++ map (\(str,_) -> (str,white)) (_termOptions tp))
. reverse
. take (_tmMaxLines tp)
@@ -124,9 +124,9 @@ subInventoryDisplay subinv cfig w = case subinv of
]
InspectInventory -> invHead cfig "INSPECT"
where
displayTermInput inputstatus tp = case _tmInput tp of
displayTermInput tp = case _tmInput tp of
Nothing -> id
Just s -> (++ [('>':T.unpack s++displayBlinkCursor inputstatus,white)])
Just (TerminalInput s inputstatus) -> (++ [('>':T.unpack s++displayBlinkCursor inputstatus,white)])
displayBlinkCursor inputstatus | inputstatus = clockCycle 10 (V.fromList ["_",""]) w
| otherwise = []
closeobjectcursor = case selectedCloseObject w of
src/Dodge/Room/SensorDoor.hs
+1 -1
View File
@@ -83,7 +83,7 @@ sensInsideDoor senseType outplid rm = rm
thinHighBar 0 (V2 20 (-1)) (V2 20 (-100))
<> thinHighBar 0 (V2 0 (-100)) (V2 20 (-100))
<> barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80))
, putTerminal terminalColor (const $ defaultTermParams & addInputLine [damageCodeCommand,quitCommand]
, putTerminal terminalColor (defaultTermParams & addInputLine [damageCodeCommand,quitCommand]
[helpCommand,commandsCommand]
)
& plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10)
src/Dodge/Room/Warning.hs
+1 -1
View File
@@ -53,7 +53,7 @@ addWarningTerminal outplid = (rmName .++~ "warningTerm-")
outplace = extTrigLitPos
(atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
(Just . set plSpot (rprShift moveToSideFirstOutLink) . putTerminal terminalColor . termMessages)
termMessages trid _ = defaultTermParams & addInputLine
termMessages trid = defaultTermParams & addInputLine
[unlockCommand trid,quitCommand]
[helpCommand,infoCommand theinfo,commandsCommand]
unlockCommand trid = singleCommand "OPEN" ["YES","Y"] "OPEN THE CONNECTED DOOR." (toggledoor trid)
src/Dodge/Terminal.hs
+23 -9
View File
@@ -73,7 +73,7 @@ getCommands tm w = do
infoClearInput :: Terminal -> [TerminalLine] -> World -> World
infoClearInput tm tls = terminals . ix (_tmID tm) %~
( (tmInput ?~ T.empty)
( (tmInput ?~ TerminalInput T.empty True)
. (tmFutureLines ++.~ tls
)
)
@@ -130,26 +130,33 @@ singleCommand command aliases htext eff = TerminalCommand
,_tcHelp = htext
,_tcArgumentType = Nothing
, _tcArguments = const $ const []
,_tcEffect = \_ tm w -> Right $ eff $ disconnectTerminal tm w
,_tcEffect = \_ tm w -> Right $ eff $ w & terminals . ix (_tmID tm) . tmInput .~ Nothing
-- & hud . hudElement . subInventory . onInputLine %~ const False
}
doTerminalEffectLB :: Terminal -> World -> World
doTerminalEffectLB tm w = fromMaybe w $ do
s <- fmap T.unpack $ w ^? terminals . ix (_tmID tm) . tmInput . _Just . tiText
if null (words s) then Just $ defocusTerminalInput w else return $ doTerminalEffect tm w
doTerminalEffect :: Terminal -> World -> World
doTerminalEffect tm w = fromMaybe w $ do
s <- fmap T.unpack $ w ^? terminals . ix (_tmID tm) . tmInput . _Just
s <- fmap T.unpack $ w ^? terminals . ix (_tmID tm) . tmInput . _Just . tiText
return $ doTerminalEffect' s tm $ w
& terminals . ix (_tmID tm) . tmFutureLines
.~ [makeColorTermLine (greyN 0.9) ('>':s)]
doTerminalEffect' :: String -> Terminal -> World -> World
doTerminalEffect' s tm w = fromMaybe (w & badinput) $ do
commands <- getCommands tm w
if null (words s) then Just $ disconnectTerminal tm w else do
if null (words s) then Just $ defocusTerminalInput w else do
let (str:args) = words s
command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) commands
case _tcEffect command args tm w of
Right w' -> return w'
Left err -> return $ w & terminals . ix (_tmID tm) %~
( (tmInput ?~ T.empty)
( (tmInput ?~ TerminalInput T.empty True)
. (tmFutureLines ++.~
[makeColorTermLine red
("^ INVALID ARGUMENT: EXPECTS "++fromJust (_tcArgumentType command)++ err)
@@ -158,28 +165,35 @@ doTerminalEffect' s tm w = fromMaybe (w & badinput) $ do
)
where
badinput = terminals . ix (_tmID tm) %~
( (tmInput ?~ T.empty)
( (tmInput ?~ TerminalInput T.empty True)
. (tmFutureLines ++.~ [makeColorTermLine red "^ INVALID INPUT" ]
)
)
defocusTerminalInput :: World -> World
defocusTerminalInput w = fromMaybe w $ do
tmid <- w ^? hud . hudElement . subInventory . termID
return $ w & terminals . ix tmid . tmInput . _Just . tiFocus %~ const False
addInputLine :: [TerminalCommand] -> [TerminalCommand] -> Terminal -> Terminal
addInputLine searchablecommands hiddencommands =
(tmFutureLines ++.~ [TerminalLineInput 0])
(tmProgram %~ \f t w -> f t w ++ [TerminalLineInput 0])
. (tmScrollCommands .~ searchablecommands)
. (tmWriteCommands .~ hiddencommands)
defaultTermParams :: Terminal
defaultTermParams = defaultTerminal
{_tmDisplayedLines = []
,_tmFutureLines = termSoundLine computerBeepingS
: map makeTermLine connectionBlurb
,_tmFutureLines = []
,_tmMaxLines = 14
,_tmTitle = "TERMINAL"
,_tmSel = Nothing
,_tmInput = Nothing
,_tmScrollCommands = []
,_tmWriteCommands = []
,_tmProgram = \_ _ -> termSoundLine computerBeepingS
: TerminalLineTerminalEffect 0 (tmStatus .~ Connected)
: map makeTermLine connectionBlurb
}
connectionBlurb :: [String]
src/Dodge/Update.hs
+4 -4
View File
@@ -110,13 +110,13 @@ tmUpdate tm w = case w ^? terminals . ix (_tmID tm) . tmFutureLines . ix 0 of
Just (TerminalLineEffect _ eff) -> w
& pointTermParams . tmFutureLines %~ tail
& eff tm
Just (TerminalLineTerminalEffect _ eff) -> w
& pointTermParams . tmFutureLines %~ tail
& pointTermParams %~ eff
Just (TerminalLineInput _) -> w
& hud . hudElement . subInventory . onInputLine %~ const True
& pointTermParams %~
( ( tmFutureLines %~ tail )
-- . ( tmScrollCommands .~ scrollc )
-- . ( tmWriteCommands .~ writec )
. ( tmInput ?~ T.empty ) )
. ( tmInput ?~ TerminalInput T.empty True) )
where
pointTermParams = terminals . ix (_tmID tm)