Compare 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
justin 2f4fcb42e5 Work on press-continue terminal prompts 2025-08-19 11:08:54 +01:00
31 changed files with 578 additions and 690 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 drawButton bt = case bt ^. btEvent of
ButtonPress {_bpColor = col} -> defaultDrawButton col bt ButtonPress {_bpColor = col} -> defaultDrawButton col bt
ButtonSwitch {_bsColor1 = col1, _bsColor2 = col2} -> drawSwitch col1 col2 bt ButtonSwitch {_bsColor1 = col1, _bsColor2 = col2} -> drawSwitch col1 col2 bt
ButtonAccessTerminal -> mempty ButtonAccessTerminal _ -> mempty
-- ButtonDoNothing -> mempty
drawSwitch :: Color -> Color -> Button -> SPic drawSwitch :: Color -> Color -> Button -> SPic
drawSwitch col1 col2 bt drawSwitch col1 col2 bt
+2 -3
View File
@@ -5,7 +5,6 @@ import Control.Lens
import Dodge.Data.World import Dodge.Data.World
import Dodge.SoundLogic import Dodge.SoundLogic
import Dodge.WorldEffect import Dodge.WorldEffect
import Sound.Data
doButtonEvent :: ButtonEvent -> Button -> World -> World doButtonEvent :: ButtonEvent -> Button -> World -> World
doButtonEvent = \case doButtonEvent = \case
@@ -13,10 +12,10 @@ doButtonEvent = \case
ButtonPress False f _ -> buttonFlip f ButtonPress False f _ -> buttonFlip f
ButtonSwitch _ f _ _ True -> buttonFlip f ButtonSwitch _ f _ _ True -> buttonFlip f
ButtonSwitch f _ _ _ False -> buttonFlip f ButtonSwitch f _ _ _ False -> buttonFlip f
ButtonAccessTerminal -> accessTerminal . _btTermMID ButtonAccessTerminal tid -> const $ accessTerminal tid
buttonFlip :: WdWd -> Button -> World -> World buttonFlip :: WdWd -> Button -> World -> World
buttonFlip f bt = buttonFlip f bt =
doWdWd f 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 . 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 combineList = map f . combineItemListYouX
where where
f (is, itm) = f (is, itm) =
SelectionItem SelItem
{ _siPictures = basicItemDisplay itm { _siPictures = basicItemDisplay itm
, _siHeight = itInvHeight itm , _siHeight = itInvHeight itm
, _siWidth = 15 , _siWidth = 15
, _siIsSelectable = True , _siIsSelectable = True
, _siColor = itemInvColor $ baseCI itm , _siColor = itemInvColor $ baseCI itm
, _siOffX = 0 , _siOffX = 0
, _siPayload = CombinableItem is itm , _siPayload = Just $ CombinableItem is itm
} }
combineItemListYouX :: World -> [([Int], Item)] combineItemListYouX :: World -> [([Int], Item)]
+1 -2
View File
@@ -25,14 +25,13 @@ data ButtonEvent
, _bsColor2 :: Color , _bsColor2 :: Color
, _btOn :: Bool , _btOn :: Bool
} }
| ButtonAccessTerminal | ButtonAccessTerminal {_btTermID :: Int}
data Button = Button data Button = Button
{ _btPos :: Point2 { _btPos :: Point2
, _btRot :: Float , _btRot :: Float
, _btEvent :: ButtonEvent , _btEvent :: ButtonEvent
, _btID :: Int , _btID :: Int
, _btTermMID :: Maybe Int
} }
makeLenses ''Button makeLenses ''Button
+3 -2
View File
@@ -5,6 +5,7 @@
module Dodge.Data.Input where module Dodge.Data.Input where
import Dodge.Data.Terminal.Status
import Control.Lens import Control.Lens
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Geometry.Data import Geometry.Data
@@ -28,8 +29,8 @@ data MouseContext
| OverCombCombine { _mcoCombCombine :: (Int,Int)} | OverCombCombine { _mcoCombCombine :: (Int,Int)}
| OverCombFilter | OverCombFilter
| OverCombEscape | OverCombEscape
| OverTerminalReturn {_mcoTermID :: Int} | OverTerminal {_mcoTermID :: Int, _mcoTermStatus :: TerminalStatus}
| OverTerminalEscape | OutsideTerminal
| MouseGameRotate | MouseGameRotate
deriving (Show) deriving (Show)
+2 -10
View File
@@ -41,22 +41,14 @@ data SelectionWidth
| UseItemWidth | UseItemWidth
data SelectionItem a data SelectionItem a
= SelectionItem = SelItem
{ _siPictures :: [String]
, _siHeight :: Int
, _siWidth :: Int
, _siIsSelectable :: Bool
, _siColor :: Color
, _siOffX :: Int
, _siPayload :: a
}
| SelectionInfo
{ _siPictures :: [String] { _siPictures :: [String]
, _siHeight :: Int , _siHeight :: Int
, _siWidth :: Int , _siWidth :: Int
, _siIsSelectable :: Bool , _siIsSelectable :: Bool
, _siColor :: Color , _siColor :: Color
, _siOffX :: Int , _siOffX :: Int
, _siPayload :: Maybe a
} }
makeLenses ''ListDisplayParams makeLenses ''ListDisplayParams
+1 -1
View File
@@ -34,7 +34,7 @@ data SoundOrigin
| GlassBreakSound Int | GlassBreakSound Int
| MaterialSound Material Int | MaterialSound Material Int
| TeleSound Int | TeleSound Int
| LeverSound Int | ButtonSound Int
| Explosion Int | Explosion Int
| Tap Int | Tap Int
| EBSound Int | EBSound Int
+3 -3
View File
@@ -36,7 +36,6 @@ data Terminal = Terminal
, _tmStatus :: TerminalStatus , _tmStatus :: TerminalStatus
, _tmCommandHistory :: [String] , _tmCommandHistory :: [String]
, _tmToggles :: M.Map String TerminalToggle , _tmToggles :: M.Map String TerminalToggle
-- , _tmPartialCommand :: Maybe TerminalCommand
} }
data TerminalLineString = TerminalLineConst String Color data TerminalLineString = TerminalLineConst String Color
@@ -77,7 +76,7 @@ data TerminalCommandEffect
-- , _tcEffect :: TerminalCommandEffect -- Terminal -> World -> EffectArguments -- , _tcEffect :: TerminalCommandEffect -- Terminal -> World -> EffectArguments
-- } -- }
data TCom = TCInfo String String data TCom = TCInfo String String -- this may not be necessary, to revisit
| TCBase | TCBase
| TCDamageCommand | TCDamageCommand
| TCSensorInfo | TCSensorInfo
@@ -90,7 +89,8 @@ data TCom = TCInfo String String
data TmWdWd data TmWdWd
= TmWdId = TmWdId
| TmWdWdDisconnectTerminal | TmWdWdPowerDownTerminal
| TmWdWdDeactivateTerminal
| TmWdWdfromWdWd WdWd | TmWdWdfromWdWd WdWd
| TmWdWdTermSound SoundID | TmWdWdTermSound SoundID
| TmWdWdDoDeathTriggers | TmWdWdDoDeathTriggers
+3 -2
View File
@@ -9,10 +9,11 @@ import Data.Aeson.TH
data TerminalStatus data TerminalStatus
= TerminalOff = TerminalOff
| TerminalBusy | TerminalDeactivated
| TerminalLineRead
| TerminalTextInput {_tiText :: String} | TerminalTextInput {_tiText :: String}
| TerminalPressTo {_tptString :: String} | TerminalPressTo {_tptString :: String}
deriving (Eq) deriving (Eq,Show)
makeLenses ''TerminalStatus makeLenses ''TerminalStatus
deriveJSON defaultOptions ''TerminalStatus deriveJSON defaultOptions ''TerminalStatus
+2 -2
View File
@@ -20,9 +20,9 @@ data ItCrWdWd = ItCrWdItemHeldEffect
data WdWd data WdWd
= NoWorldEffect = NoWorldEffect
| SetTrigger Bool Int | SetTrigger Bool Int
| WorldEffects [WdWd] | WorldEffects [WdWd] -- probably best to avoid recursive types if possible...
| SetLSCol Point3 Int | SetLSCol Point3 Int
| AccessTerminal (Maybe Int) | AccessTerminal Int
| UnlockInv | UnlockInv
| SoundStart SoundOrigin Point2 SoundID (Maybe Int) | SoundStart SoundOrigin Point2 SoundID (Maybe Int)
| MakeStartCloudAt Point3 | MakeStartCloudAt Point3
@@ -1,6 +1,6 @@
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
module Dodge.Debug.Console where module Dodge.Debug.Terminal where
import Data.Foldable import Data.Foldable
import Dodge.Item.Location.Initialize import Dodge.Item.Location.Initialize
@@ -19,14 +19,14 @@ import LensHelp
import MaybeHelp import MaybeHelp
import Text.Read (readMaybe) import Text.Read (readMaybe)
applyConsoleString :: [String] -> Universe -> Universe applyTerminalString :: [String] -> Universe -> Universe
applyConsoleString ss = case ss of applyTerminalString ss = case ss of
[] -> id [] -> id
[s] -> applyConsoleCommand s [s] -> applyTerminalCommand s
(s : ss') -> applyConsoleCommandArguments s ss' (s : ss') -> applyTerminalCommandArguments s ss'
applyConsoleCommand :: String -> Universe -> Universe applyTerminalCommand :: String -> Universe -> Universe
applyConsoleCommand s = case s of applyTerminalCommand s = case s of
"NOCLIP" -> uvConfig . debug_booleans . at Noclip %~ toggleJust "NOCLIP" -> uvConfig . debug_booleans . at Noclip %~ toggleJust
['L', x] -> ['L', x] ->
(uvWorld . cWorld . lWorld %~ initSpecificCrItemLocations 0) (uvWorld . cWorld . lWorld %~ initSpecificCrItemLocations 0)
@@ -39,8 +39,8 @@ applyConsoleCommand s = case s of
(ibt, n) <- parseItem [x] (ibt, n) <- parseItem [x]
return $ uvWorld %~ flip (foldl' (&)) (replicate n (snd . createItemYou (itemFromBase ibt))) return $ uvWorld %~ flip (foldl' (&)) (replicate n (snd . createItemYou (itemFromBase ibt)))
applyConsoleCommandArguments :: String -> [String] -> Universe -> Universe applyTerminalCommandArguments :: String -> [String] -> Universe -> Universe
applyConsoleCommandArguments command args u = case command of applyTerminalCommandArguments command args u = case command of
"IT" -> fromMaybe u $ do "IT" -> fromMaybe u $ do
(ibt, n) <- parseItem args (ibt, n) <- parseItem args
return $ u & uvWorld %~ flip (foldl' (&)) (replicate n (snd . createItemYou (itemFromBase ibt))) return $ u & uvWorld %~ flip (foldl' (&)) (replicate n (snd . createItemYou (itemFromBase ibt)))
@@ -75,33 +75,33 @@ parseItem [] = Nothing
parseNum :: [String] -> Int parseNum :: [String] -> Int
parseNum xs = fromMaybe 1 $ xs ^? ix 0 >>= readMaybe parseNum xs = fromMaybe 1 $ xs ^? ix 0 >>= readMaybe
showConsoleError :: String -> String -> Universe -> Universe showTerminalError :: String -> String -> Universe -> Universe
showConsoleError cmd s = uvScreenLayers .:~ InputScreen cmd s showTerminalError cmd s = uvScreenLayers .:~ InputScreen cmd s
applySetConsoleString :: String -> Universe -> Universe applySetTerminalString :: String -> Universe -> Universe
applySetConsoleString [] = id applySetTerminalString [] = id
applySetConsoleString var = case key' of applySetTerminalString var = case key' of
"" -> showConsoleError ("set " ++ var) ("Unable to read as argument as float: " ++ val) "" -> showTerminalError ("set " ++ var) ("Unable to read as argument as float: " ++ val)
"hp" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crHP .~ round (fromJust val') "hp" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crHP .~ round (fromJust val')
-- "invcap" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crInvCapacity .~ round (fromJust val') -- "invcap" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crInvCapacity .~ round (fromJust val')
-- "mass" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crMass .~ fromJust val' -- "mass" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crMass .~ fromJust val'
-- "mvspeed" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crMvType . mvSpeed .~ fromJust val' -- "mvspeed" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crMvType . mvSpeed .~ fromJust val'
"mvspeed" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crType . avMoveSpeed .~ fromJust val' "mvspeed" -> uvWorld . cWorld . lWorld . creatures . ix 0 . crType . avMoveSpeed .~ fromJust val'
_ -> showConsoleError ("set " ++ var) ("Invalid set command: " ++ key) -- never reached? _ -> showTerminalError ("set " ++ var) ("Invalid set command: " ++ key) -- never reached?
where where
(key, val) = getSplitString var (key, val) = getSplitString var
val' = readMaybe val :: Maybe Float val' = readMaybe val :: Maybe Float
key' = if isNothing val' then "" else key key' = if isNothing val' then "" else key
--autoCompleteConsole :: String -> String -> Universe -> IO (Maybe Universe) --autoCompleteTerminal :: String -> String -> Universe -> IO (Maybe Universe)
--autoCompleteConsole s _ = --autoCompleteTerminal s _ =
-- return -- return
-- . (popScreen' >=> pushScreen' (InputScreen (T.pack input_str) valid_commands)) -- . (popScreen' >=> pushScreen' (InputScreen (T.pack input_str) valid_commands))
-- where -- where
-- (key, val) = getSplitString $ tail s -- (key, val) = getSplitString $ tail s
-- command_options = case val of -- command_options = case val of
-- "" -> filter (isInfixOf key) (validConsoleCommands "") -- "" -> filter (isInfixOf key) (validTerminalCommands "")
-- _ -> filter (isInfixOf val) (validConsoleCommands key) -- _ -> filter (isInfixOf val) (validTerminalCommands key)
-- -- basic autocomplete if single option available (or as far as possible) -- -- basic autocomplete if single option available (or as far as possible)
-- input_str = case (key, val) of -- input_str = case (key, val) of
-- (_, "") -> -- (_, "") ->
@@ -117,7 +117,7 @@ applySetConsoleString var = case key' of
-- else ">" ++ key ++ " " ++ longestCommonPrefix command_options -- else ">" ++ key ++ " " ++ longestCommonPrefix command_options
-- command_options' = -- command_options' =
-- if not (null command_options) && head command_options == key -- if not (null command_options) && head command_options == key
-- then validConsoleCommands key -- then validTerminalCommands key
-- else command_options -- else command_options
-- --
-- --val' = Debug.Trace.trace key tail val -- --val' = Debug.Trace.trace key tail val
@@ -129,12 +129,12 @@ getSplitString str = case break (== ' ') str of
(a, _) -> (a, "") (a, _) -> (a, "")
isValidCommand :: String -> String -> Bool isValidCommand :: String -> String -> Bool
isValidCommand arg1 arg2 = arg2 `elem` validConsoleCommands arg1 isValidCommand arg1 arg2 = arg2 `elem` validTerminalCommands arg1
validConsoleCommands :: String -> [String]
validConsoleCommands "set" = ["hp", "invcap", "invsel", "mass", "mvspeed"] validTerminalCommands :: String -> [String]
validConsoleCommands "god" = ["on", "off"] validTerminalCommands "set" = ["hp", "invcap", "invsel", "mass", "mvspeed"]
validConsoleCommands _ = ["set", "spawn", "god"] validTerminalCommands "god" = ["on", "off"]
validConsoleCommands _ = ["set", "spawn", "god"] validTerminalCommands _ = ["set", "spawn", "god"]
loadme :: a loadme :: a
loadme = undefined loadme = undefined
+2 -7
View File
@@ -46,16 +46,11 @@ defaultMachine =
} }
defaultButton :: Button defaultButton :: Button
defaultButton = defaultButton = Button
Button { _btPos = 0
{ _btPos = V2 0 0
, _btRot = 0 , _btRot = 0
, _btEvent = ButtonPress False NoWorldEffect (dark red) , _btEvent = ButtonPress False NoWorldEffect (dark red)
, _btID = 0 , _btID = 0
-- , _btState = BtOff
, _btTermMID = Nothing
-- , _btName = ""
-- , _btColor = red
} }
defaultPP :: PressPlate defaultPP :: PressPlate
+1 -1
View File
@@ -16,7 +16,7 @@ defaultTerminal =
, _tmMachineID = 0 , _tmMachineID = 0
, _tmDisplayedLines = [] , _tmDisplayedLines = []
, _tmFutureLines = [] , _tmFutureLines = []
, _tmCommands = [TCInfo "TESA" "text 2",TCInfo "TEST" "display text",TCBase] , _tmCommands = [TCBase]
, _tmDeathEffect = TmWdWdDoDeathTriggers , _tmDeathEffect = TmWdWdDoDeathTriggers
, _tmStatus = TerminalOff , _tmStatus = TerminalOff
, _tmCommandHistory = [] , _tmCommandHistory = []
+6 -5
View File
@@ -65,12 +65,12 @@ updateCombineSections w cfig =
sclose' sclose'
| null sclose = | null sclose =
IM.singleton 0 $ IM.singleton 0 $
SelectionInfo ["No possible combinations"] 1 25 False white 0 SelItem ["No possible combinations"] 1 25 False white 0 Nothing
| otherwise = sclose | otherwise = sclose
regexCombs :: IM.IntMap Item -> SelectionItem CombinableItem -> String -> Bool regexCombs :: IM.IntMap Item -> SelectionItem CombinableItem -> String -> Bool
regexCombs inv ci = \case regexCombs inv ci = \case
'#' : str -> any (g str) (_ciInvIDs $ _siPayload ci) '#' : str -> any (g str) (_ciInvIDs $ fromJust $ _siPayload ci)
str -> (regexList str . _siPictures) ci str -> (regexList str . _siPictures) ci
where where
g str i = maybe False (regexList str . basicItemDisplay) (inv ^? ix i) g str i = maybe False (regexList str . basicItemDisplay) (inv ^? ix i)
@@ -129,7 +129,7 @@ updateDisplaySections w cfig =
[ invhead [ invhead
, sinv , sinv
, IM.singleton 0 , IM.singleton 0
$ SelectionItem [displayFreeSlots (crNumFreeSlots cr)] 1 15 True invDimColor 2 () $ SelItem [displayFreeSlots (crNumFreeSlots cr)] 1 15 True invDimColor 2 Nothing
, nearbyhead , nearbyhead
, sclose , sclose
, interfaceshead , interfaceshead
@@ -153,7 +153,7 @@ updateDisplaySections w cfig =
btitems = btitems =
IM.fromDistinctAscList . zip [0 ..] $ IM.fromDistinctAscList . zip [0 ..] $
mapMaybe (closeButtonToSelectionItem w) (w ^. hud . closeButtons) 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 invhead = if null sfinv then makehead "INVENTORY" else sfinv
cr = you w cr = you w
closeitms = closeitms =
@@ -179,13 +179,14 @@ filterSectionsPair infocus filtfn itms filtdescription mfilt = (filtsis, itms')
return $ return $
IM.singleton IM.singleton
0 0
$ SelectionInfo $ SelItem
[filtdescription ++ " FILTER/" ++ str ++ [filtcurs], numfiltitems] [filtdescription ++ " FILTER/" ++ str ++ [filtcurs], numfiltitems]
2 2
(length (filtdescription ++ " FILTER/" ++ str ++ [filtcurs])) (length (filtdescription ++ " FILTER/" ++ str ++ [filtcurs]))
True True
white white
0 0
Nothing
itms' = maybe id (IM.filter . filtfn) mfilt itms itms' = maybe id (IM.filter . filtfn) mfilt itms
numfiltitems = " " ++ show (length itms - length itms') ++ " FILTERED" 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 | x > invid || Just x == maxk = max 0 $ x - 1
| otherwise = x | otherwise = x
-- this looks ugly... -- this looks ugly...
updateCloseObjects :: World -> World updateCloseObjects :: World -> World
updateCloseObjects w = updateCloseObjects w =
@@ -137,6 +136,9 @@ updateCloseObjects w =
activeButtons = filter canpress . IM.elems $ w ^. cWorld . lWorld . buttons activeButtons = filter canpress . IM.elems $ w ^. cWorld . lWorld . buttons
canpress bt = case bt ^. btEvent of canpress bt = case bt ^. btEvent of
ButtonPress {_btOn = t} -> not t ButtonPress {_btOn = t} -> not t
ButtonAccessTerminal tid -> fromMaybe False $ do
x <- w ^? cWorld . lWorld . terminals . ix tid . tmStatus
return (x /= TerminalDeactivated)
_ -> True _ -> True
changeSwapSel :: Int -> World -> World changeSwapSel :: Int -> World -> World
+7 -7
View File
@@ -31,14 +31,14 @@ import Picture.Base
invSelectionItem :: World -> Int -> LocationDT OItem -> SelectionItem () invSelectionItem :: World -> Int -> LocationDT OItem -> SelectionItem ()
invSelectionItem w indent loc = invSelectionItem w indent loc =
SelectionItem SelItem
{ _siPictures = itemDisplay w cr ci { _siPictures = itemDisplay w cr ci
, _siHeight = itInvHeight $ ci ^. _1 , _siHeight = itInvHeight $ ci ^. _1
, _siWidth = 15 , _siWidth = 15
, _siIsSelectable = True , _siIsSelectable = True
, _siColor = itemInvColor ci , _siColor = itemInvColor ci
, _siOffX = indent , _siOffX = indent
, _siPayload = () , _siPayload = Nothing
} }
where where
ci = (a,b) ci = (a,b)
@@ -207,35 +207,35 @@ closeItemToSelectionItem w (NInt i) = do
e <- w ^? cWorld . lWorld . floorItems . unNIntMap . ix i e <- w ^? cWorld . lWorld . floorItems . unNIntMap . ix i
let (pics, col) = closeItemToTextPictures e let (pics, col) = closeItemToTextPictures e
return return
SelectionItem SelItem
{ _siPictures = pics { _siPictures = pics
, _siHeight = length pics , _siHeight = length pics
, _siWidth = 15 , _siWidth = 15
, _siIsSelectable = True , _siIsSelectable = True
, _siColor = col , _siColor = col
, _siOffX = 0 , _siOffX = 0
, _siPayload = () , _siPayload = Nothing
} }
closeButtonToSelectionItem :: World -> Int -> Maybe (SelectionItem ()) closeButtonToSelectionItem :: World -> Int -> Maybe (SelectionItem ())
closeButtonToSelectionItem w i = do closeButtonToSelectionItem w i = do
bt <- w ^? cWorld . lWorld . buttons . ix i bt <- w ^? cWorld . lWorld . buttons . ix i
return return
SelectionItem SelItem
{ _siPictures = [btText bt] { _siPictures = [btText bt]
, _siHeight = 1 , _siHeight = 1
, _siWidth = 15 , _siWidth = 15
, _siIsSelectable = True , _siIsSelectable = True
, _siColor = yellow , _siColor = yellow
, _siOffX = 0 , _siOffX = 0
, _siPayload = () , _siPayload = Nothing
} }
btText :: Button -> String btText :: Button -> String
btText bt = case _btEvent bt of btText bt = case _btEvent bt of
ButtonPress {} -> "BUTTON" ButtonPress {} -> "BUTTON"
ButtonSwitch {_btOn = t} -> if t then "SWITCH\\" else "SWITCH/" ButtonSwitch {_btOn = t} -> if t then "SWITCH\\" else "SWITCH/"
ButtonAccessTerminal -> "TERMINAL" ButtonAccessTerminal {} -> "TERMINAL"
closeItemToTextPictures :: FloorItem -> ([String], Color) closeItemToTextPictures :: FloorItem -> ([String], Color)
closeItemToTextPictures flit = (basicItemDisplay it, itemInvColor $ baseCI it) closeItemToTextPictures flit = (basicItemDisplay it, itemInvColor $ baseCI it)
+2 -2
View File
@@ -96,14 +96,14 @@ menuOptionToSelectionItem ::
MenuOption -> MenuOption ->
SelectionItem (Universe -> Universe, Universe -> Universe) SelectionItem (Universe -> Universe, Universe -> Universe)
menuOptionToSelectionItem w padAmount mo = menuOptionToSelectionItem w padAmount mo =
SelectionItem SelItem
{ _siPictures = [optionText] { _siPictures = [optionText]
, _siHeight = 1 , _siHeight = 1
, _siWidth = 50 , _siWidth = 50
, _siIsSelectable = isselectable , _siIsSelectable = isselectable
, _siColor = thecol , _siColor = thecol
, _siOffX = 0 , _siOffX = 0
, _siPayload = (f, g) , _siPayload = Just (f, g)
} }
where where
isselectable = case _moString mo w of isselectable = case _moString mo w of
+2 -12
View File
@@ -17,7 +17,7 @@ putTerminal :: Color -> Machine -> Terminal -> Placement
putTerminal col mc tm = putTerminal col mc tm =
ps0PushPS (PutTerminal (tm & tmExternalColor .~ col)) $ ps0PushPS (PutTerminal (tm & tmExternalColor .~ col)) $
\tmpl -> Just $ \tmpl -> Just $
ps0PushPS (PutButton termButton) $ ps0PushPS (PutButton defaultButton) $
\btpl -> Just $ \btpl -> Just $
pt0 pt0
( PutMachine ( PutMachine
@@ -34,7 +34,7 @@ putTerminal col mc tm =
& cWorld . lWorld . terminals . ix tmid . tmButtonID .~ btid & cWorld . lWorld . terminals . ix tmid . tmButtonID .~ btid
& cWorld . lWorld . terminals . ix tmid . tmMachineID .~ mcid & cWorld . lWorld . terminals . ix tmid . tmMachineID .~ mcid
& cWorld . lWorld . machines . ix mcid . mcMounts . at OTTerminal ?~ tmid & 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 where
tmid = fromJust (_plMID tmpl) tmid = fromJust (_plMID tmpl)
btid = fromJust (_plMID btpl) btid = fromJust (_plMID btpl)
@@ -48,15 +48,5 @@ putMessageTerminal col =
& mcType .~ McTerminal & mcType .~ McTerminal
& mcHP .~ 100 & mcHP .~ 100
termButton :: Button
termButton =
Button
{ _btPos = 0
, _btRot = 0
, _btEvent = ButtonAccessTerminal
, _btID = 0
, _btTermMID = Nothing
}
terminalColor :: Color terminalColor :: Color
terminalColor = dark magenta terminalColor = dark magenta
+18 -30
View File
@@ -1,10 +1,7 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module Dodge.Render.HUD ( module Dodge.Render.HUD (drawHUD) where
drawHUD,
) where
import Dodge.Data.Terminal.Status
import Control.Applicative import Control.Applicative
import Control.Lens import Control.Lens
import Control.Monad import Control.Monad
@@ -23,6 +20,7 @@ import Dodge.Data.Config
import Dodge.Data.DoubleTree import Dodge.Data.DoubleTree
import Dodge.Data.EquipType import Dodge.Data.EquipType
import Dodge.Data.SelectionList import Dodge.Data.SelectionList
import Dodge.Data.Terminal.Status
import Dodge.Data.World import Dodge.Data.World
import Dodge.DoubleTree import Dodge.DoubleTree
import Dodge.Equipment.Text import Dodge.Equipment.Text
@@ -34,7 +32,6 @@ import Dodge.Item.InvSize
import Dodge.Item.Location import Dodge.Item.Location
import Dodge.ListDisplayParams import Dodge.ListDisplayParams
import Dodge.Render.Connectors import Dodge.Render.Connectors
--import Dodge.Render.HUD.Carte
import Dodge.Render.List import Dodge.Render.List
import Dodge.ScreenPos import Dodge.ScreenPos
import Dodge.SelectionSections import Dodge.SelectionSections
@@ -105,9 +102,7 @@ getRootItemBounds i inv = do
drawMouseOver :: Configuration -> World -> Picture drawMouseOver :: Configuration -> World -> Picture
drawMouseOver cfig w = drawMouseOver cfig w =
concat concat
( invsel <|> combinvsel (invsel <|> combinvsel <|> drawDragSelecting cfig w)
<|> drawDragSelecting cfig w
)
<> concat (drawDragSelected cfig w) <> concat (drawDragSelected cfig w)
where where
invsel = do invsel = do
@@ -211,14 +206,14 @@ drawExamineInventory cfig w =
) )
where where
f str = f str =
SelectionItem SelItem
{ _siPictures = [str] { _siPictures = [str]
, _siWidth = 55 , _siWidth = 55
, _siHeight = 1 , _siHeight = 1
, _siIsSelectable = True , _siIsSelectable = True
, _siColor = white , _siColor = white
, _siOffX = 0 , _siOffX = 0
, _siPayload = () , _siPayload = Nothing
} }
closeObjectInfo :: Int -> Either FloorItem Button -> String 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 j <- w ^? hud . closeItems . ix i . unNInt
flit <- w ^? cWorld . lWorld . floorItems . unNIntMap . ix j flit <- w ^? cWorld . lWorld . floorItems . unNIntMap . ix j
return . g $ Left flit return . g $ Left flit
-- g . Left $ w ^?! hud . closeItems . ix i
Just (SelCloseButton i) -> fromMaybe x $ do Just (SelCloseButton i) -> fromMaybe x $ do
j <- w ^? hud . closeButtons . ix i j <- w ^? hud . closeButtons . ix i
flit <- w ^? cWorld . lWorld . buttons . ix j but <- w ^? cWorld . lWorld . buttons . ix j
return . g $ Right flit return . g $ Right but
_ -> x _ -> x
drawRBOptions :: Configuration -> World -> Picture drawRBOptions :: Configuration -> World -> Picture
@@ -343,13 +337,12 @@ combineInventoryExtra ::
Configuration -> Configuration ->
World -> World ->
Picture Picture
combineInventoryExtra sss msel cfig w = fromMaybe mempty $ do combineInventoryExtra sss msel cfig w = fold $ do
(i, j) <- msel (i, j) <- msel
si <- sss ^? ix i . ssItems . ix j si <- sss ^? ix i . ssItems . ix j
let col = _siColor si let col = _siColor si
lnks <- si ^? siPayload . ciInvIDs lnks <- si ^? siPayload . _Just . ciInvIDs
return (lnkMidPosInvSelsCol cfig w j col lnks) return (lnkMidPosInvSelsCol cfig w j col lnks) <> foldMap invcursor lnks
<> foldMap invcursor lnks
where where
invcursor i = do invcursor i = do
sss' <- w ^? hud . hudElement . diSections sss' <- w ^? hud . hudElement . diSections
@@ -362,37 +355,32 @@ combineInventoryExtra sss msel cfig w = fromMaybe mempty $ do
(Just (0, i)) (Just (0, i))
drawTerminalDisplay :: Int -> Configuration -> LWorld -> Picture drawTerminalDisplay :: Int -> Configuration -> LWorld -> Picture
drawTerminalDisplay tid cfig w = fromMaybe mempty $ do drawTerminalDisplay tid cfig w = fold $ do
tm <- w ^? terminals . ix tid tm <- w ^? terminals . ix tid
let tsize = getMaxLinesTM + 1 let tsize = getMaxLinesTM + 1
return $ return $
invHead cfig ("T-" ++ show tid) invHead cfig ("T-" ++ show tid)
<> drawSelectionList secondColumnParams cfig (thesellist tm) <> drawSelectionList secondColumnParams cfig (f tm)
<> color <> color
(withAlpha 0.5 green) -- consider integrating termScreenColor somehow (withAlpha 0.5 green) -- consider integrating termScreenColor somehow
(drawSelectionListBackground secondColumnParams cfig tsize) (drawSelectionListBackground secondColumnParams cfig tsize)
<> color (dark $ _tmExternalColor tm) (drawTitleBackground cfig) <> color (dark $ _tmExternalColor tm) (drawTitleBackground cfig)
where 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 -- not sure if the width (55) is correct here
thesellist tm = thelist tm f tm =
thelist tm =
map toselitm . displayTermInput tm map toselitm . displayTermInput tm
. reverse . reverse
. take getMaxLinesTM . take getMaxLinesTM
$ _tmDisplayedLines tm $ _tmDisplayedLines tm
displayTermInput tm = case _tmStatus tm of displayTermInput tm = case _tmStatus tm of
TerminalOff -> id TerminalOff -> id
TerminalBusy -> (++ [([cFilledRect], white)]) TerminalDeactivated -> id
TerminalLineRead -> id
TerminalTextInput s -> TerminalTextInput s ->
(++ [(getPromptTM ++ s ++ [cFilledRect], white)]) (++ [(getPromptTM ++ s ++ [cFilledRect], white)])
TerminalPressTo s -> TerminalPressTo s ->
(++ [("PRESS TO "++s, white)]) (++ [(getPromptTM ++ "PRESS TO " ++ s, white)])
-- partcommand tm = maybe "" (++ " ") $ tm ^? tmPartialCommand . _Just . tcString
-- displayInputText tm s
-- | TerminalTextInput <- _tmStatus tm = getPromptTM ++ s
---- | _tmStatus tm == TerminalReady = partcommand tm ++ getPromptTM ++ s
-- | otherwise = ""
-- | hasfoc = clockCycle 10 (V.fromList [[cFilledRect] , "."]) w -- | hasfoc = clockCycle 10 (V.fromList [[cFilledRect] , "."]) w
@@ -511,4 +499,4 @@ selNumPosCardinal card cfig ldp sss i j = do
ygap = _ldpVerticalGap ldp ygap = _ldpVerticalGap ldp
selSecSelCol :: Int -> Int -> IM.IntMap (SelectionSection a) -> Maybe Color 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 -2
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Render.Picture ( module Dodge.Render.Picture (
fixedCoordPictures, fixedCoordPictures,
) where ) where
@@ -109,8 +110,8 @@ mouseCursorType u = case u ^. uvWorld . input . mouseContext of
OverCombFilter{} -> drawJumpDown 5 OverCombFilter{} -> drawJumpDown 5
OverCombCombine{} -> drawGapPlus 5 OverCombCombine{} -> drawGapPlus 5
OverCombEscape -> rotate (pi / 4) $ drawPlus 5 OverCombEscape -> rotate (pi / 4) $ drawPlus 5
OverTerminalReturn{} -> drawReturn 5 OverTerminal _ ts -> drawCursorByTerminalStatus ts
OverTerminalEscape -> rotate (pi / 4) $ drawPlus 5 OutsideTerminal -> rotate (pi / 4) $ drawPlus 5
MouseGameRotate -> rotate a (drawVerticalDoubleArrow 5) MouseGameRotate -> rotate a (drawVerticalDoubleArrow 5)
where where
w = u ^. uvWorld w = u ^. uvWorld
@@ -121,6 +122,21 @@ mouseCursorType u = case u ^. uvWorld . input . mouseContext of
argV (w ^. cWorld . lWorld . lAimPos -.- cpos) argV (w ^. cWorld . lWorld . lAimPos -.- cpos)
- w ^. wCam . camRot - 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 :: Float -> Picture
drawEmptySet x = drawEmptySet x =
fold fold
@@ -201,6 +217,14 @@ drawVerticalDoubleArrow x =
z = 1.5 * x z = 1.5 * x
w = 0.6 * 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 :: Float -> Picture
drawDragDrop x = drawDragDrop x =
line (fmap (+ V2 z (- x)) [V2 (- x) x, V2 0 x, V2 0 (- x)]) line (fmap (+ V2 z (- x)) [V2 (- x) x, V2 0 x, V2 0 (- x)])
+7 -1
View File
@@ -1,5 +1,6 @@
module Dodge.Room.RezBox where module Dodge.Room.RezBox where
import Dodge.Default.Terminal
import Dodge.Terminal import Dodge.Terminal
import Control.Monad import Control.Monad
import qualified Data.Set as S import qualified Data.Set as S
@@ -25,12 +26,17 @@ rezBox :: LightSource -> Room
rezBox ls = rezBox ls =
roomRect 40 60 1 1 roomRect 40 60 1 1
& rmPmnts .~ [sPS (V2 20 1) 0 $ PutLS ls & rmPmnts .~ [sPS (V2 20 1) 0 $ PutLS ls
, putMessageTerminal terminalColor (simpleTermMessage ["HELLOW","THIS"]) , putMessageTerminal terminalColor (defaultTerminal & tmBootLines .~ (makeTermPara s) <> tlSetStatus (TerminalPressTo "QUIT") <> [TLine 1 [] TmWdWdDeactivateTerminal])
& plSpot .~ PS (V2 20 0) 0 & plSpot .~ PS (V2 20 0) 0
] ]
& restrictInLinks (\(V2 _ h, _) -> h < 1) & restrictInLinks (\(V2 _ h, _) -> h < 1)
& restrictOutLinks (\(V2 _ h, _) -> h > 59) & restrictOutLinks (\(V2 _ h, _) -> h > 59)
& rmName .~ "rezBox" & rmName .~ "rezBox"
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' :: RandomGen g => State g (MetaTree Room String)
rezBox' = do rezBox' = do
+1 -1
View File
@@ -11,7 +11,7 @@ module Dodge.SoundLogic (
soundContinueVol, soundContinueVol,
soundMultiFrom, soundMultiFrom,
stopSoundFrom, stopSoundFrom,
soundWithStatus, -- soundWithStatus,
-- * helper to determine the angle of a sound given a world position -- * helper to determine the angle of a sound given a world position
soundAngle, soundAngle,
+39 -201
View File
@@ -1,14 +1,8 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module Dodge.Terminal ( module Dodge.Terminal (
-- doTerminalCommandEffect,
makeTermLine, makeTermLine,
-- commandFutureLines,
-- quitCommand,
-- helpCommand,
-- commandsCommand,
connectionBlurbLines, connectionBlurbLines,
disconnectTerminal,
textTerminal, textTerminal,
simpleTermMessage, simpleTermMessage,
damageCodeCommand, damageCodeCommand,
@@ -18,18 +12,15 @@ module Dodge.Terminal (
toggleCommand, toggleCommand,
terminalReturnEffect, terminalReturnEffect,
getCommands, getCommands,
makeColorTermPara,
commandColor,
tabComplete, tabComplete,
tlSetStatus,
) where ) where
--import Dodge.Data.WorldEffect import Color
import qualified Data.Map.Strict as M
import Data.Char import Data.Char
import qualified Data.List as List import qualified Data.List as List
import Color
import qualified Data.ListTrie.Patricia.Map.Enum as PTE import qualified Data.ListTrie.Patricia.Map.Enum as PTE
import qualified Data.Map.Strict as M
--import Control.Monad --import Control.Monad
--import Data.Char --import Data.Char
--import qualified Data.Map.Strict as M --import qualified Data.Map.Strict as M
@@ -45,10 +36,7 @@ import LensHelp
import Sound.Data import Sound.Data
textTerminal :: Terminal textTerminal :: Terminal
textTerminal = textTerminal = defaultTerminal{_tmBootLines = connectionBlurb}
defaultTerminal
{ _tmBootLines = connectionBlurb
}
connectionBlurbLines :: [TerminalLine] -> [TerminalLine] connectionBlurbLines :: [TerminalLine] -> [TerminalLine]
connectionBlurbLines tls = connectionBlurbLines tls =
@@ -58,53 +46,6 @@ connectionBlurbLines tls =
++ tls ++ tls
++ [TLine 10 [TerminalLineConst "READY FOR INPUT" termTextColor] (TmTmSetStatus (TerminalTextInput ""))] ++ [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 :: [TerminalLine]
connectionBlurb = connectionBlurbLines [] connectionBlurb = connectionBlurbLines []
@@ -126,28 +67,36 @@ getCommand tm = \case
TCSensorInfo -> sensorCommand TCSensorInfo -> sensorCommand
damageCodeCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine]) 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 where
f :: SensorType -> Maybe (String, [TerminalLine]) f :: SensorType -> Maybe (String, [TerminalLine])
f st = do f st = do
s <- g st s <- g st
return (s, [TLine 0 [] $ TmGetDamageCoding st]) return (s, [TLine 0 [] $ TmGetDamageCoding st])
g = fmap (map toUpper) . fmap reverse . List.stripPrefix (reverse "Sensor") g =
. reverse . show fmap (map toUpper) . fmap reverse . List.stripPrefix (reverse "Sensor")
. reverse
. show
-- ugly, when changing check getSensorInfo -- ugly, when changing check getSensorInfo
sensorCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine]) sensorCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
sensorCommand = PTE.singleton "SENSOR" $ PTE.fromList sensorCommand =
[("REQUIREMENT", []) PTE.singleton "SENSOR" $
,("DISTANCE",[]) PTE.fromList
,("STATUS",[]) [ ("REQUIREMENT", [])
, ("DISTANCE", [])
, ("STATUS", [])
] ]
toggleCommand :: Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine]) toggleCommand :: Terminal -> PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine])
toggleCommand tm = PTE.singleton "TOGGLE" $ PTE.fromList $ toggleCommand tm =
PTE.singleton "TOGGLE" $
PTE.fromList $
M.toList $ fmap f $ tm ^. tmToggles M.toList $ fmap f $ tm ^. tmToggles
where where
f x = [TLine 1 f x =
[ TLine
1
[TerminalLineConst "TOGGLE DONE!" termTextColor] [TerminalLineConst "TOGGLE DONE!" termTextColor]
(TmWdWdfromWdWd (WdWdNegateTrig $ x ^. ttTriggerID)) (TmWdWdfromWdWd (WdWdNegateTrig $ x ^. ttTriggerID))
] ]
@@ -158,17 +107,18 @@ helpCommand = PTE.singleton "HELP" (fmap makeTermPara helpStrings)
helpStrings :: PTE.TrieMap Char String helpStrings :: PTE.TrieMap Char String
helpStrings = helpStrings =
PTE.fromList PTE.fromList
[ ("", "THIS TERMINAL PROCESSES TEXT INPUT. USE [TAB] FOR AVAILABLE COMMANDS AND AUTOCOMPLETE.") [ ("", "THIS TERMINAL PROCESSES KEYBOARD INPUT. USE [RETURN] OR [LMB] TO REGISTER YOUR INPUT. AVAILABLE COMMANDS CAN BE SCROLLED THROUGH, HOLD [RMB] TO SCROLL THROUGH ARGUMENTS. USE [TAB] FOR AUTOCOMPLETE.")
, ("HELP", "BASIC HELP. ACCEPTS A COMMAND AS AN ARGUMENT.")
, ("QUIT", "SHUTDOWN TERMINAL.")
] ]
quitCommand :: PTE.TrieMap Char (PTE.TrieMap Char [TerminalLine]) 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 :: String -> TerminalLine
makeTermLine = makeColorTermLine termTextColor makeTermLine = makeColorTermLine termTextColor
tlSetStatus :: TerminalStatus -> [TerminalLine]
tlSetStatus x = [TLine 1 [] $ TmTmSetStatus x]
makeTermPara :: String -> [TerminalLine] makeTermPara :: String -> [TerminalLine]
makeTermPara = makeColorTermPara termTextColor makeTermPara = makeColorTermPara termTextColor
@@ -192,99 +142,16 @@ tabComplete s' tm = case PTE.lookup s $ getCommands tm of
a = fromMaybe "" $ ss ^? ix 1 a = fromMaybe "" $ ss ^? ix 1
f y m' = case fmap fst m' of f y m' = case fmap fst m' of
[] -> tm [] -> tm
[x] -> tm & tmStatus .~ TerminalTextInput (y ++ x) [x] -> tm & tmStatus . tiText .~ (y ++ x)
xs -> xs ->
tm & tmFutureLines tm & tmStatus .~ TerminalLineRead
.~ makeColorTermPara & tmFutureLines
.~ ( makeColorTermPara
commandColor commandColor
(unwords xs) (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) . tmFutureLines
.~ [TLine 0 [] TmTmClearDisplayedLines]
) )
exitTerminalSubInv :: World -> World
exitTerminalSubInv w = case w ^? hud . hudElement . subInventory . termID of
Just _ ->
w & hud . hudElement . subInventory
.~ NoSubInventory --MouseInvNothing
_ -> w
--damageCodeCommand :: TerminalCommand --damageCodeCommand :: TerminalCommand
--damageCodeCommand = --damageCodeCommand =
-- TerminalCommand -- TerminalCommand
@@ -309,49 +176,20 @@ exitTerminalSubInv w = case w ^? hud . hudElement . subInventory . termID of
simpleTermMessage :: [String] -> Terminal simpleTermMessage :: [String] -> Terminal
simpleTermMessage strs = defaultTerminal & tmBootLines .~ map makeTermLine strs 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 :: Int -> World -> World
terminalReturnEffect tmid w = fromMaybe w $ do terminalReturnEffect tmid w = fromMaybe w $ do
tm <- w ^? cWorld . lWorld . terminals . ix tmid tm <- w ^? cWorld . lWorld . terminals . ix tmid
s <- tm ^? tmStatus . tiText s <- tm ^? tmStatus . tiText
return $ let ss = fromMaybe [makeTermLine "ERROR: INPUT NOT RECOGNISED"] $ do
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)
%~ ( --(tmInput .~ TerminalInput{ _tiSel = (0, 0)})
(tmFutureLines ++.~ ss)
. (tmCommandHistory %~ take 10 . (s :))
. (tmStatus .~ TerminalTextInput "")
)
where
ss = fromMaybe [makeTermLine "ERROR: INPUT NOT RECOGNISED"] $ do
let args = words s let args = words s
x <- args ^? ix 0 x <- args ^? ix 0
teff <- PTE.lookup x (getCommands tm) teff <- PTE.lookup x (getCommands tm)
let y = fromMaybe "" (args ^? ix 1) let y = fromMaybe "" (args ^? ix 1)
PTE.lookup y teff 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
totm = cWorld . lWorld . terminals . ix tmid
+2 -1
View File
@@ -10,6 +10,7 @@ import Control.Lens
termScreenColor :: Terminal -> Maybe Color termScreenColor :: Terminal -> Maybe Color
termScreenColor tm = case tm ^. tmStatus of termScreenColor tm = case tm ^. tmStatus of
TerminalOff -> Nothing TerminalOff -> Nothing
TerminalDeactivated -> Nothing
TerminalTextInput _ -> Just green TerminalTextInput _ -> Just green
TerminalPressTo{} -> Just green TerminalPressTo{} -> Just green
TerminalBusy -> Just white TerminalLineRead -> Just white
+1 -2
View File
@@ -28,8 +28,7 @@ import qualified IntMapHelp as IM
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
testStringInit :: Universe -> [String] testStringInit :: Universe -> [String]
testStringInit u = [show $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crHP testStringInit u = map show $ u ^.. uvWorld . cWorld . lWorld . terminals . each . tmStatus
, show $ u ^? uvWorld . timeFlow . respawnDelay]
-- map shortShow (u ^.. uvWorld . cWorld . lWorld . debris . each . to g) -- map shortShow (u ^.. uvWorld . cWorld . lWorld . debris . each . to g)
-- where -- where
-- g db = (pz,z,norm v) -- g db = (pz,z,norm v)
+28 -24
View File
@@ -7,10 +7,6 @@ Description : Simulation update
-} -}
module Dodge.Update (updateUniverse) where module Dodge.Update (updateUniverse) where
import Dodge.SpawnAt
import Dodge.Prop.Moving
import Dodge.WorldEvent.Explosion
import Dodge.Data.Object
import Color import Color
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad
@@ -27,6 +23,7 @@ import Dodge.Creature.Radius
import Dodge.Creature.Update import Dodge.Creature.Update
import Dodge.Damage import Dodge.Damage
import Dodge.Data.CrWlID import Dodge.Data.CrWlID
import Dodge.Data.Object
import Dodge.Data.Universe import Dodge.Data.Universe
import Dodge.Debug import Dodge.Debug
import Dodge.DisplayInventory import Dodge.DisplayInventory
@@ -44,6 +41,7 @@ import Dodge.Machine.Update
import Dodge.ModificationEffect import Dodge.ModificationEffect
import Dodge.PressPlate import Dodge.PressPlate
import Dodge.Projectile.Update import Dodge.Projectile.Update
import Dodge.Prop.Moving
import Dodge.Prop.Update import Dodge.Prop.Update
import Dodge.RadarBlip import Dodge.RadarBlip
import Dodge.RadarSweep import Dodge.RadarSweep
@@ -54,6 +52,7 @@ import Dodge.Shockwave.Update
import Dodge.SmoothScroll import Dodge.SmoothScroll
import Dodge.SoundLogic import Dodge.SoundLogic
import Dodge.Spark import Dodge.Spark
import Dodge.SpawnAt
import Dodge.Terminal.Type import Dodge.Terminal.Type
import Dodge.TractorBeam.Update import Dodge.TractorBeam.Update
import Dodge.Update.Camera import Dodge.Update.Camera
@@ -64,6 +63,7 @@ import Dodge.Update.Scroll
import Dodge.Update.WallDamage import Dodge.Update.WallDamage
import Dodge.WallCreatureCollisions import Dodge.WallCreatureCollisions
import Dodge.WorldEffect import Dodge.WorldEffect
import Dodge.WorldEvent.Explosion
import Dodge.WorldEvent.ThingsHit import Dodge.WorldEvent.ThingsHit
import Dodge.Zoning.Cloud import Dodge.Zoning.Cloud
import Dodge.Zoning.Creature import Dodge.Zoning.Creature
@@ -397,11 +397,8 @@ updateMouseContextGame cfig u = case u ^. uvWorld . input . mouseContext of
tm <- w ^? cWorld . lWorld . terminals . ix tmid tm <- w ^? cWorld . lWorld . terminals . ix tmid
return $ return $
if isOverTerminalScreen cfig mpos if isOverTerminalScreen cfig mpos
then fromMaybe NoMouseContext $ do then OverTerminal tmid (tm ^. tmStatus)
let s = tm ^. tmStatus . tiText else OutsideTerminal
guard $ not (null s) -- && _tmStatus tm == TerminalTextInput
return $ OverTerminalReturn tmid
else OverTerminalEscape
getMenuMouseContext :: ScreenLayer -> Universe -> MouseContext getMenuMouseContext :: ScreenLayer -> Universe -> MouseContext
getMenuMouseContext screen u = case screen ^. scOptions of getMenuMouseContext screen u = case screen ^. scOptions of
@@ -501,20 +498,23 @@ displayTerminalLineString :: TerminalLineString -> (String, Color)
displayTerminalLineString (TerminalLineConst str col) = (str, col) displayTerminalLineString (TerminalLineConst str col) = (str, col)
tmUpdate :: Terminal -> World -> World tmUpdate :: Terminal -> World -> World
tmUpdate tm w = case w ^? cWorld . lWorld . terminals . ix (_tmID tm) . tmFutureLines . ix 0 of tmUpdate tm w = fromMaybe w $ do
Nothing -> w guard $ tm ^. tmStatus == TerminalLineRead
Just tl | _tlPause tl > 0 -> w & pointTermParams . tmFutureLines . ix 0 . tlPause -~ 1 tl <- w ^? cWorld . lWorld . terminals . ix (_tmID tm) . tmFutureLines . ix 0
Just (TLine _ tls g) -> return $ case tl of
_ | _tlPause tl > 0 -> w & pointTermParams . tmFutureLines . ix 0 . tlPause -~ 1
(TLine _ tls g) ->
w & pointTermParams w & pointTermParams
%~ ( (tmFutureLines %~ tail) %~ ( (tmFutureLines %~ tail)
. (tmDisplayedLines %~ (map displayTerminalLineString tls ++)) . (tmDisplayedLines %~ (map displayTerminalLineString tls ++))
) )
& doTmWdWd g tm & doTmWdWd g tm
-- Just (TerminalLineEffect _ eff) ->
-- w
-- & pointTermParams . tmFutureLines %~ tail
-- & doTmWdWd eff tm
where where
-- Just (TerminalLineEffect _ eff) ->
-- w
-- & pointTermParams . tmFutureLines %~ tail
-- & doTmWdWd eff tm
pointTermParams = cWorld . lWorld . terminals . ix (_tmID tm) pointTermParams = cWorld . lWorld . terminals . ix (_tmID tm)
setOldPos :: Creature -> Creature setOldPos :: Creature -> Creature
@@ -641,21 +641,23 @@ updatePulseLaser pz = case pz ^. pzTimer of
5 -> (Endo f, [pz & pzTimer -~ 1]) 5 -> (Endo f, [pz & pzTimer -~ 1])
_ -> (Endo g, [pz & pzTimer -~ 1]) _ -> (Endo g, [pz & pzTimer -~ 1])
where where
f w = dodam thHit f w =
dodam
thHit
w w
& cWorld . lWorld . flares <>~ drawLaser cyan (sp : ps) & cWorld . lWorld . flares <>~ drawLaser cyan (sp : ps)
where where
(thHit, ps) = reflectPulseLaserAlong phasev sp xp w (thHit, ps) = reflectPulseLaserAlong phasev sp xp w
dodam thit = case thit of dodam thit = case thit of
((p, OCreature cr):_) -> ((p, OCreature cr) : _) ->
cWorld . lWorld . creatures . ix (_crID cr) . crDamage cWorld . lWorld . creatures . ix (_crID cr) . crDamage
.:~ Lasering (pz ^. pzDamage) p (xp - sp) .:~ Lasering (pz ^. pzDamage) p (xp - sp)
((p, OWall wl):_) -> ((p, OWall wl) : _) ->
cWorld . lWorld . wallDamages . at (_wlID wl) . non mempty cWorld . lWorld . wallDamages . at (_wlID wl) . non mempty
.:~ Lasering (pz ^. pzDamage) p (xp - sp) .:~ Lasering (pz ^. pzDamage) p (xp - sp)
((_, OPulseBall pb):xs) -> dodam xs ((_, OPulseBall pb) : xs) ->
. dodam xs
(cWorld . lWorld . pulseBalls . ix (_pbID pb) . pbTimer .~ 0) . (cWorld . lWorld . pulseBalls . ix (_pbID pb) . pbTimer .~ 0)
. makeExplosionAt (_pbPos pb `v2z` 20) 0 . makeExplosionAt (_pbPos pb `v2z` 20) 0
_ -> id _ -> id
phasev = _pzPhaseV pz phasev = _pzPhaseV pz
@@ -796,7 +798,9 @@ ppEvents w = IM.foldl' (flip $ \pp -> doPressPlateEvent (_ppEvent pp) pp) w $ w
checkEndGame :: Universe -> Universe checkEndGame :: Universe -> Universe
checkEndGame uv = case w ^? timeFlow . respawnDelay of checkEndGame uv = case w ^? timeFlow . respawnDelay of
Just x | x < 0 -> uv -- & uvScreenLayers .~ [gameOverMenu uv] Just x
| x < 0 ->
uv -- & uvScreenLayers .~ [gameOverMenu uv]
& uvWorld . timeFlow .~ NormalTimeFlow & uvWorld . timeFlow .~ NormalTimeFlow
& uvWorld %~ respawn & uvWorld %~ respawn
Just _ -> uv & uvWorld . timeFlow . respawnDelay -~ 1 Just _ -> uv & uvWorld . timeFlow . respawnDelay -~ 1
+23 -4
View File
@@ -218,8 +218,9 @@ updateMouseClickInGame cfig w = case w ^. input . mouseContext of
&& isGroupSelectableSection (fst x) -> && isGroupSelectableSection (fst x) ->
w & input . mouseContext .~ OverInvDragSelect x (Just $ snd x) w & input . mouseContext .~ OverInvDragSelect x (Just $ snd x)
OverInvSelect x -> startDrag x cfig w OverInvSelect x -> startDrag x cfig w
OverTerminalReturn tmid -> terminalReturnEffect tmid w OverTerminal tmid (TerminalTextInput {}) -> terminalReturnEffect tmid w
OverTerminalEscape -> w & hud . hudElement . subInventory .~ NoSubInventory OverTerminal tmid (TerminalPressTo{}) -> continueTerminal tmid w
OutsideTerminal -> w & hud . hudElement . subInventory .~ NoSubInventory
OverCombSelect x -> OverCombSelect x ->
w & hud . hudElement . subInventory . ciSelection ?~ f x w & hud . hudElement . subInventory . ciSelection ?~ f x
& worldEventFlags . at CombineInventoryChange ?~ () & worldEventFlags . at CombineInventoryChange ?~ ()
@@ -381,7 +382,25 @@ updateFunctionKey uv ScancodeF4 _ = doDebugTest2 uv
updateFunctionKey uv _ _ = uv updateFunctionKey uv _ _ = uv
updateKeysInTerminal :: Int -> Universe -> Universe updateKeysInTerminal :: Int -> Universe -> Universe
updateKeysInTerminal tmid u = 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 %~ 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 u
& doTextInputOverUniverse & doTextInputOverUniverse
(uvWorld . cWorld . lWorld . terminals . ix tmid . tmStatus . tiText) (uvWorld . cWorld . lWorld . terminals . ix tmid . tmStatus . tiText)
@@ -533,7 +552,7 @@ getCloseObj w = getSelectedCloseObj w <|> firstcitem <|> firstcbut
tryCombine :: (Int, Int) -> World -> World tryCombine :: (Int, Int) -> World -> World
tryCombine (i, j) w = fromMaybe w $ do tryCombine (i, j) w = fromMaybe w $ do
sss <- w ^? hud . hudElement . subInventory . ciSections 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 p <- w ^? cWorld . lWorld . creatures . ix 0 . crPos
return $ return $
snd (createItemYou it (foldr (destroyInvItem 0) w (sort is))) snd (createItemYou it (foldr (destroyInvItem 0) w (sort is)))
+4 -4
View File
@@ -11,7 +11,7 @@ import qualified Data.Map.Strict as M
import Data.Maybe import Data.Maybe
import Dodge.Data.ScreenPos import Dodge.Data.ScreenPos
import Dodge.Data.Universe import Dodge.Data.Universe
import Dodge.Debug.Console import Dodge.Debug.Terminal
import Dodge.Menu.Option import Dodge.Menu.Option
import Dodge.SelectionList import Dodge.SelectionList
import Dodge.Update.Input.Text import Dodge.Update.Input.Text
@@ -34,7 +34,7 @@ doInputScreenInput s u =
checkEndStatus checkEndStatus
| ispressed ScancodeReturn = | ispressed ScancodeReturn =
(uvScreenLayers %~ tail) (uvScreenLayers %~ tail)
. applyConsoleString (words $ map toUpper s) . applyTerminalString (words $ map toUpper s)
. (uvWorld . worldEventFlags . at InventoryChange ?~ ()) . (uvWorld . worldEventFlags . at InventoryChange ?~ ())
| ispressed ScancodeEscape = uvScreenLayers %~ tail | ispressed ScancodeEscape = uvScreenLayers %~ tail
| otherwise = id | otherwise = id
@@ -63,11 +63,11 @@ mouseClickOptionsList u = fromMaybe u $ do
case u ^. uvWorld . input . mouseButtons of case u ^. uvWorld . input . mouseButtons of
mbs | mbs ^. at ButtonLeft == Just 0 -> do mbs | mbs ^. at ButtonLeft == Just 0 -> do
i <- u ^? uvWorld . input . mouseContext . mcoMenuClick i <- u ^? uvWorld . input . mouseContext . mcoMenuClick
f <- sl ^? ix i . siPayload . _1 f <- sl ^? ix i . siPayload . _Just . _1
return $ f u & uvSoundQueue .:~ click1S return $ f u & uvSoundQueue .:~ click1S
mbs | mbs ^. at ButtonRight == Just 0 -> do mbs | mbs ^. at ButtonRight == Just 0 -> do
i <- u ^? uvWorld . input . mouseContext . mcoMenuClick i <- u ^? uvWorld . input . mouseContext . mcoMenuClick
f <- sl ^? ix i . siPayload . _2 f <- sl ^? ix i . siPayload . _Just . _2
return $ f u & uvSoundQueue .:~ click1S return $ f u & uvSoundQueue .:~ click1S
_ -> Nothing _ -> Nothing
+39 -13
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module Dodge.WorldEffect ( module Dodge.WorldEffect (
doWdWd, doWdWd,
accessTerminal, accessTerminal,
@@ -6,6 +7,7 @@ module Dodge.WorldEffect (
lineOutputTerminal, lineOutputTerminal,
) where ) where
import Control.Monad
import Data.Foldable import Data.Foldable
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Maybe import Data.Maybe
@@ -51,21 +53,23 @@ doWdWd we = case we of
loc <- invIndents (cr ^. crInv) ^? ix invid . _2 loc <- invIndents (cr ^. crInv) ^? ix invid . _2
return $ heldEffectMuzzles loc cr w return $ heldEffectMuzzles loc cr w
accessTerminal :: Maybe Int -> World -> World accessTerminal :: Int -> World -> World
accessTerminal mtmid w = fromMaybe w $ do accessTerminal tid w = fromMaybe w $ do
tmid <- mtmid tm <- w ^? cWorld . lWorld . terminals . ix tid
guard (tm ^. tmStatus /= TerminalDeactivated)
return $ return $
w & hud . hudElement . subInventory .~ DisplayTerminal tmid w & hud . hudElement . subInventory .~ DisplayTerminal tid
& cWorld . lWorld . terminals . ix tmid %~ tryToBoot & cWorld . lWorld . terminals . ix tid %~ tryToBoot
where where
tryToBoot tm = case _tmStatus tm of tryToBoot tm = case _tmStatus tm of
TerminalTextInput{} -> tm TerminalTextInput{} -> tm
TerminalBusy -> tm TerminalLineRead -> tm
TerminalPressTo{} -> tm TerminalPressTo{} -> tm
TerminalOff -> TerminalOff ->
tm tm
& tmFutureLines .~ _tmBootLines tm & tmFutureLines .~ _tmBootLines tm
& tmStatus .~ TerminalBusy & tmStatus .~ TerminalLineRead
TerminalDeactivated -> error "managed to boot a deactivated terminal"
torqueCr :: Float -> Int -> World -> World torqueCr :: Float -> Int -> World -> World
torqueCr x cid w torqueCr x cid w
@@ -84,7 +88,8 @@ lineOutputTerminal tls =
} }
doDeathTriggers :: Terminal -> World -> World 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 where
xs = M.elems $ _tmToggles tm xs = M.elems $ _tmToggles tm
@@ -98,7 +103,8 @@ doTmWdWd tmwdwd = case tmwdwd of
return $ cWorld . lWorld . terminals . ix tid . tmDisplayedLines .~ [] return $ cWorld . lWorld . terminals . ix tid . tmDisplayedLines .~ []
TmGetDamageCoding st -> \tm w -> fromMaybe w $ do TmGetDamageCoding st -> \tm w -> fromMaybe w $ do
tid <- tm ^? tmID tid <- tm ^? tmID
return $ w & cWorld . lWorld . terminals . ix tid . tmFutureLines return $
w & cWorld . lWorld . terminals . ix tid . tmFutureLines
.~ decodeSensorType st w .~ decodeSensorType st w
TmGetSensor s -> \tm w -> fromMaybe w $ do TmGetSensor s -> \tm w -> fromMaybe w $ do
tid <- tm ^? tmID tid <- tm ^? tmID
@@ -106,9 +112,9 @@ doTmWdWd tmwdwd = case tmwdwd of
TmTmSetStatus x -> \tm -> fromMaybe id $ do TmTmSetStatus x -> \tm -> fromMaybe id $ do
tid <- tm ^? tmID tid <- tm ^? tmID
return $ cWorld . lWorld . terminals . ix tid . tmStatus .~ x return $ cWorld . lWorld . terminals . ix tid . tmStatus .~ x
-- TmDisplayCommands -> \tm -> fromMaybe id $ do -- TmDisplayCommands -> \tm -> fromMaybe id $ do
-- tid <- tm ^? tmID -- tid <- tm ^? tmID
-- return $ cWorld . lWorld . terminals . ix tid %~ tabComplete "" -- return $ cWorld . lWorld . terminals . ix tid %~ tabComplete ""
--return $ cWorld . lWorld . terminals . ix tid . tmFutureLines .~ --return $ cWorld . lWorld . terminals . ix tid . tmFutureLines .~
-- makeColorTermPara commandColor -- makeColorTermPara commandColor
-- (unwords (map fst (PTE.toList $ getCommands tm))) -- (unwords (map fst (PTE.toList $ getCommands tm)))
@@ -116,13 +122,33 @@ doTmWdWd tmwdwd = case tmwdwd of
-- tid <- tm ^? tmID -- tid <- tm ^? tmID
-- return $ cWorld . lWorld . terminals . ix tid . tmPartialCommand .~ x -- return $ cWorld . lWorld . terminals . ix tid . tmPartialCommand .~ x
TmWdId -> const id TmWdId -> const id
TmWdWdDisconnectTerminal -> disconnectTerminal TmWdWdPowerDownTerminal -> powerDownTerminal
TmWdWdDeactivateTerminal -> deactivateTerminal
TmWdWdTermSound sid -> \tm w -> TmWdWdTermSound sid -> \tm w ->
let tpos = fromMaybe 0 $ w ^? cWorld . lWorld . buttons . ix (_tmButtonID tm) . btPos let tpos = fromMaybe 0 $ w ^? cWorld . lWorld . buttons . ix (_tmButtonID tm) . btPos
in soundStart TerminalSound tpos sid Nothing w in soundStart TerminalSound tpos sid Nothing w
TmWdWdDoDeathTriggers -> doDeathTriggers TmWdWdDoDeathTriggers -> doDeathTriggers
TmWdWdfromWdWd f -> \_ -> doWdWd f 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 :: SensorType -> World -> [TerminalLine]
decodeSensorType st w = fromMaybe [] $ do decodeSensorType st w = fromMaybe [] $ do
x <- w ^? cWorld . cwGen . cwgParams . sensorCoding . ix st x <- w ^? cWorld . cwGen . cwgParams . sensorCoding . ix st
+291 -287
View File
File diff suppressed because it is too large Load Diff