enforce rows of grid are nonempty

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

@@ -54,7 +54,7 @@ import Data.Set qualified as Set
 import Data.Tuple (swap)
 import Swarm.Game.Entity (Entity, EntityName, entityName)
 import Swarm.Game.Scenario (StaticStructureInfo (..))
-import Swarm.Game.Scenario.Topography.Area (Grid (Grid))
+import Swarm.Game.Scenario.Topography.Area (Grid, getRows)
 import Swarm.Game.Scenario.Topography.Cell (PCell, cellEntity)
 import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransform)
 import Swarm.Game.Scenario.Topography.Structure
@@ -67,14 +67,14 @@ import Swarm.Util.Erasable (erasableToMaybe)
 import Text.AhoCorasick
 
 getEntityGrid :: Grid (Maybe (PCell Entity)) -> [SymbolSequence Entity]
-getEntityGrid (Grid cells) = map (map ((erasableToMaybe . cellEntity) =<<)) cells
+getEntityGrid = map (map ((erasableToMaybe . cellEntity) =<<)) . getRows
 
 allStructureRows :: [StructureWithGrid b a] -> [StructureRow b a]
 allStructureRows =
-  concatMap getRows
+  concatMap transformRows
  where
-  getRows :: StructureWithGrid b a -> [StructureRow b a]
-  getRows g = zipWith (StructureRow g) [0 ..] $ entityGrid g
+  transformRows :: StructureWithGrid b a -> [StructureRow b a]
+  transformRows g = zipWith (StructureRow g) [0 ..] $ entityGrid g
 
 mkOffsets :: Foldable f => Int32 -> f a -> InspectionOffsets
 mkOffsets pos xs =
@@ -190,10 +190,9 @@ extractOrientedGrid ::
   NamedGrid (Maybe (PCell Entity)) ->
   AbsoluteDir ->
   StructureWithGrid (PCell Entity) Entity
-extractOrientedGrid x d = StructureWithGrid x d $ getEntityGrid g'
+extractOrientedGrid x d = StructureWithGrid x d $ getEntityGrid g
  where
-  Grid rows = structure x
-  g' = Grid $ applyOrientationTransform (Orientation d False) rows
+  g = applyOrientationTransform (Orientation d False) $ structure x
 
 -- | At this point, we have already ensured that orientations
 -- redundant by rotational symmetry have been excluded

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

@@ -18,7 +18,7 @@ import Swarm.Game.Entity
 import Swarm.Game.Land
 import Swarm.Game.Location
 import Swarm.Game.Scenario.RobotLookup
-import Swarm.Game.Scenario.Topography.Area (emptyGrid)
+import Swarm.Game.Scenario.Topography.Area (Grid (EmptyGrid))
 import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.EntityFacade
 import Swarm.Game.Scenario.Topography.Navigation.Portal
@@ -84,7 +84,7 @@ integrateArea ::
 integrateArea palette initialStructureDefs v = do
   placementDefs <- v .:? "placements" .!= []
   waypointDefs <- v .:? "waypoints" .!= []
-  rawMap <- v .:? "map" .!= emptyGrid
+  rawMap <- v .:? "map" .!= EmptyGrid
   (initialArea, mapWaypoints) <- paintMap Nothing palette rawMap
   let unflattenedStructure =
         Structure

src/swarm-scenario/Swarm/Util/Content.hs

@@ -38,7 +38,7 @@ getMapRectangle ::
   BoundsRectangle ->
   EA.Grid (PCell e)
 getMapRectangle paintTransform contentFunc coords =
-  EA.Grid $ map renderRow [yTop .. yBottom]
+  EA.mkGrid $ map renderRow [yTop .. yBottom]
  where
   (Coords (yTop, xLeft), Coords (yBottom, xRight)) = coords
 

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

@@ -7,38 +7,56 @@ module Swarm.Game.Scenario.Topography.Area where
 import Data.Aeson (ToJSON (..))
 import Data.Int (Int32)
 import Data.List qualified as L
-import Data.Maybe (listToMaybe)
+import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty qualified as NE
+import Data.Maybe (fromMaybe, listToMaybe)
+import Data.Semigroup
 import Linear (V2 (..))
 import Swarm.Game.Location
 import Swarm.Game.World.Coords
+import Prelude hiding (zipWith)
 
-newtype Grid c = Grid [[c]]
+data Grid c
+  = EmptyGrid
+  | Grid (NonEmpty (NonEmpty c))
   deriving (Show, Eq, Functor, Foldable, Traversable)
 
-emptyGrid :: Grid a
-emptyGrid = Grid []
+mkGrid :: [[a]] -> Grid a
+mkGrid rows = fromMaybe EmptyGrid $ do
+  rowsNE <- NE.nonEmpty =<< mapM NE.nonEmpty rows
+  return $ Grid rowsNE
 
 getRows :: Grid a -> [[a]]
-getRows (Grid g) = g
+getRows EmptyGrid = []
+getRows (Grid g) = NE.toList . NE.map NE.toList $ g
 
 -- | Since the derived 'Functor' instance applies to the
 -- type parameter that is nested within lists, we define
 -- an explicit function for mapping over the enclosing lists.
-mapRows :: ([[a]] -> [[b]]) -> Grid a -> Grid b
+mapRows :: (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty b)) -> Grid a -> Grid b
+mapRows _ EmptyGrid = EmptyGrid
 mapRows f (Grid rows) = Grid $ f rows
 
 allMembers :: Grid a -> [a]
-allMembers (Grid g) = concat g
+allMembers EmptyGrid = []
+allMembers g = concat . getRows $ g
 
 mapIndexedMembers :: (Coords -> a -> b) -> Grid a -> [b]
+mapIndexedMembers _ EmptyGrid = []
 mapIndexedMembers f (Grid g) =
-  concat $ zipWith (\i -> zipWith (\j -> f (Coords (i, j))) [0 ..]) [0 ..] g
+  NE.toList $
+    sconcat $
+      NE.zipWith (\i -> NE.zipWith (\j -> f (Coords (i, j))) nonemptyCount) nonemptyCount g
+ where
+  nonemptyCount = NE.iterate succ 0
 
 instance (ToJSON a) => ToJSON (Grid a) where
+  toJSON EmptyGrid = toJSON ([] :: [a])
   toJSON (Grid g) = toJSON g
 
 getGridDimensions :: Grid a -> AreaDimensions
-getGridDimensions (Grid g) = getAreaDimensions g
+getGridDimensions EmptyGrid = AreaDimensions 0 0
+getGridDimensions g = getAreaDimensions $ getRows g
 
 -- | Height and width of a 2D map region
 data AreaDimensions = AreaDimensions
@@ -94,8 +112,13 @@ getAreaDimensions cellGrid =
 computeArea :: AreaDimensions -> Int32
 computeArea (AreaDimensions w h) = w * h
 
+-- |
+-- Warning: size must be nonzero,
+-- since 'stimes' is unsafe with value @0@.
 fillGrid :: AreaDimensions -> a -> Grid a
 fillGrid (AreaDimensions w h) =
   Grid
-    . replicate (fromIntegral h)
-    . replicate (fromIntegral w)
+    . stimes h
+    . pure
+    . stimes w
+    . pure

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

@@ -8,7 +8,7 @@
 -- which a structure should be placed.
 module Swarm.Game.Scenario.Topography.Placement where
 
-import Data.List (transpose)
+import Data.List.NonEmpty qualified as NE
 import Data.Text (Text)
 import Data.Yaml as Y
 import GHC.Generics (Generic)
@@ -56,17 +56,18 @@ reorientLandmark (Orientation upDir shouldFlip) (AreaDimensions width height) =
     DWest -> transposeLoc . flipH
 
 -- | affine transformation
-applyOrientationTransform :: Orientation -> [[a]] -> [[a]]
+applyOrientationTransform :: Orientation -> Grid a -> Grid a
 applyOrientationTransform (Orientation upDir shouldFlip) =
-  rotational . flipping
+  mapRows f
  where
-  flipV = reverse
+  f = rotational . flipping
+  flipV = NE.reverse
   flipping = if shouldFlip then flipV else id
   rotational = case upDir of
     DNorth -> id
-    DSouth -> transpose . flipV . transpose . flipV
-    DEast -> transpose . flipV
-    DWest -> flipV . transpose
+    DSouth -> NE.transpose . flipV . NE.transpose . flipV
+    DEast -> NE.transpose . flipV
+    DWest -> flipV . NE.transpose
 
 data Pose = Pose
   { offset :: Location

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

@@ -5,13 +5,15 @@
 module Swarm.Game.Scenario.Topography.Rasterize where
 
 import Codec.Picture
+import Data.List.NonEmpty qualified as NE
 import Data.Vector qualified as V
 import Swarm.Game.Scenario.Topography.Area
 
 -- | Converts linked lists to vectors to facilitate
 -- random access when assembling the image
 gridToVec :: Grid a -> V.Vector (V.Vector a)
-gridToVec (Grid g) = V.fromList . map V.fromList $ g
+gridToVec EmptyGrid = V.empty
+gridToVec (Grid g) = V.fromList . map (V.fromList . NE.toList) $ NE.toList g
 
 makeImage :: Pixel px => (a -> px) -> Grid a -> Image px
 makeImage computeColor g =

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

@@ -91,13 +91,14 @@ instance (FromJSONE e a) => FromJSONE e (NamedStructure (Maybe a)) where
 instance FromJSON (Grid Char) where
   parseJSON = withText "area" $ \t -> do
     let textLines = map T.unpack $ T.lines t
+        g = mkGrid textLines
     case NE.nonEmpty textLines of
-      Nothing -> return emptyGrid
+      Nothing -> return EmptyGrid
       Just nonemptyRows -> do
         let firstRowLength = length $ NE.head nonemptyRows
         unless (all ((== firstRowLength) . length) $ NE.tail nonemptyRows) $
           fail "Grid is not rectangular!"
-        return $ Grid textLines
+        return g
 
 instance (FromJSONE e a) => FromJSONE e (PStructure (Maybe a)) where
   parseJSONE = withObjectE "structure definition" $ \v -> do
@@ -107,7 +108,7 @@ instance (FromJSONE e a) => FromJSONE e (PStructure (Maybe a)) where
       placements <- v .:? "placements" .!= []
       waypointDefs <- v .:? "waypoints" .!= []
       maybeMaskChar <- v .:? "mask"
-      rawGrid <- v .:? "map" .!= emptyGrid
+      rawGrid <- v .:? "map" .!= EmptyGrid
       (maskedArea, mapWaypoints) <- paintMap maybeMaskChar pal rawGrid
       let area = PositionedGrid origin maskedArea
           waypoints = waypointDefs <> mapWaypoints

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

@@ -101,10 +101,10 @@ overlayGridExpanded ::
 overlayGridExpanded
   inputGrid
   (Pose loc orientation)
-  (PositionedGrid _ (Grid overlayArea)) =
+  (PositionedGrid _ overlayArea) =
     PositionedGrid origin inputGrid <> positionedOverlay
    where
-    reorientedOverlayCells = Grid $ applyOrientationTransform orientation overlayArea
+    reorientedOverlayCells = applyOrientationTransform orientation overlayArea
     positionedOverlay = PositionedGrid loc reorientedOverlayCells
 
 -- * Validation

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

@@ -68,14 +68,14 @@ computeMergedArea (OverlayPair pg1 pg2) =
 zipGridRows ::
   Alternative f =>
   AreaDimensions ->
-  OverlayPair (Grid (f a)) ->
+  OverlayPair [[f a]] ->
   Grid (f a)
-zipGridRows dims (OverlayPair (Grid paddedBaseRows) (Grid paddedOverlayRows)) =
-  mapRows (pad2D paddedBaseRows . pad2D paddedOverlayRows) blankGrid
+zipGridRows dims (OverlayPair paddedBaseRows paddedOverlayRows) =
+  mkGrid $ (pad2D paddedBaseRows . pad2D paddedOverlayRows) blankGrid
  where
   -- Right-bias; that is, take the last non-empty value
   pad2D = zipPadded $ zipPadded $ flip (<|>)
-  blankGrid = fillGrid dims empty
+  blankGrid = getRows $ fillGrid dims empty
 
 -- |
 -- First arg: base layer
@@ -124,11 +124,11 @@ padSouthwest ::
   Alternative f =>
   V2 Int32 ->
   OverlayPair (Grid (f a)) ->
-  OverlayPair (Grid (f a))
+  OverlayPair [[f a]]
 padSouthwest (V2 deltaX deltaY) (OverlayPair baseGrid overlayGrid) =
   OverlayPair paddedBaseGrid paddedOverlayGrid
  where
-  prefixPadDimension delta f = mapRows $ f (padding <>)
+  prefixPadDimension delta f = f (padding <>)
    where
     padding = replicate (abs $ fromIntegral delta) empty
 
@@ -147,8 +147,8 @@ padSouthwest (V2 deltaX deltaY) (OverlayPair baseGrid overlayGrid) =
   (baseHorizontalPadFunc, overlayHorizontalPadFunc) =
     applyWhen (deltaX < 0) swap (id, prefixPadColumns)
 
-  paddedBaseGrid = baseVerticalPadFunc $ baseHorizontalPadFunc baseGrid
-  paddedOverlayGrid = overlayVerticalPadFunc $ overlayHorizontalPadFunc overlayGrid
+  paddedBaseGrid = baseVerticalPadFunc $ baseHorizontalPadFunc $ getRows baseGrid
+  paddedOverlayGrid = overlayVerticalPadFunc $ overlayHorizontalPadFunc $ getRows overlayGrid
 
 -- * Utils
 

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

@@ -10,7 +10,6 @@ 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.Area (Grid (Grid))
 import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransform)
 import Swarm.Game.Scenario.Topography.Structure qualified as Structure
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (RotationalSymmetry (..), SymmetryAnnotatedGrid (..))
@@ -67,4 +66,4 @@ checkSymmetry ng = do
   halfTurnRows = applyOrientationTransform (Orientation DSouth False) originalRows
 
   suppliedOrientations = Structure.recognize ng
-  Grid originalRows = Structure.structure ng
+  originalRows = Structure.structure ng

src/swarm-tui/Swarm/TUI/Editor/Controller.hs

@@ -17,7 +17,6 @@ import Data.Map qualified as M
 import Data.Yaml qualified as Y
 import Graphics.Vty qualified as V
 import Swarm.Game.Land
-import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.EntityFacade
 import Swarm.Game.State
 import Swarm.Game.State.Landscape
@@ -148,8 +147,8 @@ saveMapFile = do
   w <- use $ gameState . landscape . multiWorld
   tm <- use $ gameState . landscape . terrainAndEntities . terrainMap
   let mapCellGrid =
-        mapRows (map (map Just)) $
-          EU.getEditedMapRectangle tm (worldEditor ^. worldOverdraw) maybeBounds w
+        Just
+          <$> EU.getEditedMapRectangle tm (worldEditor ^. worldOverdraw) maybeBounds w
 
   let fp = worldEditor ^. outputFilePath
   maybeScenarioPair <- use $ uiState . uiGameplay . scenarioRef

src/swarm-tui/Swarm/TUI/Editor/Util.hs

@@ -107,7 +107,7 @@ getEditedMapRectangle ::
   Maybe (Cosmic BoundsRectangle) ->
   W.MultiWorld Int Entity ->
   EA.Grid CellPaintDisplay
-getEditedMapRectangle _ _ Nothing _ = EA.emptyGrid
+getEditedMapRectangle _ _ Nothing _ = EA.EmptyGrid
 getEditedMapRectangle tm worldEditor (Just (Cosmic subworldName coords)) w =
   getMapRectangle toFacade getContent coords
  where

src/swarm-tui/Swarm/TUI/View/Structure.hs

@@ -84,7 +84,7 @@ structureWidget gs s =
         , commaList $ map (T.pack . directionJsonModifier . show) supportedOrientations
         , "with"
         , renderSymmetry $ symmetry annotatedStructureGrid
-        , "symmetry."
+        , "rotational symmetry."
         ]
 
   maybeDescriptionWidget =

test/unit/TestOverlay.hs

@@ -37,6 +37,6 @@ mkOriginTestCase adjustmentDescription overlayLocation expectedBaseLoc =
   testCase (unwords [adjustmentDescription, "origin adjustment"]) $ do
     assertEqual "Base loc wrong" expectedBaseLoc actualBaseLoc
  where
-  baseLayer = PositionedGrid (Location 0 0) $ Grid [[] :: [Maybe Int]]
-  overlayLayer = PositionedGrid overlayLocation $ Grid [[]]
+  baseLayer = PositionedGrid (Location 0 0) (EmptyGrid :: Grid (Maybe ()))
+  overlayLayer = PositionedGrid overlayLocation EmptyGrid
   PositionedGrid actualBaseLoc _ = baseLayer <> overlayLayer