nonempty grid rows (#1933)

Closes #1843

Towards #1981

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

@@ -54,8 +54,8 @@ 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.Cell (PCell, cellEntity)
+import Swarm.Game.Scenario.Topography.Grid (Grid, getRows)
 import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransform)
 import Swarm.Game.Scenario.Topography.Structure
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry
@@ -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,9 +18,9 @@ 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.Cell
 import Swarm.Game.Scenario.Topography.EntityFacade
+import Swarm.Game.Scenario.Topography.Grid (Grid (EmptyGrid))
 import Swarm.Game.Scenario.Topography.Navigation.Portal
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint (
   Parentage (Root),
@@ -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/Game/Scenario/Topography/WorldPalette.hs

@@ -13,9 +13,9 @@ import Data.Set qualified as Set
 import Data.Text qualified as T
 import Data.Tuple (swap)
 import Swarm.Game.Entity
-import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.EntityFacade
+import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.ProtoCell
 import Swarm.Game.Terrain (TerrainType)
 import Swarm.Util.Erasable

src/swarm-scenario/Swarm/Game/State/Landscape.hs

@@ -40,6 +40,7 @@ import Swarm.Game.Location
 import Swarm.Game.Robot (TRobot, trobotLocation)
 import Swarm.Game.Scenario
 import Swarm.Game.Scenario.Topography.Area
+import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
 import Swarm.Game.Scenario.Topography.Structure.Overlay
 import Swarm.Game.State.Config

src/swarm-scenario/Swarm/Game/World/Render.hs

@@ -26,6 +26,7 @@ import Swarm.Game.Scenario.Topography.Area
 import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.Center
 import Swarm.Game.Scenario.Topography.EntityFacade (EntityFacade (..), mkFacade)
+import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.Rasterize
 import Swarm.Game.Scenario.Topography.Structure.Overlay
 import Swarm.Game.State.Landscape

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

@@ -11,9 +11,9 @@ import Data.Map qualified as M
 import Data.Text qualified as T
 import Swarm.Game.Display
 import Swarm.Game.Entity.Cosmetic
-import Swarm.Game.Scenario.Topography.Area qualified as EA
 import Swarm.Game.Scenario.Topography.Cell (PCell (..))
 import Swarm.Game.Scenario.Topography.EntityFacade
+import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Terrain (TerrainMap, TerrainType, getTerrainWord)
 import Swarm.Game.Universe
 import Swarm.Game.World
@@ -36,9 +36,9 @@ getMapRectangle ::
   (d -> e) ->
   (Coords -> (TerrainType, Maybe d)) ->
   BoundsRectangle ->
-  EA.Grid (PCell e)
+  Grid (PCell e)
 getMapRectangle paintTransform contentFunc coords =
-  EA.Grid $ map renderRow [yTop .. yBottom]
+  mkGrid $ map renderRow [yTop .. yBottom]
  where
   (Coords (yTop, xLeft), Coords (yBottom, xRight)) = coords
 

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

@@ -4,48 +4,24 @@
 -- SPDX-License-Identifier: BSD-3-Clause
 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.Semigroup
 import Linear (V2 (..))
 import Swarm.Game.Location
-import Swarm.Game.World.Coords
-
-newtype Grid c = Grid [[c]]
-  deriving (Show, Eq, Functor, Foldable, Traversable)
-
-emptyGrid :: Grid a
-emptyGrid = Grid []
-
-getRows :: Grid a -> [[a]]
-getRows (Grid g) = 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 f (Grid rows) = Grid $ f rows
-
-allMembers :: Grid a -> [a]
-allMembers (Grid g) = concat g
-
-mapIndexedMembers :: (Coords -> a -> b) -> Grid a -> [b]
-mapIndexedMembers f (Grid g) =
-  concat $ zipWith (\i -> zipWith (\j -> f (Coords (i, j))) [0 ..]) [0 ..] g
-
-instance (ToJSON a) => ToJSON (Grid a) where
-  toJSON (Grid g) = toJSON g
-
-getGridDimensions :: Grid a -> AreaDimensions
-getGridDimensions (Grid g) = getAreaDimensions g
+import Swarm.Game.Scenario.Topography.Grid
+import Prelude hiding (zipWith)
 
 -- | Height and width of a 2D map region
 data AreaDimensions = AreaDimensions
   { rectWidth :: Int32
   , rectHeight :: Int32
   }
 
+getGridDimensions :: Grid a -> AreaDimensions
+getGridDimensions g = getAreaDimensions $ getRows g
+
 asTuple :: AreaDimensions -> (Int32, Int32)
 asTuple (AreaDimensions x y) = (x, y)
 
@@ -95,7 +71,12 @@ computeArea :: AreaDimensions -> Int32
 computeArea (AreaDimensions w h) = w * h
 
 fillGrid :: AreaDimensions -> a -> Grid a
-fillGrid (AreaDimensions w h) =
+fillGrid (AreaDimensions 0 _) _ = EmptyGrid
+fillGrid (AreaDimensions _ 0) _ = EmptyGrid
+fillGrid (AreaDimensions w h) x =
   Grid
-    . replicate (fromIntegral h)
-    . replicate (fromIntegral w)
+    . stimes h
+    . pure
+    . stimes w
+    . pure
+    $ x

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

@@ -0,0 +1,65 @@
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+module Swarm.Game.Scenario.Topography.Grid (
+  Grid (..),
+  gridToVec,
+  mapIndexedMembers,
+  allMembers,
+  mapRows,
+  getRows,
+  mkGrid,
+)
+where
+
+import Data.Aeson (ToJSON (..))
+import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty qualified as NE
+import Data.Maybe (fromMaybe)
+import Data.Semigroup
+import Data.Vector qualified as V
+import Swarm.Game.World.Coords
+import Prelude hiding (zipWith)
+
+data Grid c
+  = EmptyGrid
+  | Grid (NonEmpty (NonEmpty c))
+  deriving (Show, Eq, Functor, Foldable, Traversable)
+
+mkGrid :: [[a]] -> Grid a
+mkGrid rows = fromMaybe EmptyGrid $ do
+  rowsNE <- NE.nonEmpty =<< mapM NE.nonEmpty rows
+  return $ Grid rowsNE
+
+getRows :: Grid a -> [[a]]
+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 :: (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 EmptyGrid = []
+allMembers g = concat . getRows $ g
+
+mapIndexedMembers :: (Coords -> a -> b) -> Grid a -> [b]
+mapIndexedMembers _ EmptyGrid = []
+mapIndexedMembers f (Grid g) =
+  NE.toList $
+    sconcat $
+      NE.zipWith (\i -> NE.zipWith (\j -> f (Coords (i, j))) nonemptyCount) nonemptyCount g
+ where
+  nonemptyCount = NE.iterate succ 0
+
+-- | Converts linked lists to vectors to facilitate
+-- random access when assembling the image
+gridToVec :: Grid a -> V.Vector (V.Vector a)
+gridToVec EmptyGrid = V.empty
+gridToVec (Grid g) = V.fromList . map (V.fromList . NE.toList) $ NE.toList g
+
+instance (ToJSON a) => ToJSON (Grid a) where
+  toJSON EmptyGrid = toJSON ([] :: [a])
+  toJSON (Grid g) = toJSON g

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

@@ -8,12 +8,13 @@
 -- 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)
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Area
+import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Language.Syntax.Direction (AbsoluteDir (..))
 
 newtype StructureName = StructureName Text
@@ -56,17 +57,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

@@ -7,11 +7,7 @@ module Swarm.Game.Scenario.Topography.Rasterize where
 import Codec.Picture
 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
+import Swarm.Game.Scenario.Topography.Grid
 
 makeImage :: Pixel px => (a -> px) -> Grid a -> Image px
 makeImage computeColor g =

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

@@ -21,7 +21,7 @@ import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Yaml as Y
 import Swarm.Game.Location
-import Swarm.Game.Scenario.Topography.Area
+import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint
 import Swarm.Game.Scenario.Topography.Placement
 import Swarm.Game.Scenario.Topography.ProtoCell
@@ -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

@@ -22,6 +22,7 @@ import Data.Text qualified as T
 import Linear.Affine
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Area
+import Swarm.Game.Scenario.Topography.Grid
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint
 import Swarm.Game.Scenario.Topography.Placement
 import Swarm.Game.Scenario.Topography.Structure
@@ -101,10 +102,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