From eb9ec3eb427e47f1dbcb1b0efb5ad3b212c7aee9 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sat, 22 Jun 2024 15:46:26 -0700 Subject: [PATCH] enforce rows of grid are nonempty --- .../Structure/Recognition/Precompute.hs | 15 +++---- .../Scenario/Topography/WorldDescription.hs | 4 +- src/swarm-scenario/Swarm/Util/Content.hs | 2 +- .../Swarm/Game/Scenario/Topography/Area.hs | 45 ++++++++++++++----- .../Game/Scenario/Topography/Placement.hs | 15 ++++--- .../Game/Scenario/Topography/Rasterize.hs | 4 +- .../Game/Scenario/Topography/Structure.hs | 7 +-- .../Scenario/Topography/Structure/Assembly.hs | 4 +- .../Scenario/Topography/Structure/Overlay.hs | 17 ++++--- .../Structure/Recognition/Symmetry.hs | 3 +- src/swarm-tui/Swarm/TUI/Editor/Controller.hs | 5 +-- src/swarm-tui/Swarm/TUI/Editor/Util.hs | 2 +- test/unit/TestOverlay.hs | 4 +- 13 files changed, 77 insertions(+), 50 deletions(-) diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs index 0bcf9211be..5664773985 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs +++ b/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 diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs index 7fba5a1aa7..48396bd08a 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs +++ b/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 diff --git a/src/swarm-scenario/Swarm/Util/Content.hs b/src/swarm-scenario/Swarm/Util/Content.hs index b92d112250..0e619c6e87 100644 --- a/src/swarm-scenario/Swarm/Util/Content.hs +++ b/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 diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs index 20943a4298..674862dca0 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs +++ b/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 diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs index c9faa6a832..7d37ee8fbf 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs +++ b/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 diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Rasterize.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Rasterize.hs index a51ded72cc..021f376502 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Rasterize.hs +++ b/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 = diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs index 6c67c6eea0..e9a95fd378 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs +++ b/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 diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs index b10703c5fb..1da8fb70c8 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs +++ b/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 diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs index e60ffb7848..fafe46a3f1 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs @@ -70,12 +70,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 +129,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 +150,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 diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs index 758cd733c6..378bb7d2e4 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs +++ b/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 diff --git a/src/swarm-tui/Swarm/TUI/Editor/Controller.hs b/src/swarm-tui/Swarm/TUI/Editor/Controller.hs index 34d7dcb0d1..e52e4b6669 100644 --- a/src/swarm-tui/Swarm/TUI/Editor/Controller.hs +++ b/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 diff --git a/src/swarm-tui/Swarm/TUI/Editor/Util.hs b/src/swarm-tui/Swarm/TUI/Editor/Util.hs index b671713152..f69ae262d2 100644 --- a/src/swarm-tui/Swarm/TUI/Editor/Util.hs +++ b/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 diff --git a/test/unit/TestOverlay.hs b/test/unit/TestOverlay.hs index ee3f14151b..4c85f18f00 100644 --- a/test/unit/TestOverlay.hs +++ b/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