Record best code size

towards #866

src/Swarm/Game/Scenario/Scoring/CodeSize.hs

@@ -0,0 +1,30 @@
+module Swarm.Game.Scenario.Scoring.CodeSize where
+
+import Control.Monad (guard)
+import Data.Aeson
+import GHC.Generics (Generic)
+import Swarm.Language.Module
+import Swarm.Language.Pipeline
+import Swarm.Language.Syntax
+
+data CodeSizeDeterminators = CodeSizeDeterminators
+  { initialCode :: Maybe ProcessedTerm
+  , hasUsedREPL :: Bool
+  }
+  deriving (Show)
+
+data ScenarioCodeMetrics = ScenarioCodeMetrics
+  { sourceTextLength :: Int
+  , astSize :: Int
+  }
+  deriving (Eq, Ord, Show, Read, Generic, ToJSON, FromJSON)
+
+charCount :: SrcLoc -> Int
+charCount NoLoc = 0
+charCount (SrcLoc start end) = end - start
+
+codeSizeFromDeterminator :: CodeSizeDeterminators -> Maybe ScenarioCodeMetrics
+codeSizeFromDeterminator (CodeSizeDeterminators maybeInitialCode usedRepl) = do
+  guard $ not usedRepl
+  ProcessedTerm (Module s@(Syntax' srcLoc _ _) _) _ _ <- maybeInitialCode
+  return $ ScenarioCodeMetrics (charCount srcLoc) (measureAstSize s)

src/Swarm/Game/ScenarioInfo.hs

@@ -24,6 +24,8 @@ module Swarm.Game.ScenarioInfo (
   scenarioStatus,
   scenarioBestTime,
   scenarioBestTicks,
+  scenarioBestCodeSize,
+  CodeSizeDeterminators (CodeSizeDeterminators),
   updateScenarioInfoOnQuit,
   ScenarioInfoPair,
 
@@ -69,6 +71,7 @@ import Data.Yaml as Y
 import GHC.Generics (Generic)
 import Swarm.Game.Entity
 import Swarm.Game.Scenario
+import Swarm.Game.Scenario.Scoring.CodeSize
 import Swarm.Util (dataNotFound, getDataDirSafe, getSwarmSavePath)
 import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, listDirectory)
 import System.FilePath (pathSeparator, splitDirectories, takeBaseName, takeExtensions, (-<.>), (</>))
@@ -107,6 +110,9 @@ data ScenarioStatus
       }
   deriving (Eq, Ord, Show, Read, Generic)
 
+-- TODO Define a semigroup instance that encodes the
+-- "best" precedence logic, factoring in the completion state.
+
 instance FromJSON ScenarioStatus where
   parseJSON = genericParseJSON scenarioOptions
 
@@ -121,6 +127,7 @@ data ScenarioInfo = ScenarioInfo
   , _scenarioStatus :: ScenarioStatus
   , _scenarioBestTime :: ScenarioStatus
   , _scenarioBestTicks :: ScenarioStatus
+  , _scenarioBestCodeSize :: Maybe ScenarioCodeMetrics
   }
   deriving (Eq, Ord, Show, Read, Generic)
 
@@ -153,22 +160,37 @@ scenarioBestTime :: Lens' ScenarioInfo ScenarioStatus
 -- | The best status of the scenario, measured in game ticks.
 scenarioBestTicks :: Lens' ScenarioInfo ScenarioStatus
 
+-- | The best code size of the scenario, measured both in character count and AST size.
+scenarioBestCodeSize :: Lens' ScenarioInfo (Maybe ScenarioCodeMetrics)
+
 -- | Update the current @ScenarioInfo@ record when quitting a game.
 --
 -- Note that when comparing "best" times, shorter is not always better!
 -- As long as the scenario is not completed (e.g. some do not have win condition)
 -- we consider having fun _longer_ to be better.
-updateScenarioInfoOnQuit :: ZonedTime -> Integer -> Bool -> ScenarioInfo -> ScenarioInfo
-updateScenarioInfoOnQuit z ticks completed (ScenarioInfo p s bTime bTicks) = case s of
-  InProgress start _ _ ->
-    let el = (diffUTCTime `on` zonedTimeToUTC) z start
-        cur = (if completed then Complete else InProgress) start el ticks
-        best f b = case b of
-          Complete {} | not completed || f b <= f cur -> b -- keep faster completed
-          InProgress {} | not completed && f b > f cur -> b -- keep longer progress (fun!)
-          _ -> cur -- otherwise update with current
-     in ScenarioInfo p cur (best _scenarioElapsed bTime) (best _scenarioElapsedTicks bTicks)
-  _ -> error "Logical error: trying to quit scenario which is not in progress!"
+updateScenarioInfoOnQuit ::
+  CodeSizeDeterminators ->
+  ZonedTime ->
+  Integer ->
+  Bool ->
+  ScenarioInfo ->
+  ScenarioInfo
+updateScenarioInfoOnQuit
+  csd
+  z
+  ticks
+  completed
+  (ScenarioInfo p s bTime bTicks _prevCodeSize) = case s of
+    InProgress start _ _ ->
+      let el = (diffUTCTime `on` zonedTimeToUTC) z start
+          cur = (if completed then Complete else InProgress) start el ticks
+          -- TODO Offload this logic to a Semigroup instance of ScenarioStatus
+          best f b = case b of
+            Complete {} | not completed || f b <= f cur -> b -- keep faster completed
+            InProgress {} | not completed && f b > f cur -> b -- keep longer progress (fun!)
+            _ -> cur -- otherwise update with current
+       in ScenarioInfo p cur (best _scenarioElapsed bTime) (best _scenarioElapsedTicks bTicks) (codeSizeFromDeterminator csd)
+    _ -> error "Logical error: trying to quit scenario which is not in progress!"
 
 -- ----------------------------------------------------------------------------
 -- Scenario Item
@@ -320,7 +342,7 @@ loadScenarioInfo p = do
   hasInfo <- sendIO $ doesFileExist infoPath
   if not hasInfo
     then do
-      return $ ScenarioInfo path NotStarted NotStarted NotStarted
+      return $ ScenarioInfo path NotStarted NotStarted NotStarted Nothing
     else
       sendIO (decodeFileEither infoPath)
         >>= either (throwError . pack . prettyPrintParseException) return

src/Swarm/Game/State.hs

@@ -51,6 +51,7 @@ module Swarm.Game.State (
   gensym,
   seed,
   randGen,
+  initiallyRunCode,
   adjList,
   nameList,
   entityMap,
@@ -333,6 +334,7 @@ data GameState = GameState
   , _gensym :: Int
   , _seed :: Seed
   , _randGen :: StdGen
+  , _initiallyRunCode :: Maybe ProcessedTerm
   , _adjList :: Array Int Text
   , _nameList :: Array Int Text
   , _entityMap :: EntityMap
@@ -389,7 +391,7 @@ winSolution :: Lens' GameState (Maybe ProcessedTerm)
 -- | Map of in-game achievements that were attained
 gameAchievements :: Lens' GameState (Map GameplayAchievement Attainment)
 
--- | A queue of global announcments.
+-- | A queue of global announcements.
 -- Note that this is distinct from the "messageQueue",
 -- which is for messages emitted by robots.
 --
@@ -468,6 +470,10 @@ seed :: Lens' GameState Seed
 -- | Pseudorandom generator initialized at start.
 randGen :: Lens' GameState StdGen
 
+-- | Code that is run upon scenario start, before any
+-- REPL interaction.
+initiallyRunCode :: Lens' GameState (Maybe ProcessedTerm)
+
 -- | Read-only list of words, for use in building random robot names.
 adjList :: Getter GameState (Array Int Text)
 adjList = to _adjList
@@ -785,6 +791,7 @@ initGameState = do
       , _gensym = 0
       , _seed = 0
       , _randGen = mkStdGen 0
+      , _initiallyRunCode = Nothing
       , _adjList = listArray (0, length adjs - 1) adjs
       , _nameList = listArray (0, length names - 1) names
       , _entityMap = entities
@@ -808,7 +815,12 @@ initGameState = do
       }
 
 -- | Set a given scenario as the currently loaded scenario in the game state.
-scenarioToGameState :: Scenario -> Maybe Seed -> Maybe CodeToRun -> GameState -> IO GameState
+scenarioToGameState ::
+  Scenario ->
+  Maybe Seed ->
+  Maybe CodeToRun ->
+  GameState ->
+  IO GameState
 scenarioToGameState scenario userSeed toRun g = do
   -- Decide on a seed.  In order of preference, we will use:
   --   1. seed value provided by the user
@@ -837,6 +849,7 @@ scenarioToGameState scenario userSeed toRun g = do
       , _gensym = initGensym
       , _seed = theSeed
       , _randGen = mkStdGen theSeed
+      , _initiallyRunCode = initialCodeToRun
       , _entityMap = em
       , _recipesOut = addRecipesWith outRecipeMap recipesOut
       , _recipesIn = addRecipesWith inRecipeMap recipesIn
@@ -892,6 +905,8 @@ scenarioToGameState scenario userSeed toRun g = do
   --        prefer the one closest to the upper-left of the screen, with higher rows given precedence over columns.
   robotsByBasePrecedence = locatedRobots ++ map snd (sortOn fst genRobots)
 
+  initialCodeToRun = getCodeToRun <$> toRun
+
   robotList =
     zipWith instantiateRobot [baseID ..] robotsByBasePrecedence
       -- If the  --run flag was used, use it to replace the CESK machine of the
@@ -900,7 +915,7 @@ scenarioToGameState scenario userSeed toRun g = do
       -- would have run (i.e. any program specified in the program: field
       -- of the scenario description).
       & ix baseID . machine
-        %~ case getCodeToRun <$> toRun of
+        %~ case initialCodeToRun of
           Nothing -> id
           Just pt -> const $ initMachine pt Ctx.empty emptyStore
       -- If we are in creative mode, give base all the things

src/Swarm/Language/Syntax.hs

@@ -88,10 +88,12 @@ module Swarm.Language.Syntax (
   freeVarsV,
   mapFreeS,
   locVarToSyntax',
+  asTree,
+  measureAstSize,
 ) where
 
 import Control.Arrow (Arrow ((&&&)))
-import Control.Lens (Plated (..), Traversal', makeLenses, (%~), (^.))
+import Control.Lens (Plated (..), Traversal', makeLenses, (%~), (^.), para, universe)
 import Data.Aeson.Types
 import Data.Char qualified as C (toLower)
 import Data.Data (Data)
@@ -103,8 +105,9 @@ import Data.List.NonEmpty qualified as NonEmpty
 import Data.Map qualified as M
 import Data.Set qualified as S
 import Data.String (IsString (fromString))
-import Data.Text hiding (filter, map)
+import Data.Text hiding (filter, map, length)
 import Data.Text qualified as T
+import Data.Tree
 import GHC.Generics (Generic)
 import Linear
 import Swarm.Language.Types
@@ -1111,3 +1114,13 @@ freeVarsV = freeVarsT . (\f -> \case TVar x -> TVar <$> f x; t -> pure t)
 -- | Apply a function to all free occurrences of a particular variable.
 mapFreeS :: Var -> (Syntax' ty -> Syntax' ty) -> Syntax' ty -> Syntax' ty
 mapFreeS x f = freeVarsS %~ (\t -> case t ^. sTerm of TVar y | y == x -> f t; _ -> t)
+
+-- | Transform the AST into a Tree datatype.
+-- Useful for pretty-printing (e.g. via "Data.Tree.drawTree").
+asTree :: Data a => Syntax' a -> Tree (Syntax' a)
+asTree = para Node
+
+-- | Each constructor is a assigned a value of 1, plus
+-- any recursive syntax it entails.
+measureAstSize :: Data a => Syntax' a -> Int
+measureAstSize = length . universe

src/Swarm/TUI/Controller.hs

@@ -439,6 +439,7 @@ saveScenarioInfoOnQuit = do
       Nothing -> return ()
       Just p' -> do
         gs <- use $ gameState . scenarios
+        initialCode <- use $ gameState . initiallyRunCode
         p <- liftIO $ normalizeScenarioPath gs p'
         t <- liftIO getZonedTime
         wc <- use $ gameState . winCondition
@@ -448,7 +449,15 @@ saveScenarioInfoOnQuit = do
         ts <- use $ gameState . ticks
         let currentScenarioInfo :: Traversal' AppState ScenarioInfo
             currentScenarioInfo = gameState . scenarios . scenarioItemByPath p . _SISingle . _2
-        currentScenarioInfo %= updateScenarioInfoOnQuit t ts won
+
+        replHist <- use $ uiState . uiREPL . replHistory
+        let determinator = CodeSizeDeterminators initialCode $ replHist ^. replHasExecutedManualInput
+        currentScenarioInfo
+          %= updateScenarioInfoOnQuit
+            determinator
+            t
+            ts
+            won
         status <- preuse currentScenarioInfo
         case status of
           Nothing -> return ()
@@ -953,6 +962,7 @@ handleREPLEventTyping = \case
             Right mt -> do
               uiState %= resetREPL "" (CmdPrompt [])
               uiState . uiREPL . replHistory %= addREPLItem (REPLEntry uinput)
+              uiState . uiREPL . replHistory . replHasExecutedManualInput .= True
               modify $ maybe id startBaseProgram mt
             Left err -> uiState . uiError ?= err
         SearchPrompt hist ->

src/Swarm/TUI/Model/Menu.hs

@@ -106,7 +106,7 @@ mkNewGameMenu cheat sc path = NewGameMenu . NE.fromList <$> go (Just sc) (splitP
   go (Just curSC) (thing : rest) stk = go nextSC rest (lst : stk)
    where
     hasName :: ScenarioItem -> Bool
-    hasName (SISingle (_, ScenarioInfo pth _ _ _)) = takeFileName pth == thing
+    hasName (SISingle (_, ScenarioInfo pth _ _ _ _)) = takeFileName pth == thing
     hasName (SICollection nm _) = nm == into @Text (dropTrailingPathSeparator thing)
 
     lst = BL.listFindBy hasName (mkScenarioList cheat curSC)

src/Swarm/TUI/Model/Repl.hs

@@ -13,6 +13,7 @@ module Swarm.TUI.Model.Repl (
   REPLHistory,
   replIndex,
   replLength,
+  replHasExecutedManualInput,
   replSeq,
   newREPLHistory,
   addREPLItem,
@@ -95,7 +96,9 @@ data REPLHistory = REPLHistory
   { _replSeq :: Seq REPLHistItem
   , _replIndex :: Int
   , _replStart :: Int
+  , _replHasExecutedManualInput :: Bool
   }
+  deriving (Show)
 
 makeLensesWith (lensRules & generateSignatures .~ False) ''REPLHistory
 
@@ -111,6 +114,22 @@ replIndex :: Lens' REPLHistory Int
 -- It will be set on load and reset on save (happens during exit).
 replStart :: Lens' REPLHistory Int
 
+-- | Note: Instead of adding a dedicated field to the REPLHistory record,
+-- an early attempt entailed checking for:
+--
+--    _replIndex > _replStart
+--
+-- However, executing an initial script causes
+-- a "REPLOutput" to be appended to the REPL history,
+-- which increments the replIndex, and thus makes
+-- the Index greater than the Start even though
+-- the player has input not commands into the REPL.
+--
+-- Therefore, a dedicated boolean is introduced into
+-- REPLHistory which simply latches True when the user
+-- has input a command.
+replHasExecutedManualInput :: Lens' REPLHistory Bool
+
 -- | Create new REPL history (i.e. from loaded history file lines).
 newREPLHistory :: [REPLHistItem] -> REPLHistory
 newREPLHistory xs =
@@ -119,6 +138,7 @@ newREPLHistory xs =
         { _replSeq = s
         , _replStart = length s
         , _replIndex = length s
+        , _replHasExecutedManualInput = False
         }
 
 -- | Point the start of REPL history after current last line. See 'replStart'.

src/Swarm/TUI/Model/StateUpdate.hs

@@ -69,7 +69,7 @@ initAppState AppOpts {..} = do
       let codeToRun = maybeAutoplay <|> maybeRunScript
 
       execStateT
-        (startGameWithSeed userSeed (scenario, ScenarioInfo path NotStarted NotStarted NotStarted) codeToRun)
+        (startGameWithSeed userSeed (scenario, ScenarioInfo path NotStarted NotStarted NotStarted Nothing) codeToRun)
         (AppState gs ui rs)
 
 -- | Load a 'Scenario' and start playing the game.
@@ -90,7 +90,12 @@ restartGame currentSeed siPair = startGameWithSeed (Just currentSeed) siPair Not
 
 -- | Load a 'Scenario' and start playing the game, with the
 --   possibility for the user to override the seed.
-startGameWithSeed :: (MonadIO m, MonadState AppState m) => Maybe Seed -> ScenarioInfoPair -> Maybe CodeToRun -> m ()
+startGameWithSeed ::
+  (MonadIO m, MonadState AppState m) =>
+  Maybe Seed ->
+  ScenarioInfoPair ->
+  Maybe CodeToRun ->
+  m ()
 startGameWithSeed userSeed siPair@(_scene, si) toRun = do
   t <- liftIO getZonedTime
   ss <- use $ gameState . scenarios