From 989ccbd64204bdb6f09cad2b3a8d28f49ea07a9f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 8 Feb 2025 15:32:21 +0100 Subject: [PATCH 1/2] Fix completed scenario to show green status --- .../Swarm/Game/Scenario/Scoring/Best.hs | 4 +-- .../Game/Scenario/Scoring/GenericMetrics.hs | 26 ++++++++++++++++--- src/swarm-tui/Swarm/TUI/View.hs | 7 +++-- 3 files changed, 29 insertions(+), 8 deletions(-) diff --git a/src/swarm-engine/Swarm/Game/Scenario/Scoring/Best.hs b/src/swarm-engine/Swarm/Game/Scenario/Scoring/Best.hs index 91c8d8dee..4aa03527a 100644 --- a/src/swarm-engine/Swarm/Game/Scenario/Scoring/Best.hs +++ b/src/swarm-engine/Swarm/Game/Scenario/Scoring/Best.hs @@ -144,7 +144,7 @@ getBestGroups :: getBestGroups = rearrangeTuples . M.toList . bestToMap where - groupByStartTime = NE.groupAllWith $ view scenarioStarted . getMetric . snd + groupByStartTime = NE.groupAllWith $ view scenarioStarted . view metricData . snd rearrangeTuples = map (snd . NE.head &&& NE.map fst) . groupByStartTime bestToMap :: BestRecords -> Map BestByCriteria ProgressMetric @@ -161,4 +161,4 @@ getBestGroups = ] ensurePresent x = - (getMetric x ^. scenarioAttemptMetrics . scenarioCodeMetrics) >> Just x + (x ^. metricData . scenarioAttemptMetrics . scenarioCodeMetrics) >> Just x diff --git a/src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs b/src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs index b9f0a42d0..4c7bc4c9a 100644 --- a/src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs +++ b/src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs @@ -1,15 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} + -- | -- SPDX-License-Identifier: BSD-3-Clause -- -- Data types and functions applicable across different -- scoring methods. -module Swarm.Game.Scenario.Scoring.GenericMetrics where +module Swarm.Game.Scenario.Scoring.GenericMetrics ( + Progress (..), + Metric (Metric), + metricProgress, + metricData, + chooseBetter, +) where import Data.Aeson import Data.Ord (Down (Down)) import GHC.Generics (Generic) import Swarm.Util (maxOn) import Swarm.Util.JSON (optionsUntagged) +import Control.Lens +import Swarm.Util.Lens (makeLensesNoSigs) -- | This is a subset of the "ScenarioStatus" type -- that excludes the "NotStarted" case. @@ -24,11 +34,19 @@ instance FromJSON Progress where instance ToJSON Progress where toJSON = genericToJSON optionsUntagged -data Metric a = Metric Progress a +data Metric a = Metric + { _metricProgress :: Progress + , _metricData :: a + } deriving (Eq, Ord, Show, Read, Generic, FromJSON, ToJSON) -getMetric :: Metric a -> a -getMetric (Metric _ x) = x +makeLensesNoSigs ''Metric + +-- | The player progress, so that we know if this game was completed. +metricProgress :: Lens' (Metric a) Progress + +-- | Metric data, for example start and end time. +metricData :: Lens' (Metric a) a -- | This encodes the notion of "more play is better" -- for incomplete games (rationale: more play = more fun), diff --git a/src/swarm-tui/Swarm/TUI/View.hs b/src/swarm-tui/Swarm/TUI/View.hs index 64f2a179e..f216d173c 100644 --- a/src/swarm-tui/Swarm/TUI/View.hs +++ b/src/swarm-tui/Swarm/TUI/View.hs @@ -231,10 +231,13 @@ drawNewGameMenuUI (l :| ls) launchOptions = case displayedFor of drawScenarioItem (SICollection nm _) = padRight (Pad 1) (withAttr boldAttr $ txt " > ") <+> txt nm drawStatusInfo s si = case si ^. scenarioStatus of NotStarted -> txt " ○ " - Played _initialScript (Metric Attempted _) _ -> case s ^. scenarioOperation . scenarioObjectives of + Played _script _latestMetric best | isCompleted best -> withAttr greenAttr $ txt " ● " + Played {} -> case s ^. scenarioOperation . scenarioObjectives of [] -> withAttr cyanAttr $ txt " ◉ " _ -> withAttr yellowAttr $ txt " ◎ " - Played _initialScript (Metric Completed _) _ -> withAttr greenAttr $ txt " ● " + + isCompleted :: BestRecords -> Bool + isCompleted best = best ^. scenarioBestByTime . metricProgress == Completed describeStatus :: ScenarioStatus -> Widget n describeStatus = \case From c5b4506ac04cac9f2a01fa8fd8ae3bcdc09951f8 Mon Sep 17 00:00:00 2001 From: "github-actions[bot]" <41898282+github-actions[bot]@users.noreply.github.com> Date: Sat, 8 Feb 2025 15:36:31 +0100 Subject: [PATCH 2/2] Restyled by fourmolu (#2313) Co-authored-by: Restyled.io --- src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs | 2 +- src/swarm-tui/Swarm/TUI/View.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs b/src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs index 4c7bc4c9a..98328b768 100644 --- a/src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs +++ b/src/swarm-engine/Swarm/Game/Scenario/Scoring/GenericMetrics.hs @@ -13,12 +13,12 @@ module Swarm.Game.Scenario.Scoring.GenericMetrics ( chooseBetter, ) where +import Control.Lens import Data.Aeson import Data.Ord (Down (Down)) import GHC.Generics (Generic) import Swarm.Util (maxOn) import Swarm.Util.JSON (optionsUntagged) -import Control.Lens import Swarm.Util.Lens (makeLensesNoSigs) -- | This is a subset of the "ScenarioStatus" type diff --git a/src/swarm-tui/Swarm/TUI/View.hs b/src/swarm-tui/Swarm/TUI/View.hs index f216d173c..ec8028701 100644 --- a/src/swarm-tui/Swarm/TUI/View.hs +++ b/src/swarm-tui/Swarm/TUI/View.hs @@ -235,7 +235,7 @@ drawNewGameMenuUI (l :| ls) launchOptions = case displayedFor of Played {} -> case s ^. scenarioOperation . scenarioObjectives of [] -> withAttr cyanAttr $ txt " ◉ " _ -> withAttr yellowAttr $ txt " ◎ " - + isCompleted :: BestRecords -> Bool isCompleted best = best ^. scenarioBestByTime . metricProgress == Completed