From 47390050b5bab630996961b3e21fb87712721063 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 28 Apr 2024 21:33:12 -0700 Subject: [PATCH] Split structure assembly into separate module (#1811) Split the `Structure.hs` module in preparation for #1780. This refactoring entails no functional change. # Also included * follow-up to #1804 to remove REPL re-exports * reformat `swarm.cabal` for the latest version of `cabal-gild` --- src/Swarm/TUI/Model.hs | 36 ---- src/Swarm/TUI/View.hs | 2 +- src/swarm-scenario/Swarm/Game/Scenario.hs | 3 +- .../Game/Scenario/Topography/Placement.hs | 17 +- .../Game/Scenario/Topography/Structure.hs | 129 +-------------- .../Scenario/Topography/Structure/Assembly.hs | 156 ++++++++++++++++++ .../Scenario/Topography/WorldDescription.hs | 3 +- src/swarm-web/Swarm/Web.hs | 1 + swarm.cabal | 1 + 9 files changed, 177 insertions(+), 171 deletions(-) create mode 100644 src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Assembly.hs diff --git a/src/Swarm/TUI/Model.hs b/src/Swarm/TUI/Model.hs index ddb4039e6..4a7503405 100644 --- a/src/Swarm/TUI/Model.hs +++ b/src/Swarm/TUI/Model.hs @@ -33,47 +33,12 @@ module Swarm.TUI.Model ( -- * UI state - -- ** REPL - REPLHistItem (..), - replItemText, - isREPLEntry, - getREPLEntry, - REPLHistory, - replIndex, - replLength, - replSeq, - newREPLHistory, - addREPLItem, - restartREPLHistory, - getLatestREPLHistoryItems, - moveReplHistIndex, - getCurrentItemText, - replIndexIsAtInput, - TimeDir (..), - - -- ** Prompt utils - REPLPrompt (..), - removeEntry, - -- ** Inventory InventoryListEntry (..), _Separator, _InventoryEntry, _EquippedEntry, - -- *** REPL Panel Model - REPLState, - ReplControlMode (..), - replPromptType, - replPromptEditor, - replPromptText, - replValid, - replLast, - replType, - replControlMode, - replHistory, - newREPLEditor, - -- ** Updating populateInventoryList, infoScroll, @@ -132,7 +97,6 @@ import Swarm.Log import Swarm.TUI.Inventory.Sorting import Swarm.TUI.Model.Menu import Swarm.TUI.Model.Name -import Swarm.TUI.Model.Repl import Swarm.TUI.Model.UI import Swarm.Util.Lens (makeLensesNoSigs) import Swarm.Version (NewReleaseFailure) diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs index 70f608fe2..ec4c9d802 100644 --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -132,7 +132,7 @@ import Swarm.TUI.Launch.Model import Swarm.TUI.Launch.View import Swarm.TUI.Model import Swarm.TUI.Model.Goal (goalsContent, hasAnythingToShow) -import Swarm.TUI.Model.Repl (getSessionREPLHistoryItems, lastEntry) +import Swarm.TUI.Model.Repl import Swarm.TUI.Model.UI import Swarm.TUI.Panel import Swarm.TUI.View.Achievement diff --git a/src/swarm-scenario/Swarm/Game/Scenario.hs b/src/swarm-scenario/Swarm/Game/Scenario.hs index ff7e2a3ac..51fcc576c 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario.hs @@ -99,6 +99,7 @@ import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.Navigation.Portal import Swarm.Game.Scenario.Topography.Navigation.Waypoint (Parentage (..)) import Swarm.Game.Scenario.Topography.Structure qualified as Structure +import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly import Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (SymmetryAnnotatedGrid (..)) import Swarm.Game.Scenario.Topography.WorldDescription @@ -333,7 +334,7 @@ instance FromJSONE ScenarioInputs Scenario where mergedStructures <- either (fail . T.unpack) return $ mapM - (sequenceA . (id &&& (Structure.mergeStructures mempty Root . Structure.structure))) + (sequenceA . (id &&& (Assembly.mergeStructures mempty Root . Structure.structure))) rootLevelSharedStructures let namedGrids = map (\(ns, Structure.MergedStructure s _ _) -> Grid s <$ ns) mergedStructures diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Placement.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Placement.hs index bbcef9aca..01bc67ab0 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Placement.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Placement.hs @@ -67,16 +67,23 @@ applyOrientationTransform (Orientation upDir shouldFlip) = DEast -> transpose . flipV DWest -> flipV . transpose +data Pose = Pose + { offset :: Location + , orient :: Orientation + } + deriving (Eq, Show) + data Placement = Placement { src :: StructureName - , offset :: Location - , orient :: Orientation + , structurePose :: Pose } deriving (Eq, Show) instance FromJSON Placement where parseJSON = withObject "structure placement" $ \v -> do sName <- v .: "src" - Placement sName - <$> v .:? "offset" .!= origin - <*> v .:? "orient" .!= defaultOrientation + p <- + Pose + <$> v .:? "offset" .!= origin + <*> v .:? "orient" .!= defaultOrientation + return $ Placement sName p diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs index 516845829..263ed88ae 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs @@ -7,18 +7,10 @@ -- as well as logic for combining them. module Swarm.Game.Scenario.Topography.Structure where -import Control.Applicative ((<|>)) -import Control.Arrow (left, (&&&)) -import Control.Monad (when) import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap -import Data.Coerce -import Data.Either.Extra (maybeToEither) -import Data.Foldable (foldrM) -import Data.Map qualified as M import Data.Maybe (catMaybes) import Data.Set (Set) -import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Yaml as Y @@ -30,8 +22,8 @@ import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.Navigation.Waypoint import Swarm.Game.Scenario.Topography.Placement import Swarm.Game.Scenario.Topography.WorldPalette -import Swarm.Language.Direction (AbsoluteDir, directionJsonModifier) -import Swarm.Util (commaList, failT, quote, showT) +import Swarm.Language.Direction (AbsoluteDir) +import Swarm.Util (failT, showT) import Swarm.Util.Yaml import Witch (into) @@ -94,123 +86,6 @@ instance HasLocation LocatedStructure where data MergedStructure c = MergedStructure [[c]] [LocatedStructure] [Originated Waypoint] --- | Destructively overlays one direct child structure --- upon the input structure. --- However, the child structure is assembled recursively. -overlaySingleStructure :: - M.Map StructureName (NamedStructure (Maybe a)) -> - Placed (Maybe a) -> - MergedStructure (Maybe a) -> - Either Text (MergedStructure (Maybe a)) -overlaySingleStructure - inheritedStrucDefs - (Placed p@(Placement _ loc@(Location colOffset rowOffset) orientation) ns) - (MergedStructure inputArea inputPlacements inputWaypoints) = do - MergedStructure overlayArea overlayPlacements overlayWaypoints <- - mergeStructures inheritedStrucDefs (WithParent p) $ structure ns - - let mergedWaypoints = inputWaypoints <> map (fmap $ placeOnArea overlayArea) overlayWaypoints - mergedPlacements = inputPlacements <> map (placeOnArea overlayArea) overlayPlacements - mergedArea = zipWithPad mergeSingleRow inputArea $ paddedOverlayRows overlayArea - - return $ MergedStructure mergedArea mergedPlacements mergedWaypoints - where - placeOnArea overArea = - offsetLoc (coerce loc) - . modifyLoc (reorientLandmark orientation $ getAreaDimensions overArea) - - zipWithPad f a b = zipWith f a $ b <> repeat Nothing - - affineTransformedOverlay = applyOrientationTransform orientation - - mergeSingleRow inputRow maybeOverlayRow = - zipWithPad (flip (<|>)) inputRow paddedSingleOverlayRow - where - paddedSingleOverlayRow = maybe [] (applyOffset colOffset) maybeOverlayRow - - paddedOverlayRows = applyOffset (negate rowOffset) . map Just . affineTransformedOverlay - applyOffset offsetNum = modifyFront - where - integralOffset = fromIntegral offsetNum - modifyFront = - if integralOffset >= 0 - then (replicate integralOffset Nothing <>) - else drop $ abs integralOffset - -elaboratePlacement :: Parentage Placement -> Either Text a -> Either Text a -elaboratePlacement p = left (elaboration <>) - where - pTxt = case p of - Root -> "root placement" - WithParent (Placement (StructureName sn) loc _) -> - T.unwords - [ "placement of" - , quote sn - , "at" - , showT loc - ] - elaboration = - T.unwords - [ "Within" - , pTxt <> ":" - , "" - ] - --- | Overlays all of the "child placements", such that the children encountered earlier --- in the YAML file supersede the later ones (due to use of 'foldr' instead of 'foldl'). -mergeStructures :: - M.Map StructureName (NamedStructure (Maybe a)) -> - Parentage Placement -> - PStructure (Maybe a) -> - Either Text (MergedStructure (Maybe a)) -mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStructures subPlacements subWaypoints) = do - overlays <- elaboratePlacement parentPlacement $ mapM g subPlacements - let wrapPlacement (Placed z ns) = LocatedStructure (name ns) (up $ orient z) $ offset z - wrappedOverlays = map wrapPlacement $ filter (\(Placed _ ns) -> isRecognizable ns) overlays - foldrM - (overlaySingleStructure structureMap) - (MergedStructure origArea wrappedOverlays originatedWaypoints) - overlays - where - originatedWaypoints = map (Originated parentPlacement) subWaypoints - - -- deeper definitions override the outer (toplevel) ones - structureMap = M.union (M.fromList $ map (name &&& id) subStructures) inheritedStrucDefs - - g placement@(Placement sName@(StructureName n) _ orientation) = do - t@(_, ns) <- - maybeToEither - (T.unwords ["Could not look up structure", quote n]) - $ sequenceA (placement, M.lookup sName structureMap) - let placementDirection = up orientation - recognizedOrientations = recognize ns - when (isRecognizable ns) $ do - when (flipped orientation) $ - Left $ - T.unwords - [ "Placing recognizable structure" - , quote n - , "with flipped orientation is not supported." - ] - - -- Redundant orientations by rotational symmetry are accounted - -- for at scenario parse time - when (Set.notMember placementDirection recognizedOrientations) $ - Left $ - T.unwords - [ "Placing recognizable structure" - , quote n - , "with" - , renderDir placementDirection - , "orientation is not supported." - , "Try" - , commaList $ map renderDir $ Set.toList recognizedOrientations - , "instead." - ] - return $ uncurry Placed t - where - renderDir = quote . T.pack . directionJsonModifier . show - instance FromJSONE (TerrainEntityMaps, RobotMap) (PStructure (Maybe Cell)) where parseJSONE = withObjectE "structure definition" $ \v -> do pal <- v ..:? "palette" ..!= WorldPalette mempty diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Assembly.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Assembly.hs new file mode 100644 index 000000000..9098b9db6 --- /dev/null +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Assembly.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Definitions of "structures" for use within a map +-- as well as logic for combining them. +module Swarm.Game.Scenario.Topography.Structure.Assembly ( + mergeStructures, +) +where + +import Control.Applicative ((<|>)) +import Control.Arrow (left, (&&&)) +import Control.Monad (when) +import Data.Coerce +import Data.Either.Extra (maybeToEither) +import Data.Foldable (foldrM) +import Data.Map qualified as M +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Swarm.Game.Location +import Swarm.Game.Scenario.Topography.Area +import Swarm.Game.Scenario.Topography.Navigation.Waypoint +import Swarm.Game.Scenario.Topography.Placement +import Swarm.Game.Scenario.Topography.Structure +import Swarm.Language.Direction (directionJsonModifier) +import Swarm.Util (commaList, quote, showT) + +overlayGrid :: + [[Maybe a]] -> + Pose -> + [[Maybe a]] -> + [[Maybe a]] +overlayGrid inputArea (Pose (Location colOffset rowOffset) orientation) overlayArea = + zipWithPad mergeSingleRow inputArea $ paddedOverlayRows overlayArea + where + zipWithPad f a b = zipWith f a $ b <> repeat Nothing + + mergeSingleRow inputRow maybeOverlayRow = + zipWithPad (flip (<|>)) inputRow paddedSingleOverlayRow + where + paddedSingleOverlayRow = maybe [] (applyOffset colOffset) maybeOverlayRow + + affineTransformedOverlay = applyOrientationTransform orientation + + paddedOverlayRows = applyOffset (negate rowOffset) . map Just . affineTransformedOverlay + applyOffset offsetNum = modifyFront + where + integralOffset = fromIntegral offsetNum + modifyFront = + if integralOffset >= 0 + then (replicate integralOffset Nothing <>) + else drop $ abs integralOffset + +-- | Destructively overlays one direct child structure +-- upon the input structure. +-- However, the child structure is assembled recursively. +overlaySingleStructure :: + M.Map StructureName (NamedStructure (Maybe a)) -> + Placed (Maybe a) -> + MergedStructure (Maybe a) -> + Either Text (MergedStructure (Maybe a)) +overlaySingleStructure + inheritedStrucDefs + (Placed p@(Placement _ pose@(Pose loc orientation)) ns) + (MergedStructure inputArea inputPlacements inputWaypoints) = do + MergedStructure overlayArea overlayPlacements overlayWaypoints <- + mergeStructures inheritedStrucDefs (WithParent p) $ structure ns + + let mergedWaypoints = inputWaypoints <> map (fmap $ placeOnArea overlayArea) overlayWaypoints + mergedPlacements = inputPlacements <> map (placeOnArea overlayArea) overlayPlacements + mergedArea = overlayGrid inputArea pose overlayArea + + return $ MergedStructure mergedArea mergedPlacements mergedWaypoints + where + placeOnArea overArea = + offsetLoc (coerce loc) + . modifyLoc (reorientLandmark orientation $ getAreaDimensions overArea) + +elaboratePlacement :: Parentage Placement -> Either Text a -> Either Text a +elaboratePlacement p = left (elaboration <>) + where + pTxt = case p of + Root -> "root placement" + WithParent (Placement (StructureName sn) (Pose loc _)) -> + T.unwords + [ "placement of" + , quote sn + , "at" + , showT loc + ] + elaboration = + T.unwords + [ "Within" + , pTxt <> ":" + , "" + ] + +-- | Overlays all of the "child placements", such that the children encountered earlier +-- in the YAML file supersede the later ones (due to use of 'foldr' instead of 'foldl'). +mergeStructures :: + M.Map StructureName (NamedStructure (Maybe a)) -> + Parentage Placement -> + PStructure (Maybe a) -> + Either Text (MergedStructure (Maybe a)) +mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStructures subPlacements subWaypoints) = do + overlays <- elaboratePlacement parentPlacement $ mapM g subPlacements + let wrapPlacement (Placed z ns) = LocatedStructure (name ns) (up $ orient structPose) $ offset structPose + where + structPose = structurePose z + wrappedOverlays = map wrapPlacement $ filter (\(Placed _ ns) -> isRecognizable ns) overlays + foldrM + (overlaySingleStructure structureMap) + (MergedStructure origArea wrappedOverlays originatedWaypoints) + overlays + where + originatedWaypoints = map (Originated parentPlacement) subWaypoints + + -- deeper definitions override the outer (toplevel) ones + structureMap = M.union (M.fromList $ map (name &&& id) subStructures) inheritedStrucDefs + + g placement@(Placement sName@(StructureName n) (Pose _ orientation)) = do + t@(_, ns) <- + maybeToEither + (T.unwords ["Could not look up structure", quote n]) + $ sequenceA (placement, M.lookup sName structureMap) + let placementDirection = up orientation + recognizedOrientations = recognize ns + when (isRecognizable ns) $ do + when (flipped orientation) $ + Left $ + T.unwords + [ "Placing recognizable structure" + , quote n + , "with flipped orientation is not supported." + ] + + -- Redundant orientations by rotational symmetry are accounted + -- for at scenario parse time + when (Set.notMember placementDirection recognizedOrientations) $ + Left $ + T.unwords + [ "Placing recognizable structure" + , quote n + , "with" + , renderDir placementDirection + , "orientation is not supported." + , "Try" + , commaList $ map renderDir $ Set.toList recognizedOrientations + , "instead." + ] + return $ uncurry Placed t + where + renderDir = quote . T.pack . directionJsonModifier . show diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs index b8591373d..b31d9c04a 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs @@ -32,6 +32,7 @@ import Swarm.Game.Scenario.Topography.Structure ( PStructure (Structure), ) import Swarm.Game.Scenario.Topography.Structure qualified as Structure +import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly import Swarm.Game.Scenario.Topography.WorldPalette import Swarm.Game.Universe import Swarm.Game.World.Parse () @@ -91,7 +92,7 @@ instance FromJSONE WorldParseDependencies WorldDescription where MergedStructure mergedArea staticStructurePlacements unmergedWaypoints <- either (fail . T.unpack) return $ - Structure.mergeStructures mempty Root struc + Assembly.mergeStructures mempty Root struc let absoluteStructurePlacements = map (offsetLoc $ coerce upperLeft) staticStructurePlacements diff --git a/src/swarm-web/Swarm/Web.hs b/src/swarm-web/Swarm/Web.hs index e5e34267d..1c3b91e89 100644 --- a/src/swarm-web/Swarm/Web.hs +++ b/src/swarm-web/Swarm/Web.hs @@ -82,6 +82,7 @@ import Swarm.Language.Pretty (prettyTextLine) import Swarm.Language.Syntax import Swarm.TUI.Model import Swarm.TUI.Model.Goal +import Swarm.TUI.Model.Repl (REPLHistItem, replHistory, replSeq) import Swarm.TUI.Model.UI import Swarm.Util.ReadableIORef import Swarm.Util.RingBuffer diff --git a/swarm.cabal b/swarm.cabal index 73734c968..e8f964002 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -215,6 +215,7 @@ library swarm-scenario Swarm.Game.Scenario.Topography.Navigation.Waypoint Swarm.Game.Scenario.Topography.Placement Swarm.Game.Scenario.Topography.Structure + Swarm.Game.Scenario.Topography.Structure.Assembly Swarm.Game.Scenario.Topography.Structure.Recognition Swarm.Game.Scenario.Topography.Structure.Recognition.Log Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute