enforce rows of grid are nonempty

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

@@ -7,38 +7,54 @@ 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 (listToMaybe, fromMaybe)
+import Data.Semigroup
+import Data.Zip (zipWith)
 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 <- mapM NE.nonEmpty rows
+  outerNE <- NE.nonEmpty rowsNE
+  return $ Grid outerNE
 
 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))) (NE.iterate succ 0)) (NE.iterate succ 0) g
 
 instance (ToJSON a) => ToJSON (Grid a) where
   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
@@ -97,5 +113,7 @@ computeArea (AreaDimensions w h) = w * h
 fillGrid :: AreaDimensions -> a -> Grid a
 fillGrid (AreaDimensions w h) =
   Grid
-    . replicate (fromIntegral h)
-    . replicate (fromIntegral w)
+    . stimes (fromIntegral h)
+    . pure
+    . stimes (fromIntegral 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,20 @@ reorientLandmark (Orientation upDir shouldFlip) (AreaDimensions width height) =
     DWest -> transposeLoc . flipH
 
 -- | affine transformation
-applyOrientationTransform :: Orientation -> [[a]] -> [[a]]
-applyOrientationTransform (Orientation upDir shouldFlip) =
-  rotational . flipping
+applyOrientationTransform :: Orientation -> Grid a -> Grid a
+applyOrientationTransform (Orientation upDir shouldFlip) g = case g of
+  EmptyGrid -> EmptyGrid
+  Grid rows -> Grid $ f rows
+
  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

@@ -107,10 +107,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
 
 -- | NOTE: This ignores the 'loc' parameter of 'PositionedGrid'.
@@ -122,12 +122,15 @@ overlayGridTruncated ::
 overlayGridTruncated
   (Grid inputArea)
   (Pose (Location colOffset rowOffset) orientation)
-  (PositionedGrid _ (Grid overlayArea)) =
-    PositionedGrid origin
+  (PositionedGrid _ g) = go g
+
+   where
+    go EmptyGrid = PositionedGrid origin EmptyGrid
+    go overlayArea = PositionedGrid origin
       . Grid
       . zipWithPad mergeSingleRow inputArea
       $ paddedOverlayRows overlayArea
-   where
+
     zipWithPad f a b = zipWith f a $ b <> repeat Nothing
 
     mergeSingleRow inputRow maybeOverlayRow =

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

@@ -11,6 +11,7 @@ module Swarm.Game.Scenario.Topography.Structure.Overlay (
 import Control.Applicative
 import Data.Function (on)
 import Data.Int (Int32)
+import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.Tuple (swap)
 import Linear
 import Swarm.Game.Location
@@ -70,12 +71,15 @@ zipGridRows ::
   AreaDimensions ->
   OverlayPair (Grid (f a)) ->
   Grid (f a)
-zipGridRows dims (OverlayPair (Grid paddedBaseRows) (Grid paddedOverlayRows)) =
-  mapRows (pad2D paddedBaseRows . pad2D paddedOverlayRows) blankGrid
+zipGridRows dims (OverlayPair baseGrid overlayGrid) =
+  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
+
+  paddedBaseRows = getRows baseGrid
+  paddedOverlayRows = getRows overlayGrid
 
 -- |
 -- First arg: base layer
@@ -126,9 +130,9 @@ padSouthwest ::
   OverlayPair (Grid (f a)) ->
   OverlayPair (Grid (f a))
 padSouthwest (V2 deltaX deltaY) (OverlayPair baseGrid overlayGrid) =
-  OverlayPair paddedBaseGrid paddedOverlayGrid
+  OverlayPair (mkGrid paddedBaseGrid) (mkGrid paddedOverlayGrid)
  where
-  prefixPadDimension delta f = mapRows $ f (padding <>)
+  prefixPadDimension delta f = f (padding <>)
    where
     padding = replicate (abs $ fromIntegral delta) empty
 
@@ -147,8 +151,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
 
@@ -161,3 +165,6 @@ zipPadded :: (a -> a -> a) -> [a] -> [a] -> [a]
 zipPadded _ [] ys = ys
 zipPadded _ xs [] = xs
 zipPadded f (x : xs) (y : ys) = f x y : zipPadded f xs ys
+
+zipPaddedNE :: (a -> a -> a) -> NonEmpty a -> NonEmpty a -> NonEmpty a
+zipPaddedNE f (x :| xs) (y :| ys) = f x y :| zipPadded f xs ys

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

swarm.cabal

@@ -240,6 +240,7 @@ library swarm-topography
     linear >=1.21.6 && <1.24,
     nonempty-containers >=0.3.4 && <0.3.5,
     servant-docs >=0.12 && <0.14,
+    semialign >=1.3 && <1.4,
     text >=1.2.4 && <2.2,
     vector >=0.12 && <0.14,
     yaml >=0.11 && <0.11.12.0,