start refactor (compiles)

src/swarm-engine/Swarm/Game/State/Initialize.hs

@@ -39,6 +39,7 @@ import Swarm.Game.Scenario
 import Swarm.Game.Scenario.Objective (initCompletion)
 import Swarm.Game.Scenario.Status
 import Swarm.Game.Scenario.Topography.Cell (Cell, cellToEntity)
+import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.Structure.Recognition
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Log
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute
@@ -187,7 +188,7 @@ pureScenarioToGameState scenario theSeed now toRun gsc =
 mkRecognizer ::
   (Has (State GameState) sig m) =>
   StaticStructureInfo Cell ->
-  m (StructureRecognizer (Maybe Cell) Entity)
+  m (StructureRecognizer (NonEmptyGrid (Maybe Cell)) Entity)
 mkRecognizer structInfo@(StaticStructureInfo structDefs _) = do
   foundIntact <- mapM checkIntactness allPlaced
 

src/swarm-engine/Swarm/Game/State/Substate.hs

@@ -107,6 +107,7 @@ import Swarm.Game.Robot
 import Swarm.Game.Scenario (GameStateInputs (..))
 import Swarm.Game.Scenario.Objective
 import Swarm.Game.Scenario.Topography.Cell (Cell)
+import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.Structure.Recognition
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (emptyFoundStructures)
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (RecognizerAutomatons (..))
@@ -342,7 +343,7 @@ data Discovery = Discovery
   , _availableCommands :: Notifications Const
   , _knownEntities :: S.Set EntityName
   , _gameAchievements :: Map GameplayAchievement Attainment
-  , _structureRecognition :: StructureRecognizer (Maybe Cell) Entity
+  , _structureRecognition :: StructureRecognizer (NonEmptyGrid (Maybe Cell)) Entity
   , _tagMembers :: Map Text (NonEmpty EntityName)
   }
 
@@ -365,7 +366,7 @@ knownEntities :: Lens' Discovery (S.Set EntityName)
 gameAchievements :: Lens' Discovery (Map GameplayAchievement Attainment)
 
 -- | Recognizer for robot-constructed structures
-structureRecognition :: Lens' Discovery (StructureRecognizer (Maybe Cell) Entity)
+structureRecognition :: Lens' Discovery (StructureRecognizer (NonEmptyGrid (Maybe Cell)) Entity)
 
 -- | Map from tags to entities that possess that tag
 tagMembers :: Lens' Discovery (Map Text (NonEmpty EntityName))

src/swarm-engine/Swarm/Game/Step/Const.hs

@@ -59,7 +59,7 @@ import Swarm.Game.Robot
 import Swarm.Game.Robot.Activity
 import Swarm.Game.Robot.Concrete
 import Swarm.Game.Robot.Walk (emptyExceptions)
-import Swarm.Game.Scenario.Topography.Area (getAreaDimensions, getNEGridDimensions, rectHeight)
+import Swarm.Game.Scenario.Topography.Area (getNEGridDimensions, rectHeight)
 import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
 import Swarm.Game.Scenario.Topography.Navigation.Util
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointName (..))
@@ -568,7 +568,7 @@ execConst runChildProg c vs s k = do
         structureDef <-
           maybeStructure
             `isJustOr` cmdExn Floorplan (pure $ T.unwords ["Unknown structure", quote name])
-        return . mkReturn . getAreaDimensions $ entityProcessedGrid structureDef
+        return . mkReturn . getNEGridDimensions $ entityProcessedGrid structureDef
       _ -> badConst
     HasTag -> case vs of
       [VText eName, VText tName] -> do

src/swarm-scenario/Swarm/Game/Scenario.hs

@@ -86,6 +86,7 @@ import Swarm.Game.Scenario.Objective.Validation
 import Swarm.Game.Scenario.RobotLookup
 import Swarm.Game.Scenario.Style
 import Swarm.Game.Scenario.Topography.Cell
+import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.Navigation.Portal
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint (Parentage (..))
 import Swarm.Game.Scenario.Topography.Structure qualified as Structure
@@ -355,7 +356,8 @@ instance FromJSONE ScenarioInputs Scenario where
           namedGrids = map stuffGrid mergedStructures
           recognizableGrids = filter Structure.isRecognizable namedGrids
 
-      symmetryAnnotatedGrids <- mapM checkSymmetry recognizableGrids
+      let nonEmptyRecognizableGrids = mapMaybe (traverse getNonEmptyGrid) recognizableGrids
+      symmetryAnnotatedGrids <- mapM checkSymmetry nonEmptyRecognizableGrids
 
       let structureInfo =
             StaticStructureInfo symmetryAnnotatedGrids

src/swarm-topography/Swarm/Game/Scenario/Topography/Grid.hs

@@ -4,12 +4,14 @@ module Swarm.Game.Scenario.Topography.Grid (
   Grid (..),
   NonEmptyGrid (..),
   gridToVec,
-  mapWithCoordsNE,
   mapWithCoords,
+  mapWithCoordsNE,
   allMembers,
+  allMembersNE,
   mapRowsNE,
   getRows,
   mkGrid,
+  getNonEmptyGrid,
 )
 where
 
@@ -44,6 +46,11 @@ mkGrid rows = fromMaybe EmptyGrid $ do
   rowsNE <- NE.nonEmpty =<< mapM NE.nonEmpty rows
   return $ Grid $ NonEmptyGrid rowsNE
 
+getNonEmptyGrid :: Grid a -> Maybe (NonEmptyGrid a)
+getNonEmptyGrid = \case
+  EmptyGrid -> Nothing
+  Grid x -> Just x
+
 getRows :: Grid a -> [[a]]
 getRows EmptyGrid = []
 getRows (Grid (NonEmptyGrid g)) = NE.toList . NE.map NE.toList $ g

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Named.hs

@@ -6,7 +6,6 @@ import Data.Set (Set)
 import Data.Text (Text)
 import Data.Yaml
 import GHC.Generics (Generic)
-import Swarm.Game.Scenario.Topography.Grid (Grid)
 import Swarm.Language.Syntax.Direction (AbsoluteDir)
 
 newtype StructureName = StructureName Text
@@ -27,9 +26,7 @@ data NamedArea a = NamedArea
   -- ^ will be UI-facing only if this is a recognizable structure
   , structure :: a
   }
-  deriving (Eq, Show, Functor)
+  deriving (Eq, Show, Functor, Foldable, Traversable)
 
 isRecognizable :: NamedArea a -> Bool
 isRecognizable = not . null . recognize
-
-type NamedGrid c = NamedArea (Grid c)

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs

@@ -32,7 +32,7 @@ data StructureRecognizer b a = StructureRecognizer
   { _automatons :: RecognizerAutomatons b a
   -- ^ read-only
   , _recognitionState :: RecognitionState b a
-  -- ^ mutatable
+  -- ^ mutable
   }
   deriving (Generic)
 

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs

@@ -49,6 +49,7 @@ import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except (except, runExceptT)
 import Data.Either.Combinators (leftToMaybe)
 import Data.Hashable (Hashable)
+import Data.List.NonEmpty qualified as NE
 import Data.Map qualified as M
 import Data.Maybe (catMaybes, mapMaybe)
 import Data.Set qualified as Set
@@ -81,48 +82,45 @@ import Swarm.Util (histogram)
 -- 's' is the state variable, 'a' is the return type.
 type GenericEntLocator s a = Cosmic Location -> s (Maybe a)
 
-getEntityGrid :: (Maybe b -> Maybe a) -> NamedGrid (Maybe b) -> [[Maybe a]]
+getEntityGrid :: (Maybe b -> Maybe a) -> NamedArea (Grid (Maybe b)) -> [[Maybe a]]
 getEntityGrid extractor = getRows . fmap extractor . structure
 
 -- | Create Aho-Corasick matchers that will recognize all of the
 -- provided structure definitions
 mkAutomatons ::
   (Ord a, Hashable a) =>
   (Maybe b -> Maybe a) ->
-  [SymmetryAnnotatedGrid (Maybe b)] ->
-  RecognizerAutomatons (Maybe b) a
-mkAutomatons extractor xs =
+  [SymmetryAnnotatedGrid (NonEmptyGrid (Maybe b))] ->
+  RecognizerAutomatons (NonEmptyGrid (Maybe b)) a
+mkAutomatons extractor onlyNonempties =
   RecognizerAutomatons
     infos
     (mkEntityLookup rotatedGrids)
  where
-  rotatedGrids = concatMap (extractGrids extractor . namedGrid) xs
+  rotatedGrids = concatMap (extractGrids extractor . namedGrid) onlyNonempties
 
   process g = StructureInfo g entGrid countsMap
    where
-    entGrid = getEntityGrid extractor $ namedGrid g
-    countsMap = histogram $ concatMap catMaybes entGrid
+    entGrid = fmap extractor $ structure $ namedGrid g
+    countsMap = histogram . catMaybes . NE.toList $ allMembersNE entGrid
 
   infos =
     M.fromList $
-      map (name . namedGrid &&& process) xs
+      map (name . namedGrid &&& process) onlyNonempties
 
 -- | Returns 'Nothing' if the grid is empty, since we want
 -- to exclude them from the recognition engine.
 extractOrientedGrid ::
   (Maybe b -> Maybe a) ->
-  NamedGrid (Maybe b) ->
+  NamedArea (NonEmptyGrid (Maybe b)) ->
   AbsoluteDir ->
-  Maybe (StructureWithGrid (Maybe b) a)
+  StructureWithGrid (NonEmptyGrid (Maybe b)) a
 extractOrientedGrid extractor x d =
-  case extractor <$> structure x of
-    EmptyGrid -> Nothing
-    Grid neGrid ->
-      let w = RowWidth . rectWidth . getNEGridDimensions $ neGrid
-       in Just $
-            StructureWithGrid wrapped d w $
-              applyOrientationTransformNE (Orientation d False) neGrid
+  StructureWithGrid wrapped d w $
+    applyOrientationTransformNE (Orientation d False) neGrid
  where
+  w = RowWidth . rectWidth . getNEGridDimensions $ neGrid
+  neGrid = extractor <$> structure x
   wrapped = NamedOriginal (name x) x
 
 -- |
@@ -133,10 +131,10 @@ extractOrientedGrid extractor x d =
 -- Excludes empty grids.
 extractGrids ::
   (Maybe b -> Maybe a) ->
-  NamedGrid (Maybe b) ->
-  [StructureWithGrid (Maybe b) a]
+  NamedArea (NonEmptyGrid (Maybe b)) ->
+  [StructureWithGrid (NonEmptyGrid (Maybe b)) a]
 extractGrids extractor x =
-  mapMaybe (extractOrientedGrid extractor x) orientations
+  map (extractOrientedGrid extractor x) orientations
  where
   orientations = Set.toList $ recognize x
 
@@ -146,7 +144,7 @@ extractGrids extractor x =
 lookupStaticPlacements ::
   (Maybe b -> Maybe a) ->
   StaticStructureInfo b ->
-  [FoundStructure (Maybe b) a]
+  [FoundStructure (NonEmptyGrid (Maybe b)) a]
 lookupStaticPlacements extractor (StaticStructureInfo structDefs thePlacements) =
   concatMap f $ M.toList thePlacements
  where
@@ -156,7 +154,7 @@ lookupStaticPlacements extractor (StaticStructureInfo structDefs thePlacements)
    where
     g (LocatedStructure (OrientedStructure theName d) loc) = do
       sGrid <- M.lookup theName definitionMap
-      x <- extractOrientedGrid extractor sGrid d
+      let x = extractOrientedGrid extractor sGrid d
       return $ PositionedStructure (Cosmic subworldName loc) x
 
 -- | Matches definitions against the placements.

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Static.hs

@@ -9,6 +9,7 @@ import Data.Aeson (ToJSON)
 import Data.Map (Map)
 import GHC.Generics (Generic)
 import Swarm.Game.Location
+import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.Structure.Named
 import Swarm.Game.Universe (SubworldName)
 import Swarm.Language.Syntax.Direction (AbsoluteDir)
@@ -24,10 +25,10 @@ data RotationalSymmetry
   deriving (Show, Eq)
 
 data SymmetryAnnotatedGrid a = SymmetryAnnotatedGrid
-  { namedGrid :: NamedGrid a
-  , symmetry :: RotationalSymmetry
+  { symmetry :: RotationalSymmetry
+  , namedGrid :: NamedArea a
   }
-  deriving (Show)
+  deriving (Show, Functor, Foldable, Traversable)
 
 data OrientedStructure = OrientedStructure
   { oName :: StructureName
@@ -50,7 +51,7 @@ instance HasLocation LocatedStructure where
     LocatedStructure x $ f originalLoc
 
 data StaticStructureInfo b = StaticStructureInfo
-  { _structureDefs :: [SymmetryAnnotatedGrid (Maybe b)]
+  { _structureDefs :: [SymmetryAnnotatedGrid (NonEmptyGrid (Maybe b))]
   , _staticPlacements :: Map SubworldName [LocatedStructure]
   }
   deriving (Show)
@@ -59,7 +60,7 @@ makeLensesNoSigs ''StaticStructureInfo
 
 -- | Structure templates that may be auto-recognized when constructed
 -- by a robot
-structureDefs :: Lens' (StaticStructureInfo b) [SymmetryAnnotatedGrid (Maybe b)]
+structureDefs :: Lens' (StaticStructureInfo b) [SymmetryAnnotatedGrid (NonEmptyGrid (Maybe b))]
 
 -- | A record of the static placements of structures, so that they can be
 -- added to the "recognized" list upon scenario initialization

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs

@@ -10,8 +10,9 @@ import Control.Monad (unless, when)
 import Data.Map qualified as M
 import Data.Set qualified as Set
 import Data.Text qualified as T
-import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransform)
-import Swarm.Game.Scenario.Topography.Structure.Named (NamedGrid, recognize, structure)
+import Swarm.Game.Scenario.Topography.Grid
+import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransformNE)
+import Swarm.Game.Scenario.Topography.Structure.Named (NamedArea, recognize, structure)
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Static (RotationalSymmetry (..), SymmetryAnnotatedGrid (..))
 import Swarm.Language.Syntax.Direction (AbsoluteDir (DSouth, DWest), getCoordinateOrientation)
 import Swarm.Util (commaList, failT, histogram, showT)
@@ -28,7 +29,9 @@ import Swarm.Util (commaList, failT, histogram, showT)
 --    2-fold symmetry.
 --    Warn if two opposite orientations were supplied.
 checkSymmetry ::
-  (MonadFail m, Eq a) => NamedGrid a -> m (SymmetryAnnotatedGrid a)
+  (MonadFail m, Eq a) =>
+  NamedArea (NonEmptyGrid a) ->
+  m (SymmetryAnnotatedGrid (NonEmptyGrid a))
 checkSymmetry ng = do
   case symmetryType of
     FourFold ->
@@ -55,15 +58,15 @@ checkSymmetry ng = do
           $ Set.toList suppliedOrientations
     _ -> return ()
 
-  return $ SymmetryAnnotatedGrid ng symmetryType
+  return $ SymmetryAnnotatedGrid symmetryType ng
  where
   symmetryType
     | quarterTurnRows == originalRows = FourFold
     | halfTurnRows == originalRows = TwoFold
     | otherwise = NoSymmetry
 
-  quarterTurnRows = applyOrientationTransform (Orientation DWest False) originalRows
-  halfTurnRows = applyOrientationTransform (Orientation DSouth False) originalRows
+  quarterTurnRows = applyOrientationTransformNE (Orientation DWest False) originalRows
+  halfTurnRows = applyOrientationTransformNE (Orientation DSouth False) originalRows
 
   suppliedOrientations = recognize ng
   originalRows = structure ng

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs

@@ -33,6 +33,7 @@ import Data.Semigroup (Max (..), Min (..))
 import Data.Tuple (swap)
 import Linear (V2 (..))
 import Swarm.Game.Location (Location)
+import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.Structure.Recognition
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Log
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute (GenericEntLocator, ensureStructureIntact)
@@ -54,8 +55,8 @@ entityModified ::
   GenericEntLocator s a ->
   CellModification a ->
   Cosmic Location ->
-  StructureRecognizer b a ->
-  s (StructureRecognizer b a)
+  StructureRecognizer (NonEmptyGrid b) a ->
+  s (StructureRecognizer (NonEmptyGrid b) a)
 entityModified entLoader modification cLoc recognizer = do
   (val, accumulatedLogs) <- runWriterT $ case modification of
     Add newEntity -> doAddition newEntity recognizer
@@ -237,9 +238,9 @@ registerRowMatches ::
   (Monoid (f (SearchLog a)), Applicative f, Monad s, Hashable a, Eq b) =>
   GenericEntLocator s a ->
   Cosmic Location ->
-  AutomatonInfo b a ->
-  RecognitionState b a ->
-  WriterT (f (SearchLog a)) s (RecognitionState b a)
+  AutomatonInfo (NonEmptyGrid b) a ->
+  RecognitionState (NonEmptyGrid b) a ->
+  WriterT (f (SearchLog a)) s (RecognitionState (NonEmptyGrid b) a)
 registerRowMatches entLoader cLoc (AutomatonInfo horizontalOffsets pwMatcher) rState = do
   tell $ pure $ StartSearchAt cLoc horizontalOffsets
 

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs

@@ -35,7 +35,7 @@ import GHC.Generics (Generic)
 import Swarm.Game.Location (Location, asVector)
 import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Grid
-import Swarm.Game.Scenario.Topography.Structure.Named (NamedGrid, StructureName)
+import Swarm.Game.Scenario.Topography.Structure.Named (NamedArea, StructureName)
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Static
 import Swarm.Game.Universe (Cosmic, offsetBy)
 import Swarm.Game.World.Coords (coordsToLoc)
@@ -160,7 +160,7 @@ data ConsolidatedRowReferences b a = ConsolidatedRowReferences
 -- while remaining agnostic to its internals.
 data NamedOriginal b = NamedOriginal
   { getName :: StructureName
-  , orig :: NamedGrid b
+  , orig :: NamedArea b
   }
   deriving (Show, Eq)
 
@@ -180,7 +180,7 @@ data StructureWithGrid b a = StructureWithGrid
 -- | Structure definitions with precomputed metadata for consumption by the UI
 data StructureInfo b a = StructureInfo
   { annotatedGrid :: SymmetryAnnotatedGrid b
-  , entityProcessedGrid :: [SymbolSequence a]
+  , entityProcessedGrid :: NonEmptyGrid (AtomicKeySymbol a)
   , entityCounts :: Map a Int
   }