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