Compare commits

..

4 Commits

Author SHA1 Message Date
justin 5ccbfa1f91 Cancel terminal display if destroyed while displaying 2025-08-19 18:01:23 +01:00
justin b07280e50c Cleanup 2025-08-19 17:29:36 +01:00
justin 2f9cea1b69 Allow for terminals to be deactivated 2025-08-19 13:58:57 +01:00
justin b8581a7862 Work on terminals, add deactive data type status 2025-08-19 13:48:54 +01:00
29 changed files with 479 additions and 604 deletions
+1 -1
View File
File diff suppressed because one or more lines are too long
+1 -2
View File
@@ -11,8 +11,7 @@ drawButton :: Button -> SPic
drawButton bt = case bt ^. btEvent of
ButtonPress {_bpColor = col} -> defaultDrawButton col bt
ButtonSwitch {_bsColor1 = col1, _bsColor2 = col2} -> drawSwitch col1 col2 bt
ButtonAccessTerminal -> mempty
-- ButtonDoNothing -> mempty
ButtonAccessTerminal _ -> mempty
drawSwitch :: Color -> Color -> Button -> SPic
drawSwitch col1 col2 bt
+2 -3
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
@@ -13,10 +12,10 @@ doButtonEvent = \case
ButtonPress False f _ -> buttonFlip f
ButtonSwitch _ f _ _ True -> buttonFlip f
ButtonSwitch f _ _ _ False -> buttonFlip f
ButtonAccessTerminal -> accessTerminal . _btTermMID
ButtonAccessTerminal tid -> const $ accessTerminal tid
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
+2 -2
View File
@@ -21,14 +21,14 @@ combineList :: World -> [SelectionItem CombinableItem]
combineList = map f . combineItemListYouX
where
f (is, itm) =
SelectionItem
SelItem
{ _siPictures = basicItemDisplay itm
, _siHeight = itInvHeight itm
, _siWidth = 15
, _siIsSelectable = True
, _siColor = itemInvColor $ baseCI itm
, _siOffX = 0
, _siPayload = CombinableItem is itm
, _siPayload = Just $ CombinableItem is itm
}
combineItemListYouX :: World -> [([Int], Item)]
+1 -2
View File
@@ -25,14 +25,13 @@ data ButtonEvent
, _bsColor2 :: Color
, _btOn :: Bool
}
| ButtonAccessTerminal
| ButtonAccessTerminal {_btTermID :: Int}
data Button = Button
{ _btPos :: Point2
, _btRot :: Float
, _btEvent :: ButtonEvent
, _btID :: Int
, _btTermMID :: Maybe Int
}
makeLenses ''Button
+3 -3
View File
@@ -5,6 +5,7 @@
module Dodge.Data.Input where
import Dodge.Data.Terminal.Status
import Control.Lens
import qualified Data.Map.Strict as M
import Geometry.Data
@@ -28,9 +29,8 @@ data MouseContext
| OverCombCombine { _mcoCombCombine :: (Int,Int)}
| OverCombFilter
| OverCombEscape
| OverTerminalReturn {_mcoTermID :: Int}
| OverTerminalContinue {_mcoTermID :: Int}
| OverTerminalEscape
| OverTerminal {_mcoTermID :: Int, _mcoTermStatus :: TerminalStatus}
| OutsideTerminal
| MouseGameRotate
deriving (Show)
+2 -10
View File
@@ -41,22 +41,14 @@ data SelectionWidth
| UseItemWidth
data SelectionItem a
= SelectionItem
{ _siPictures :: [String]
, _siHeight :: Int
, _siWidth :: Int
, _siIsSelectable :: Bool
, _siColor :: Color
, _siOffX :: Int
, _siPayload :: a
}
| SelectionInfo
= SelItem
{ _siPictures :: [String]
, _siHeight :: Int
, _siWidth :: Int
, _siIsSelectable :: Bool
, _siColor :: Color
, _siOffX :: Int
, _siPayload :: Maybe a
}
makeLenses ''ListDisplayParams
+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
+2 -1
View File
@@ -89,7 +89,8 @@ data TCom = TCInfo String String -- this may not be necessary, to revisit
data TmWdWd
= TmWdId
| TmWdWdDisconnectTerminal
| TmWdWdPowerDownTerminal
| TmWdWdDeactivateTerminal
| TmWdWdfromWdWd WdWd
| TmWdWdTermSound SoundID
| TmWdWdDoDeathTriggers
+2 -1
View File
@@ -9,10 +9,11 @@ import Data.Aeson.TH
data TerminalStatus
= TerminalOff
| TerminalDeactivated
| TerminalLineRead
| TerminalTextInput {_tiText :: String}
| TerminalPressTo {_tptString :: String}
deriving (Eq)
deriving (Eq,Show)
makeLenses ''TerminalStatus
deriveJSON defaultOptions ''TerminalStatus
+1 -1
View File
@@ -22,7 +22,7 @@ data WdWd
| SetTrigger Bool Int
| WorldEffects [WdWd] -- probably best to avoid recursive types if possible...
| SetLSCol Point3 Int
| AccessTerminal (Maybe Int)
| AccessTerminal Int
| UnlockInv
| SoundStart SoundOrigin Point2 SoundID (Maybe Int)
| MakeStartCloudAt Point3
+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
+6 -5
View File
@@ -65,12 +65,12 @@ updateCombineSections w cfig =
sclose'
| null sclose =
IM.singleton 0 $
SelectionInfo ["No possible combinations"] 1 25 False white 0
SelItem ["No possible combinations"] 1 25 False white 0 Nothing
| otherwise = sclose
regexCombs :: IM.IntMap Item -> SelectionItem CombinableItem -> String -> Bool
regexCombs inv ci = \case
'#' : str -> any (g str) (_ciInvIDs $ _siPayload ci)
'#' : str -> any (g str) (_ciInvIDs $ fromJust $ _siPayload ci)
str -> (regexList str . _siPictures) ci
where
g str i = maybe False (regexList str . basicItemDisplay) (inv ^? ix i)
@@ -129,7 +129,7 @@ updateDisplaySections w cfig =
[ invhead
, sinv
, IM.singleton 0
$ SelectionItem [displayFreeSlots (crNumFreeSlots cr)] 1 15 True invDimColor 2 ()
$ SelItem [displayFreeSlots (crNumFreeSlots cr)] 1 15 True invDimColor 2 Nothing
, nearbyhead
, sclose
, interfaceshead
@@ -153,7 +153,7 @@ updateDisplaySections w cfig =
btitems =
IM.fromDistinctAscList . zip [0 ..] $
mapMaybe (closeButtonToSelectionItem w) (w ^. hud . closeButtons)
makehead str = IM.singleton 0 $ SelectionInfo [str] 1 15 False white 0
makehead str = IM.singleton 0 $ SelItem [str] 1 15 False white 0 Nothing
invhead = if null sfinv then makehead "INVENTORY" else sfinv
cr = you w
closeitms =
@@ -179,13 +179,14 @@ filterSectionsPair infocus filtfn itms filtdescription mfilt = (filtsis, itms')
return $
IM.singleton
0
$ SelectionInfo
$ SelItem
[filtdescription ++ " FILTER/" ++ str ++ [filtcurs], numfiltitems]
2
(length (filtdescription ++ " FILTER/" ++ str ++ [filtcurs]))
True
white
0
Nothing
itms' = maybe id (IM.filter . filtfn) mfilt itms
numfiltitems = " " ++ show (length itms - length itms') ++ " FILTERED"
+3 -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 =
@@ -137,6 +136,9 @@ updateCloseObjects w =
activeButtons = filter canpress . IM.elems $ w ^. cWorld . lWorld . buttons
canpress bt = case bt ^. btEvent of
ButtonPress {_btOn = t} -> not t
ButtonAccessTerminal tid -> fromMaybe False $ do
x <- w ^? cWorld . lWorld . terminals . ix tid . tmStatus
return (x /= TerminalDeactivated)
_ -> True
changeSwapSel :: Int -> World -> World
+7 -7
View File
@@ -31,14 +31,14 @@ import Picture.Base
invSelectionItem :: World -> Int -> LocationDT OItem -> SelectionItem ()
invSelectionItem w indent loc =
SelectionItem
SelItem
{ _siPictures = itemDisplay w cr ci
, _siHeight = itInvHeight $ ci ^. _1
, _siWidth = 15
, _siIsSelectable = True
, _siColor = itemInvColor ci
, _siOffX = indent
, _siPayload = ()
, _siPayload = Nothing
}
where
ci = (a,b)
@@ -207,35 +207,35 @@ closeItemToSelectionItem w (NInt i) = do
e <- w ^? cWorld . lWorld . floorItems . unNIntMap . ix i
let (pics, col) = closeItemToTextPictures e
return
SelectionItem
SelItem
{ _siPictures = pics
, _siHeight = length pics
, _siWidth = 15
, _siIsSelectable = True
, _siColor = col
, _siOffX = 0
, _siPayload = ()
, _siPayload = Nothing
}
closeButtonToSelectionItem :: World -> Int -> Maybe (SelectionItem ())
closeButtonToSelectionItem w i = do
bt <- w ^? cWorld . lWorld . buttons . ix i
return
SelectionItem
SelItem
{ _siPictures = [btText bt]
, _siHeight = 1
, _siWidth = 15
, _siIsSelectable = True
, _siColor = yellow
, _siOffX = 0
, _siPayload = ()
, _siPayload = Nothing
}
btText :: Button -> String
btText bt = case _btEvent bt of
ButtonPress {} -> "BUTTON"
ButtonSwitch {_btOn = t} -> if t then "SWITCH\\" else "SWITCH/"
ButtonAccessTerminal -> "TERMINAL"
ButtonAccessTerminal {} -> "TERMINAL"
closeItemToTextPictures :: FloorItem -> ([String], Color)
closeItemToTextPictures flit = (basicItemDisplay it, itemInvColor $ baseCI it)
+2 -2
View File
@@ -96,14 +96,14 @@ menuOptionToSelectionItem ::
MenuOption ->
SelectionItem (Universe -> Universe, Universe -> Universe)
menuOptionToSelectionItem w padAmount mo =
SelectionItem
SelItem
{ _siPictures = [optionText]
, _siHeight = 1
, _siWidth = 50
, _siIsSelectable = isselectable
, _siColor = thecol
, _siOffX = 0
, _siPayload = (f, g)
, _siPayload = Just (f, g)
}
where
isselectable = case _moString mo w of
+2 -12
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
@@ -34,7 +34,7 @@ putTerminal col mc tm =
& cWorld . lWorld . terminals . ix tmid . tmButtonID .~ btid
& cWorld . lWorld . terminals . ix tmid . tmMachineID .~ mcid
& cWorld . lWorld . machines . ix mcid . mcMounts . at OTTerminal ?~ tmid
& cWorld . lWorld . buttons . ix btid . btTermMID ?~ tmid
& cWorld . lWorld . buttons . ix btid . btEvent .~ ButtonAccessTerminal tmid
where
tmid = fromJust (_plMID tmpl)
btid = fromJust (_plMID btpl)
@@ -48,15 +48,5 @@ putMessageTerminal col =
& mcType .~ McTerminal
& mcHP .~ 100
termButton :: Button
termButton =
Button
{ _btPos = 0
, _btRot = 0
, _btEvent = ButtonAccessTerminal
, _btID = 0
, _btTermMID = Nothing
}
terminalColor :: Color
terminalColor = dark magenta
+18 -24
View File
@@ -1,10 +1,7 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Render.HUD (
drawHUD,
) where
module Dodge.Render.HUD (drawHUD) where
import Dodge.Data.Terminal.Status
import Control.Applicative
import Control.Lens
import Control.Monad
@@ -23,6 +20,7 @@ import Dodge.Data.Config
import Dodge.Data.DoubleTree
import Dodge.Data.EquipType
import Dodge.Data.SelectionList
import Dodge.Data.Terminal.Status
import Dodge.Data.World
import Dodge.DoubleTree
import Dodge.Equipment.Text
@@ -34,7 +32,6 @@ import Dodge.Item.InvSize
import Dodge.Item.Location
import Dodge.ListDisplayParams
import Dodge.Render.Connectors
--import Dodge.Render.HUD.Carte
import Dodge.Render.List
import Dodge.ScreenPos
import Dodge.SelectionSections
@@ -105,9 +102,7 @@ getRootItemBounds i inv = do
drawMouseOver :: Configuration -> World -> Picture
drawMouseOver cfig w =
concat
( invsel <|> combinvsel
<|> drawDragSelecting cfig w
)
(invsel <|> combinvsel <|> drawDragSelecting cfig w)
<> concat (drawDragSelected cfig w)
where
invsel = do
@@ -211,14 +206,14 @@ drawExamineInventory cfig w =
)
where
f str =
SelectionItem
SelItem
{ _siPictures = [str]
, _siWidth = 55
, _siHeight = 1
, _siIsSelectable = True
, _siColor = white
, _siOffX = 0
, _siPayload = ()
, _siPayload = Nothing
}
closeObjectInfo :: Int -> Either FloorItem Button -> String
@@ -240,11 +235,10 @@ yourAugmentedItem f x g w = case you w ^? crManipulation . manObject of
j <- w ^? hud . closeItems . ix i . unNInt
flit <- w ^? cWorld . lWorld . floorItems . unNIntMap . ix j
return . g $ Left flit
-- g . Left $ w ^?! hud . closeItems . ix i
Just (SelCloseButton i) -> fromMaybe x $ do
j <- w ^? hud . closeButtons . ix i
flit <- w ^? cWorld . lWorld . buttons . ix j
return . g $ Right flit
but <- w ^? cWorld . lWorld . buttons . ix j
return . g $ Right but
_ -> x
drawRBOptions :: Configuration -> World -> Picture
@@ -343,13 +337,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
lnks <- si ^? siPayload . _Just . ciInvIDs
return (lnkMidPosInvSelsCol cfig w j col lnks) <> foldMap invcursor lnks
where
invcursor i = do
sss' <- w ^? hud . hudElement . diSections
@@ -362,32 +355,33 @@ 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)
<> color (dark $ _tmExternalColor tm) (drawTitleBackground cfig)
where
toselitm (str, col) = SelectionItem [str] 1 55 True col 0 ()
toselitm (str, col) = SelItem [str] 1 55 True col 0 Nothing
-- not sure if the width (55) is correct here
thesellist tm = thelist tm
thelist tm =
f tm =
map toselitm . displayTermInput tm
. reverse
. take getMaxLinesTM
$ _tmDisplayedLines tm
displayTermInput tm = case _tmStatus tm of
TerminalOff -> id
TerminalDeactivated -> id
TerminalLineRead -> id
TerminalTextInput s ->
(++ [(getPromptTM ++ s ++ [cFilledRect], white)])
TerminalPressTo s ->
(++ [(getPromptTM ++ "PRESS TO "++s, white)])
(++ [(getPromptTM ++ "PRESS TO " ++ s, white)])
-- | hasfoc = clockCycle 10 (V.fromList [[cFilledRect] , "."]) w
lnkMidPosInvSelsCol :: Configuration -> World -> Int -> Color -> [Int] -> Picture
@@ -505,4 +499,4 @@ selNumPosCardinal card cfig ldp sss i j = do
ygap = _ldpVerticalGap ldp
selSecSelCol :: Int -> Int -> IM.IntMap (SelectionSection a) -> Maybe Color
selSecSelCol i j sss = sss ^? ix i . ssItems . ix j . siColor
selSecSelCol i j = (^? ix i . ssItems . ix j . siColor)
+26 -3
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Render.Picture (
fixedCoordPictures,
) where
@@ -109,9 +110,8 @@ mouseCursorType u = case u ^. uvWorld . input . mouseContext of
OverCombFilter{} -> drawJumpDown 5
OverCombCombine{} -> drawGapPlus 5
OverCombEscape -> rotate (pi / 4) $ drawPlus 5
OverTerminalContinue{} -> drawReturn 5
OverTerminalReturn{} -> drawReturn 5
OverTerminalEscape -> rotate (pi / 4) $ drawPlus 5
OverTerminal _ ts -> drawCursorByTerminalStatus ts
OutsideTerminal -> rotate (pi / 4) $ drawPlus 5
MouseGameRotate -> rotate a (drawVerticalDoubleArrow 5)
where
w = u ^. uvWorld
@@ -122,6 +122,21 @@ mouseCursorType u = case u ^. uvWorld . input . mouseContext of
argV (w ^. cWorld . lWorld . lAimPos -.- cpos)
- w ^. wCam . camRot
drawCursorByTerminalStatus :: TerminalStatus -> Picture
drawCursorByTerminalStatus = \case
TerminalPressTo "QUIT" -> drawQuitTerminal 5
TerminalPressTo _ -> drawArrowDown 5
TerminalTextInput "QUIT" -> drawQuitTerminal 5
TerminalTextInput{} -> drawReturn 5
_ -> drawEmptySet 5
drawQuitTerminal :: Float -> Picture
drawQuitTerminal x = fold
[ line [V2 x x, V2 (- x) (- x)]
, line [V2 x (-x), V2 (- x) x]
, polygonWire (square x)
]
drawEmptySet :: Float -> Picture
drawEmptySet x =
fold
@@ -202,6 +217,14 @@ drawVerticalDoubleArrow x =
z = 1.5 * x
w = 0.6 * x
drawArrowDown :: Float -> Picture
drawArrowDown x =
line [V2 0 z, V2 0 (- z)]
<> line [V2 (- w) (w - z), V2 0 (- z), V2 w (w - z)]
where
z = 1 * x
w = 0.6 * x
drawDragDrop :: Float -> Picture
drawDragDrop x =
line (fmap (+ V2 z (- x)) [V2 (- x) x, V2 0 x, V2 0 (- x)])
+4 -1
View File
@@ -26,7 +26,7 @@ rezBox :: LightSource -> Room
rezBox ls =
roomRect 40 60 1 1
& rmPmnts .~ [sPS (V2 20 1) 0 $ PutLS ls
, putMessageTerminal terminalColor (defaultTerminal & tmBootLines .~ (makeTermPara s) <> tlSetStatus (TerminalPressTo "QUIT") <> [TLine 1 [] TmWdWdDisconnectTerminal])
, putMessageTerminal terminalColor (defaultTerminal & tmBootLines .~ (makeTermPara s) <> tlSetStatus (TerminalPressTo "QUIT") <> [TLine 1 [] TmWdWdDeactivateTerminal])
& plSpot .~ PS (V2 20 0) 0
]
& restrictInLinks (\(V2 _ h, _) -> h < 1)
@@ -35,6 +35,9 @@ rezBox ls =
where
s = "RESPAWN POINT SET AT THIS LOCATION."
tutorialMessage1 :: String
tutorialMessage1 = "SYNTHESIS SUCCESSFUL. MOVEMENT TEST 1 INITIATED [WASD]. INTERACTION TEST 1 IN QUEUE [SPACE]."
rezBox' :: RandomGen g => State g (MetaTree Room String)
rezBox' = do
col <- rezColor
+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,
+43 -200
View File
@@ -3,7 +3,6 @@
module Dodge.Terminal (
makeTermLine,
connectionBlurbLines,
disconnectTerminal,
textTerminal,
simpleTermMessage,
damageCodeCommand,
@@ -13,19 +12,15 @@ module Dodge.Terminal (
toggleCommand,
terminalReturnEffect,
getCommands,
makeColorTermPara,
commandColor,
tabComplete,
tlSetStatus,
) where
--import Dodge.Data.WorldEffect
import qualified Data.Map.Strict as M
import Color
import Data.Char
import qualified Data.List as List
import Color
import qualified Data.ListTrie.Patricia.Map.Enum as PTE
import qualified Data.Map.Strict as M
--import Control.Monad
--import Data.Char
--import qualified Data.Map.Strict as M
@@ -41,10 +36,7 @@ import LensHelp
import Sound.Data
textTerminal :: Terminal
textTerminal =
defaultTerminal
{ _tmBootLines = connectionBlurb
}
textTerminal = defaultTerminal{_tmBootLines = connectionBlurb}
connectionBlurbLines :: [TerminalLine] -> [TerminalLine]
connectionBlurbLines tls =
@@ -54,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 []
@@ -122,30 +67,38 @@ getCommand tm = \case
TCSensorInfo -> sensorCommand
damageCodeCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
damageCodeCommand = PTE.singleton "DAMAGECODE" $ PTE.fromList $ mapMaybe f [minBound..]
damageCodeCommand = 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])
g = fmap (map toUpper) . fmap reverse . List.stripPrefix (reverse "Sensor")
. reverse . show
g =
fmap (map toUpper) . fmap reverse . List.stripPrefix (reverse "Sensor")
. reverse
. show
-- ugly, when changing check getSensorInfo
sensorCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
sensorCommand = PTE.singleton "SENSOR" $ PTE.fromList
[("REQUIREMENT", [])
,("DISTANCE",[])
,("STATUS",[])
]
sensorCommand =
PTE.singleton "SENSOR" $
PTE.fromList
[ ("REQUIREMENT", [])
, ("DISTANCE", [])
, ("STATUS", [])
]
toggleCommand :: Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
toggleCommand tm = PTE.singleton "TOGGLE" $ PTE.fromList $
M.toList $ fmap f $ tm ^. tmToggles
toggleCommand tm =
PTE.singleton "TOGGLE" $
PTE.fromList $
M.toList $ fmap f $ tm ^. tmToggles
where
f x = [TLine 1
[TerminalLineConst "TOGGLE DONE!" termTextColor]
(TmWdWdfromWdWd (WdWdNegateTrig $ x ^. ttTriggerID))
f x =
[ TLine
1
[TerminalLineConst "TOGGLE DONE!" termTextColor]
(TmWdWdfromWdWd (WdWdNegateTrig $ x ^. ttTriggerID))
]
helpCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
@@ -158,7 +111,7 @@ helpStrings =
]
quitCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
quitCommand = PTE.singleton "QUIT" (PTE.singleton "" [TLine 0 [] TmWdWdDisconnectTerminal])
quitCommand = PTE.singleton "QUIT" (PTE.singleton "" [TLine 0 [] TmWdWdPowerDownTerminal])
makeTermLine :: String -> TerminalLine
makeTermLine = makeColorTermLine termTextColor
@@ -191,96 +144,13 @@ tabComplete s' tm = case PTE.lookup s $ getCommands tm of
[] -> tm
[x] -> tm & tmStatus . tiText .~ (y ++ x)
xs ->
tm & tmStatus .~ TerminalLineRead
tm & tmStatus .~ TerminalLineRead
& tmFutureLines
.~ (makeColorTermPara
commandColor
(unwords xs) <> [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
-- }
disconnectTerminal :: Terminal -> World -> World
disconnectTerminal tm =
(cWorld . lWorld . terminals . ix (_tmID tm) . tmStatus .~ TerminalOff)
. exitTerminalSubInv
. ( cWorld . lWorld . terminals . ix (_tmID tm) . tmDisplayedLines .~ []
)
exitTerminalSubInv :: World -> World
exitTerminalSubInv w = case w ^? hud . hudElement . subInventory . termID of
Just _ ->
w & hud . hudElement . subInventory
.~ NoSubInventory --MouseInvNothing
_ -> w
.~ ( makeColorTermPara
commandColor
(unwords xs)
<> [TLine 1 [] . TmTmSetStatus $ TerminalTextInput s]
)
--damageCodeCommand :: TerminalCommand
--damageCodeCommand =
@@ -306,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
+1
View File
@@ -10,6 +10,7 @@ import Control.Lens
termScreenColor :: Terminal -> Maybe Color
termScreenColor tm = case tm ^. tmStatus of
TerminalOff -> Nothing
TerminalDeactivated -> Nothing
TerminalTextInput _ -> Just green
TerminalPressTo{} -> Just green
TerminalLineRead -> Just white
+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)
+2 -5
View File
@@ -397,11 +397,8 @@ updateMouseContextGame cfig u = case u ^. uvWorld . input . mouseContext of
tm <- w ^? cWorld . lWorld . terminals . ix tmid
return $
if isOverTerminalScreen cfig mpos
then fromMaybe NoMouseContext $ do
let s = tm ^. tmStatus . tiText
guard $ not (null s) -- && _tmStatus tm == TerminalTextInput
return $ OverTerminalReturn tmid
else OverTerminalEscape
then OverTerminal tmid (tm ^. tmStatus)
else OutsideTerminal
getMenuMouseContext :: ScreenLayer -> Universe -> MouseContext
getMenuMouseContext screen u = case screen ^. scOptions of
+11 -5
View File
@@ -218,9 +218,9 @@ updateMouseClickInGame cfig w = case w ^. input . mouseContext of
&& isGroupSelectableSection (fst x) ->
w & input . mouseContext .~ OverInvDragSelect x (Just $ snd x)
OverInvSelect x -> startDrag x cfig w
OverTerminalReturn tmid -> terminalReturnEffect tmid w
OverTerminalContinue tmid -> undefined
OverTerminalEscape -> w & hud . hudElement . subInventory .~ NoSubInventory
OverTerminal tmid (TerminalTextInput {}) -> terminalReturnEffect tmid w
OverTerminal tmid (TerminalPressTo{}) -> continueTerminal tmid w
OutsideTerminal -> w & hud . hudElement . subInventory .~ NoSubInventory
OverCombSelect x ->
w & hud . hudElement . subInventory . ciSelection ?~ f x
& worldEventFlags . at CombineInventoryChange ?~ ()
@@ -385,14 +385,20 @@ updateKeysInTerminal :: Int -> Universe -> Universe
updateKeysInTerminal tmid u = fromMaybe u $ do
tm <- u ^? uvWorld . cWorld . lWorld . terminals . ix tmid
return $ case tm ^. tmStatus of
TerminalDeactivated -> u & uvWorld . hud . hudElement . subInventory .~ NoSubInventory
TerminalTextInput{} -> updateKeysTextInputTerminal tmid u
TerminalPressTo{} -> updateKeyContinueTerminal tmid u
_ -> u
updateKeyContinueTerminal :: Int -> Universe -> Universe
updateKeyContinueTerminal tmid u
| any (==0) $ u ^. uvWorld . input . pressedKeys =
u & uvWorld . cWorld . lWorld . terminals . ix tmid . tmStatus .~ TerminalLineRead
u & uvWorld %~ continueTerminal tmid
| otherwise = u
continueTerminal :: Int -> World -> World
continueTerminal tmid = cWorld . lWorld . terminals . ix tmid . tmStatus .~ TerminalLineRead
updateKeysTextInputTerminal :: Int -> Universe -> Universe
updateKeysTextInputTerminal tmid u =
u
@@ -546,7 +552,7 @@ getCloseObj w = getSelectedCloseObj w <|> firstcitem <|> firstcbut
tryCombine :: (Int, Int) -> World -> World
tryCombine (i, j) w = fromMaybe w $ do
sss <- w ^? hud . hudElement . subInventory . ciSections
CombinableItem is it <- sss ^? ix i . ssItems . ix j . siPayload
CombinableItem is it <- sss ^? ix i . ssItems . ix j . siPayload . _Just
p <- w ^? cWorld . lWorld . creatures . ix 0 . crPos
return $
snd (createItemYou it (foldr (destroyInvItem 0) w (sort is)))
+2 -2
View File
@@ -63,11 +63,11 @@ mouseClickOptionsList u = fromMaybe u $ do
case u ^. uvWorld . input . mouseButtons of
mbs | mbs ^. at ButtonLeft == Just 0 -> do
i <- u ^? uvWorld . input . mouseContext . mcoMenuClick
f <- sl ^? ix i . siPayload . _1
f <- sl ^? ix i . siPayload . _Just . _1
return $ f u & uvSoundQueue .:~ click1S
mbs | mbs ^. at ButtonRight == Just 0 -> do
i <- u ^? uvWorld . input . mouseContext . mcoMenuClick
f <- sl ^? ix i . siPayload . _2
f <- sl ^? ix i . siPayload . _Just . _2
return $ f u & uvSoundQueue .:~ click1S
_ -> Nothing
+39 -13
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.WorldEffect (
doWdWd,
accessTerminal,
@@ -6,6 +7,7 @@ module Dodge.WorldEffect (
lineOutputTerminal,
) where
import Control.Monad
import Data.Foldable
import qualified Data.Map.Strict as M
import Data.Maybe
@@ -51,12 +53,13 @@ doWdWd we = case we of
loc <- invIndents (cr ^. crInv) ^? ix invid . _2
return $ heldEffectMuzzles loc cr w
accessTerminal :: Maybe Int -> World -> World
accessTerminal mtmid w = fromMaybe w $ do
tmid <- mtmid
accessTerminal :: Int -> World -> World
accessTerminal tid w = fromMaybe w $ do
tm <- w ^? cWorld . lWorld . terminals . ix tid
guard (tm ^. tmStatus /= TerminalDeactivated)
return $
w & hud . hudElement . subInventory .~ DisplayTerminal tmid
& cWorld . lWorld . terminals . ix tmid %~ tryToBoot
w & hud . hudElement . subInventory .~ DisplayTerminal tid
& cWorld . lWorld . terminals . ix tid %~ tryToBoot
where
tryToBoot tm = case _tmStatus tm of
TerminalTextInput{} -> tm
@@ -66,6 +69,7 @@ accessTerminal mtmid w = fromMaybe w $ do
tm
& tmFutureLines .~ _tmBootLines tm
& tmStatus .~ TerminalLineRead
TerminalDeactivated -> error "managed to boot a deactivated terminal"
torqueCr :: Float -> Int -> World -> World
torqueCr x cid w
@@ -84,7 +88,8 @@ lineOutputTerminal tls =
}
doDeathTriggers :: Terminal -> World -> World
doDeathTriggers tm = cWorld . lWorld . triggers %~ flip (foldl' $ flip doDeathToggle) xs
doDeathTriggers tm = (cWorld . lWorld . triggers %~ flip (foldl' $ flip doDeathToggle) xs)
. (cWorld . lWorld . terminals . ix (tm ^. tmID) . tmStatus .~ TerminalDeactivated)
where
xs = M.elems $ _tmToggles tm
@@ -98,17 +103,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)))
@@ -116,18 +122,38 @@ doTmWdWd tmwdwd = case tmwdwd of
-- tid <- tm ^? tmID
-- return $ cWorld . lWorld . terminals . ix tid . tmPartialCommand .~ x
TmWdId -> const id
TmWdWdDisconnectTerminal -> disconnectTerminal
TmWdWdPowerDownTerminal -> powerDownTerminal
TmWdWdDeactivateTerminal -> deactivateTerminal
TmWdWdTermSound sid -> \tm w ->
let tpos = fromMaybe 0 $ w ^? cWorld . lWorld . buttons . ix (_tmButtonID tm) . btPos
in soundStart TerminalSound tpos sid Nothing w
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
+291 -287
View File
File diff suppressed because it is too large Load Diff