reorganize code in Assembly.hs (#1829)

This does two main things to simplify the review of #1826:
* Add the `truncate` option to structure placement.  By default it shall be `true` to maintain the status quo behavior
* Extract a `validatePlacement` function to improve readability

data/schema/placement.json

@@ -10,6 +10,10 @@
             "type": "string",
             "description": "Name of structure definition"
         },
+        "truncate": {
+            "type": "boolean",
+            "description": "Overlay should be truncated if it exceeds bounds of target structure"
+        },
         "offset": {
             "$ref": "planar-loc.json"
         },

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

@@ -75,15 +75,17 @@ data Pose = Pose
 
 data Placement = Placement
   { src :: StructureName
+  , truncateOverlay :: Bool
   , structurePose :: Pose
   }
   deriving (Eq, Show)
 
 instance FromJSON Placement where
   parseJSON = withObject "structure placement" $ \v -> do
     sName <- v .: "src"
+    shouldTruncate <- v .:? "truncate" .!= True
     p <-
       Pose
         <$> v .:? "offset" .!= origin
         <*> v .:? "orient" .!= defaultOrientation
-    return $ Placement sName p
+    return $ Placement sName shouldTruncate p

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

@@ -28,32 +28,6 @@ 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.
@@ -64,7 +38,7 @@ overlaySingleStructure ::
   Either Text (MergedStructure (Maybe a))
 overlaySingleStructure
   inheritedStrucDefs
-  (Placed p@(Placement _ pose@(Pose loc orientation)) ns)
+  (Placed p@(Placement _ _shouldTruncate pose@(Pose loc orientation)) ns)
   (MergedStructure inputArea inputPlacements inputWaypoints) = do
     MergedStructure overlayArea overlayPlacements overlayWaypoints <-
       mergeStructures inheritedStrucDefs (WithParent p) $ structure ns
@@ -79,25 +53,6 @@ overlaySingleStructure
       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 ::
@@ -106,11 +61,22 @@ mergeStructures ::
   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
+  overlays <-
+    left (elaboratePlacement parentPlacement <>) $
+      mapM (validatePlacement structureMap) 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
+
+      wrappedOverlays =
+        map wrapPlacement $
+          filter (\(Placed _ ns) -> isRecognizable ns) overlays
+
   foldrM
     (overlaySingleStructure structureMap)
     (MergedStructure origArea wrappedOverlays originatedWaypoints)
@@ -119,15 +85,74 @@ mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStruct
   originatedWaypoints = map (Originated parentPlacement) subWaypoints
 
   -- deeper definitions override the outer (toplevel) ones
-  structureMap = M.union (M.fromList $ map (name &&& id) subStructures) inheritedStrucDefs
+  structureMap =
+    M.union
+      (M.fromList $ map (name &&& id) subStructures)
+      inheritedStrucDefs
+
+-- * Grid manipulation
 
-  g placement@(Placement sName@(StructureName n) (Pose _ orientation)) = do
+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
+
+-- * Validation
+
+elaboratePlacement :: Parentage Placement -> Text
+elaboratePlacement p =
+  T.unwords
+    [ "Within"
+    , pTxt <> ":"
+    , ""
+    ]
+ where
+  pTxt = case p of
+    Root -> "root placement"
+    WithParent (Placement (StructureName sn) _shouldTruncate (Pose loc _)) ->
+      T.unwords
+        [ "placement of"
+        , quote sn
+        , "at"
+        , showT loc
+        ]
+
+validatePlacement ::
+  M.Map StructureName (NamedStructure (Maybe a)) ->
+  Placement ->
+  Either Text (Placed (Maybe a))
+validatePlacement
+  structureMap
+  placement@(Placement sName@(StructureName n) _shouldTruncate (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 $