enforce rows of grid are nonempty

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

@@ -7,34 +7,39 @@ module Swarm.Game.Scenario.Topography.Area where
 import Data.Aeson (ToJSON (..))
 import Data.Int (Int32)
 import Data.List qualified as L
+import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty qualified as NE
 import Data.Maybe (listToMaybe)
+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
-  { unGrid :: [[c]]
+  { unGrid :: NonEmpty [c]
   }
   deriving (Show, Eq, Functor, Foldable, Traversable)
 
 -- | 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 [a] -> NonEmpty [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
+  concat $ zipWith (\i -> zipWith (\j -> f (Coords (i, j))) [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 (Grid g) = getAreaDimensions $ NE.toList g
 
 -- | Height and width of a 2D map region
 data AreaDimensions = AreaDimensions
@@ -93,5 +98,6 @@ computeArea (AreaDimensions w h) = w * h
 fillGrid :: AreaDimensions -> a -> Grid a
 fillGrid (AreaDimensions w h) =
   Grid
-    . replicate (fromIntegral h)
+    . stimes (fromIntegral h)
+    . pure
     . replicate (fromIntegral w)

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

@@ -5,13 +5,14 @@
 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 (Grid g) = V.fromList . map V.fromList $ NE.toList g
 
 makeImage :: Pixel px => (a -> px) -> Grid a -> Image px
 makeImage computeColor g =

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

@@ -92,12 +92,12 @@ instance FromJSON (Grid Char) where
   parseJSON = withText "area" $ \t -> do
     let textLines = map T.unpack $ T.lines t
     case NE.nonEmpty textLines of
-      Nothing -> return $ Grid []
+      Nothing -> return $ Grid $ pure []
       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 $ Grid nonemptyRows
 
 instance (FromJSONE e a) => FromJSONE e (PStructure (Maybe a)) where
   parseJSONE = withObjectE "structure definition" $ \v -> do
@@ -107,7 +107,7 @@ instance (FromJSONE e a) => FromJSONE e (PStructure (Maybe a)) where
       placements <- v .:? "placements" .!= []
       waypointDefs <- v .:? "waypoints" .!= []
       maybeMaskChar <- v .:? "mask"
-      rawGrid <- v .:? "map" .!= Grid []
+      rawGrid <- v .:? "map" .!= Grid (pure [])
       (maskedArea, mapWaypoints) <- paintMap maybeMaskChar pal rawGrid
       let area = PositionedGrid origin maskedArea
           waypoints = waypointDefs <> mapWaypoints

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

@@ -11,6 +11,8 @@ 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.List.NonEmpty qualified as NE
 import Data.Tuple (swap)
 import Linear
 import Swarm.Game.Location
@@ -74,7 +76,7 @@ zipGridRows dims (OverlayPair (Grid paddedBaseRows) (Grid paddedOverlayRows)) =
   mapRows (pad2D paddedBaseRows . pad2D paddedOverlayRows) emptyGrid
  where
   -- Right-bias; that is, take the last non-empty value
-  pad2D = zipPadded $ zipPadded $ flip (<|>)
+  pad2D = zipPaddedNE $ zipPadded $ flip (<|>)
   emptyGrid = fillGrid dims empty
 
 -- |
@@ -132,8 +134,12 @@ padSouthwest (V2 deltaX deltaY) (OverlayPair baseGrid overlayGrid) =
    where
     padding = replicate (abs $ fromIntegral delta) empty
 
-  prefixPadRows = prefixPadDimension deltaY id
-  prefixPadColumns = prefixPadDimension deltaX map
+  prefixPadDimensionNE delta = mapRows (NE.prependList padding)
+   where
+    padding = replicate (abs $ fromIntegral delta) empty
+
+  prefixPadRows = prefixPadDimensionNE deltaY
+  prefixPadColumns = prefixPadDimension deltaX fmap
 
   -- Assume only the *overlay* requires vertical (top-)padding.
   -- However, if the conditional is true, then
@@ -161,3 +167,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

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,