From b38e88a82c3ec3f772fd8cd154b65b1d380f7f54 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 4 Dec 2022 19:32:57 -0800 Subject: [PATCH] Extract utils from Controller and View --- src/Swarm/DocGen.hs | 51 +++++----- src/Swarm/Game/Step.hs | 62 ++++++------ src/Swarm/TUI/Controller.hs | 20 +--- src/Swarm/TUI/Controller/ControllerUtils.hs | 24 +++++ src/Swarm/TUI/View.hs | 84 +--------------- src/Swarm/TUI/View/ViewUtils.hs | 103 ++++++++++++++++++++ swarm.cabal | 2 + 7 files changed, 189 insertions(+), 157 deletions(-) create mode 100644 src/Swarm/TUI/Controller/ControllerUtils.hs create mode 100644 src/Swarm/TUI/View/ViewUtils.hs diff --git a/src/Swarm/DocGen.hs b/src/Swarm/DocGen.hs index 47c651c58..a7ade608f 100644 --- a/src/Swarm/DocGen.hs +++ b/src/Swarm/DocGen.hs @@ -445,31 +445,32 @@ recipesToDot classic emap recipes = do Dot.attribute ("color", "forestgreen") mapM_ ((uncurry (Dot..->.) . (world,)) . getE) (toList testWorld2Entites) -- -------------------------------------------------------------------------- - let -- put a hidden node above and below entities and connect them by hidden edges - wrapBelowAbove :: Set Entity -> Dot (NodeId, NodeId) - wrapBelowAbove ns = do - b <- hiddenNode - t <- hiddenNode - let ns' = map nid $ toList ns - mapM_ (b .~>.) ns' - mapM_ (.~>. t) ns' - return (b, t) - -- put set of entities in nice - subLevel :: Int -> Set Entity -> Dot (NodeId, NodeId) - subLevel i ns = fmap snd . Dot.cluster $ do - Dot.attribute ("style", "filled") - Dot.attribute ("color", "khaki") - bt <- wrapBelowAbove ns - Dot.attribute ("rank", "sink") - -- the normal label for cluster would be cover by lines - _bigLabel <- - Dot.node - [ ("shape", "plain") - , ("label", "Bottom Label") - , ("fontsize", "20pt") - , ("label", "Level #" <> show i) - ] - return bt + let + -- put a hidden node above and below entities and connect them by hidden edges + wrapBelowAbove :: Set Entity -> Dot (NodeId, NodeId) + wrapBelowAbove ns = do + b <- hiddenNode + t <- hiddenNode + let ns' = map nid $ toList ns + mapM_ (b .~>.) ns' + mapM_ (.~>. t) ns' + return (b, t) + -- put set of entities in nice + subLevel :: Int -> Set Entity -> Dot (NodeId, NodeId) + subLevel i ns = fmap snd . Dot.cluster $ do + Dot.attribute ("style", "filled") + Dot.attribute ("color", "khaki") + bt <- wrapBelowAbove ns + Dot.attribute ("rank", "sink") + -- the normal label for cluster would be cover by lines + _bigLabel <- + Dot.node + [ ("shape", "plain") + , ("label", "Bottom Label") + , ("fontsize", "20pt") + , ("label", "Level #" <> show i) + ] + return bt -- -------------------------------------------------------------------------- -- order entities into clusters based on how "far" they are from -- what is available at the start - see 'recipeLevels'. diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index 6fe7c5a7d..af6c1a679 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -1558,13 +1558,14 @@ execConst c vs s k = do currentContext <- use $ robotContext . defReqs em <- use entityMap creative <- use creativeMode - let -- Note that _capCtx must be empty: at least at the - -- moment, definitions are only allowed at the top level, - -- so there can't be any inside the argument to build. - -- (Though perhaps there is an argument that this ought to be - -- relaxed specifically in the cases of 'Build' and 'Reprogram'.) - -- See #349 - (R.Requirements (S.toList -> caps) (S.toList -> devNames) reqInvNames, _capCtx) = R.requirements currentContext cmd + let + -- Note that _capCtx must be empty: at least at the + -- moment, definitions are only allowed at the top level, + -- so there can't be any inside the argument to build. + -- (Though perhaps there is an argument that this ought to be + -- relaxed specifically in the cases of 'Build' and 'Reprogram'.) + -- See #349 + (R.Requirements (S.toList -> caps) (S.toList -> devNames) reqInvNames, _capCtx) = R.requirements currentContext cmd -- Check that all required device names exist, and fail with -- an exception if not @@ -1580,35 +1581,36 @@ execConst c vs s k = do ) let reqInv = E.fromElems reqElems - let -- List of possible devices per requirement. Devices for - -- required capabilities come first, then singleton devices - -- that are required directly. This order is important since - -- later we zip required capabilities with this list to figure - -- out which capabilities are missing. - capDevices = map (`deviceForCap` em) caps ++ map (: []) devs + let + -- List of possible devices per requirement. Devices for + -- required capabilities come first, then singleton devices + -- that are required directly. This order is important since + -- later we zip required capabilities with this list to figure + -- out which capabilities are missing. + capDevices = map (`deviceForCap` em) caps ++ map (: []) devs - -- A device is OK if it is available in the inventory of the - -- parent robot, or already installed in the child robot. - deviceOK d = parentInventory `E.contains` d || childDevices `E.contains` d + -- A device is OK if it is available in the inventory of the + -- parent robot, or already installed in the child robot. + deviceOK d = parentInventory `E.contains` d || childDevices `E.contains` d - -- take a pair of device sets providing capabilities that is - -- split into (AVAIL,MISSING) and if there are some available - -- ignore missing because we only need them for error message - ignoreOK ([], miss) = ([], miss) - ignoreOK (ds, _miss) = (ds, []) + -- take a pair of device sets providing capabilities that is + -- split into (AVAIL,MISSING) and if there are some available + -- ignore missing because we only need them for error message + ignoreOK ([], miss) = ([], miss) + ignoreOK (ds, _miss) = (ds, []) - (deviceSets, missingDeviceSets) = - Lens.over both (nubOrd . map S.fromList) . unzip $ - map (ignoreOK . L.partition deviceOK) capDevices + (deviceSets, missingDeviceSets) = + Lens.over both (nubOrd . map S.fromList) . unzip $ + map (ignoreOK . L.partition deviceOK) capDevices - formatDevices = T.intercalate " or " . map (^. entityName) . S.toList - -- capabilities not provided by any device in inventory - missingCaps = S.fromList . map fst . filter (null . snd) $ zip caps deviceSets + formatDevices = T.intercalate " or " . map (^. entityName) . S.toList + -- capabilities not provided by any device in inventory + missingCaps = S.fromList . map fst . filter (null . snd) $ zip caps deviceSets - alreadyInstalled = S.fromList . map snd . E.elems $ childDevices + alreadyInstalled = S.fromList . map snd . E.elems $ childDevices - -- Figure out what is missing from the required inventory - missingChildInv = reqInv `E.difference` childInventory + -- Figure out what is missing from the required inventory + missingChildInv = reqInv `E.difference` childInventory if creative then -- In creative mode, just return ALL the devices diff --git a/src/Swarm/TUI/Controller.hs b/src/Swarm/TUI/Controller.hs index 509a34ebc..be57a70f1 100644 --- a/src/Swarm/TUI/Controller.hs +++ b/src/Swarm/TUI/Controller.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -- | -- Module : Swarm.TUI.Controller @@ -81,6 +80,7 @@ import Swarm.Language.Requirement qualified as R import Swarm.Language.Syntax import Swarm.Language.Typed (Typed (..)) import Swarm.Language.Types +import Swarm.TUI.Controller.ControllerUtils import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder) import Swarm.TUI.List import Swarm.TUI.Model @@ -90,24 +90,6 @@ import Swarm.Version (NewReleaseFailure (..)) import System.Clock import Witch (into) --- | Pattern synonyms to simplify brick event handler -pattern Key :: V.Key -> BrickEvent n e -pattern Key k = VtyEvent (V.EvKey k []) - -pattern CharKey, ControlChar, MetaChar :: Char -> BrickEvent n e -pattern CharKey c = VtyEvent (V.EvKey (V.KChar c) []) -pattern ControlChar c = VtyEvent (V.EvKey (V.KChar c) [V.MCtrl]) -pattern MetaChar c = VtyEvent (V.EvKey (V.KChar c) [V.MMeta]) - -pattern ShiftKey :: V.Key -> BrickEvent n e -pattern ShiftKey k = VtyEvent (V.EvKey k [V.MShift]) - -pattern EscapeKey :: BrickEvent n e -pattern EscapeKey = VtyEvent (V.EvKey V.KEsc []) - -pattern FKey :: Int -> BrickEvent n e -pattern FKey c = VtyEvent (V.EvKey (V.KFun c) []) - -- | The top-level event handler for the TUI. handleEvent :: BrickEvent Name AppEvent -> EventM Name AppState () handleEvent = \case diff --git a/src/Swarm/TUI/Controller/ControllerUtils.hs b/src/Swarm/TUI/Controller/ControllerUtils.hs new file mode 100644 index 000000000..4df80592a --- /dev/null +++ b/src/Swarm/TUI/Controller/ControllerUtils.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Swarm.TUI.Controller.ControllerUtils where + +import Brick hiding (Direction) +import Graphics.Vty qualified as V + +-- | Pattern synonyms to simplify brick event handler +pattern Key :: V.Key -> BrickEvent n e +pattern Key k = VtyEvent (V.EvKey k []) + +pattern CharKey, ControlChar, MetaChar :: Char -> BrickEvent n e +pattern CharKey c = VtyEvent (V.EvKey (V.KChar c) []) +pattern ControlChar c = VtyEvent (V.EvKey (V.KChar c) [V.MCtrl]) +pattern MetaChar c = VtyEvent (V.EvKey (V.KChar c) [V.MMeta]) + +pattern ShiftKey :: V.Key -> BrickEvent n e +pattern ShiftKey k = VtyEvent (V.EvKey k [V.MShift]) + +pattern EscapeKey :: BrickEvent n e +pattern EscapeKey = VtyEvent (V.EvKey V.KEsc []) + +pattern FKey :: Int -> BrickEvent n e +pattern FKey c = VtyEvent (V.EvKey (V.KFun c) []) diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs index 6e8b2d404..5ae415cad 100644 --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -91,12 +91,12 @@ import Swarm.Game.World qualified as W import Swarm.Language.Pretty (prettyText) import Swarm.Language.Syntax import Swarm.Language.Typecheck (inferConst) -import Swarm.Language.Types (Polytype) import Swarm.TUI.Attr import Swarm.TUI.Border import Swarm.TUI.Inventory.Sorting (renderSortMethod) import Swarm.TUI.Model import Swarm.TUI.Panel +import Swarm.TUI.View.ViewUtils import Swarm.Util import Swarm.Version (NewReleaseFailure (..)) import System.Clock (TimeSpec (..)) @@ -390,10 +390,6 @@ drawTime t showTicks = maybeDrawTime :: Integer -> Bool -> GameState -> Maybe (Widget n) maybeDrawTime t showTicks gs = guard (clockInstalled gs) $> drawTime t showTicks --- | Render the type of the current REPL input to be shown to the user. -drawType :: Polytype -> Widget Name -drawType = withAttr infoAttr . padLeftRight 1 . txt . prettyText - -- | Draw info about the current number of ticks per second. drawTPS :: AppState -> Widget Name drawTPS s = hBox (tpsInfo : rateInfo) @@ -426,10 +422,6 @@ chooseCursor s locs = case s ^. uiState . uiModal of Nothing -> showFirstCursor s locs Just _ -> Nothing --- | Width cap for modal and error message windows -maxModalWindowWidth :: Int -maxModalWindowWidth = 500 - -- | Render the error dialog window with a given error message renderErrorDialog :: Text -> Widget Name renderErrorDialog err = renderDialog (dialog (Just "Error") Nothing (maxModalWindowWidth `min` requiredWidth)) errContent @@ -473,77 +465,6 @@ drawModal s = \case GoalModal g -> padLeftRight 1 (displayParagraphs g) KeepPlayingModal -> padLeftRight 1 (displayParagraphs ["Have fun! Hit Ctrl-Q whenever you're ready to proceed to the next challenge or return to the menu."]) -quitMsg :: Menu -> Text -quitMsg m = "Are you sure you want to " <> quitAction <> "? All progress on this scenario will be lost!" - where - quitAction = case m of - NoMenu -> "quit" - _ -> "return to the menu" - --- | Generate a fresh modal window of the requested type. -generateModal :: AppState -> ModalType -> Modal -generateModal s mt = Modal mt (dialog (Just title) buttons (maxModalWindowWidth `min` requiredWidth)) - where - currentScenario = s ^. uiState . scenarioRef - currentSeed = s ^. gameState . seed - haltingMessage = case s ^. uiState . uiMenu of - NoMenu -> Just "Quit" - _ -> Nothing - descriptionWidth = 100 - helpWidth = 80 - (title, buttons, requiredWidth) = - case mt of - HelpModal -> (" Help ", Nothing, helpWidth) - RobotsModal -> ("Robots", Nothing, descriptionWidth) - RecipesModal -> ("Available Recipes", Nothing, descriptionWidth) - CommandsModal -> ("Available Commands", Nothing, descriptionWidth) - MessagesModal -> ("Messages", Nothing, descriptionWidth) - WinModal -> - let nextMsg = "Next challenge!" - stopMsg = fromMaybe "Return to the menu" haltingMessage - continueMsg = "Keep playing" - in ( "" - , Just - ( 0 - , [ (nextMsg, NextButton scene) - | Just scene <- [nextScenario (s ^. uiState . uiMenu)] - ] - ++ [ (stopMsg, QuitButton) - , (continueMsg, KeepPlayingButton) - ] - ) - , sum (map length [nextMsg, stopMsg, continueMsg]) + 32 - ) - DescriptionModal e -> (descriptionTitle e, Nothing, descriptionWidth) - QuitModal -> - let stopMsg = fromMaybe ("Quit to" ++ maybe "" (" " ++) (into @String <$> curMenuName s) ++ " menu") haltingMessage - maybeStartOver = sequenceA ("Start over", StartOverButton currentSeed <$> currentScenario) - in ( "" - , Just - ( 0 - , catMaybes - [ Just ("Keep playing", CancelButton) - , maybeStartOver - , Just (stopMsg, QuitButton) - ] - ) - , T.length (quitMsg (s ^. uiState . uiMenu)) + 4 - ) - GoalModal _ -> - let goalModalTitle = case currentScenario of - Nothing -> "Goal" - Just (scenario, _) -> scenario ^. scenarioName - in (" " <> T.unpack goalModalTitle <> " ", Nothing, 80) - KeepPlayingModal -> ("", Just (0, [("OK", CancelButton)]), 80) - --- | Get the name of the current New Game menu. -curMenuName :: AppState -> Maybe Text -curMenuName s = case s ^. uiState . uiMenu of - NewGameMenu (_ :| (parentMenu : _)) -> - Just (parentMenu ^. BL.listSelectedElementL . to scenarioItemName) - NewGameMenu _ -> Just "Scenarios" - _ -> Nothing - robotsListWidget :: AppState -> Widget Name robotsListWidget s = hCenter table where @@ -713,9 +634,6 @@ drawConst c = hBox [padLeft (Pad $ 13 - T.length constName) (txt constName), txt constName = syntax . constInfo $ c constSig = " : " <> prettyText (inferConst c) -descriptionTitle :: Entity -> String -descriptionTitle e = " " ++ from @Text (e ^. entityName) ++ " " - -- | Generate a pop-up widget to display the description of an entity. descriptionWidget :: AppState -> Entity -> Widget Name descriptionWidget s e = padLeftRight 1 (explainEntry s e) diff --git a/src/Swarm/TUI/View/ViewUtils.hs b/src/Swarm/TUI/View/ViewUtils.hs new file mode 100644 index 000000000..01a2070f2 --- /dev/null +++ b/src/Swarm/TUI/View/ViewUtils.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Swarm.TUI.View.ViewUtils where + +import Brick hiding (Direction) +import Brick.Widgets.Dialog +import Brick.Widgets.List qualified as BL +import Control.Lens hiding (Const, from) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Swarm.Game.Entity as E +import Swarm.Game.Scenario (scenarioName) +import Swarm.Game.ScenarioInfo (scenarioItemName) +import Swarm.Game.State +import Swarm.Language.Pretty (prettyText) +import Swarm.Language.Types (Polytype) +import Swarm.TUI.Attr +import Swarm.TUI.Model +import Witch (from, into) + +-- | Generate a fresh modal window of the requested type. +generateModal :: AppState -> ModalType -> Modal +generateModal s mt = Modal mt (dialog (Just title) buttons (maxModalWindowWidth `min` requiredWidth)) + where + currentScenario = s ^. uiState . scenarioRef + currentSeed = s ^. gameState . seed + haltingMessage = case s ^. uiState . uiMenu of + NoMenu -> Just "Quit" + _ -> Nothing + descriptionWidth = 100 + helpWidth = 80 + (title, buttons, requiredWidth) = + case mt of + HelpModal -> (" Help ", Nothing, helpWidth) + RobotsModal -> ("Robots", Nothing, descriptionWidth) + RecipesModal -> ("Available Recipes", Nothing, descriptionWidth) + CommandsModal -> ("Available Commands", Nothing, descriptionWidth) + MessagesModal -> ("Messages", Nothing, descriptionWidth) + WinModal -> + let nextMsg = "Next challenge!" + stopMsg = fromMaybe "Return to the menu" haltingMessage + continueMsg = "Keep playing" + in ( "" + , Just + ( 0 + , [ (nextMsg, NextButton scene) + | Just scene <- [nextScenario (s ^. uiState . uiMenu)] + ] + ++ [ (stopMsg, QuitButton) + , (continueMsg, KeepPlayingButton) + ] + ) + , sum (map length [nextMsg, stopMsg, continueMsg]) + 32 + ) + DescriptionModal e -> (descriptionTitle e, Nothing, descriptionWidth) + QuitModal -> + let stopMsg = fromMaybe ("Quit to" ++ maybe "" (" " ++) (into @String <$> curMenuName s) ++ " menu") haltingMessage + maybeStartOver = sequenceA ("Start over", StartOverButton currentSeed <$> currentScenario) + in ( "" + , Just + ( 0 + , catMaybes + [ Just ("Keep playing", CancelButton) + , maybeStartOver + , Just (stopMsg, QuitButton) + ] + ) + , T.length (quitMsg (s ^. uiState . uiMenu)) + 4 + ) + GoalModal _ -> + let goalModalTitle = case currentScenario of + Nothing -> "Goal" + Just (scenario, _) -> scenario ^. scenarioName + in (" " <> T.unpack goalModalTitle <> " ", Nothing, 80) + KeepPlayingModal -> ("", Just (0, [("OK", CancelButton)]), 80) + +-- | Render the type of the current REPL input to be shown to the user. +drawType :: Polytype -> Widget Name +drawType = withAttr infoAttr . padLeftRight 1 . txt . prettyText + +descriptionTitle :: Entity -> String +descriptionTitle e = " " ++ from @Text (e ^. entityName) ++ " " + +-- | Width cap for modal and error message windows +maxModalWindowWidth :: Int +maxModalWindowWidth = 500 + +-- | Get the name of the current New Game menu. +curMenuName :: AppState -> Maybe Text +curMenuName s = case s ^. uiState . uiMenu of + NewGameMenu (_ :| (parentMenu : _)) -> + Just (parentMenu ^. BL.listSelectedElementL . to scenarioItemName) + NewGameMenu _ -> Just "Scenarios" + _ -> Nothing + +quitMsg :: Menu -> Text +quitMsg m = "Are you sure you want to " <> quitAction <> "? All progress on this scenario will be lost!" + where + quitAction = case m of + NoMenu -> "quit" + _ -> "return to the menu" diff --git a/swarm.cabal b/swarm.cabal index 9a5695a52..337f0cea8 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -115,7 +115,9 @@ library Swarm.TUI.Panel Swarm.TUI.Model Swarm.TUI.View + Swarm.TUI.View.ViewUtils Swarm.TUI.Controller + Swarm.TUI.Controller.ControllerUtils Swarm.TUI.Inventory.Sorting Swarm.App Swarm.Version