{-# 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.Arrow (left, (&&&))
import Control.Monad (when)
import Data.Coerce
import Data.Either.Extra (maybeToEither)
import Data.Foldable (foldlM)
import Data.Map qualified as M
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Linear.Affine
import Swarm.Game.Location
import Swarm.Game.Scenario.Topography.Area
import Swarm.Game.Scenario.Topography.Grid
import Swarm.Game.Scenario.Topography.Navigation.Waypoint
import Swarm.Game.Scenario.Topography.Placement
import Swarm.Game.Scenario.Topography.Structure
import Swarm.Game.Scenario.Topography.Structure.Overlay
import Swarm.Language.Syntax.Direction (directionJsonModifier)
import Swarm.Util (commaList, quote, showT)

-- | 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 :: forall a.
Map StructureName (NamedStructure (Maybe a))
-> Placed (Maybe a)
-> MergedStructure (Maybe a)
-> Either Text (MergedStructure (Maybe a))
overlaySingleStructure
  Map StructureName (NamedStructure (Maybe a))
inheritedStrucDefs
  (Placed p :: Placement
p@(Placement StructureName
_ pose :: Pose
pose@(Pose Location
loc Orientation
orientation)) NamedStructure (Maybe a)
ns)
  (MergedStructure PositionedGrid (Maybe a)
inputArea [LocatedStructure]
inputPlacements [Originated Waypoint]
inputWaypoints) = do
    MergedStructure PositionedGrid (Maybe a)
overlayArea [LocatedStructure]
overlayPlacements [Originated Waypoint]
overlayWaypoints <-
      Map StructureName (NamedStructure (Maybe a))
-> Parentage Placement
-> PStructure (Maybe a)
-> Either Text (MergedStructure (Maybe a))
forall a.
Map StructureName (NamedStructure (Maybe a))
-> Parentage Placement
-> PStructure (Maybe a)
-> Either Text (MergedStructure (Maybe a))
mergeStructures Map StructureName (NamedStructure (Maybe a))
inheritedStrucDefs (Placement -> Parentage Placement
forall a. a -> Parentage a
WithParent Placement
p) (PStructure (Maybe a) -> Either Text (MergedStructure (Maybe a)))
-> PStructure (Maybe a) -> Either Text (MergedStructure (Maybe a))
forall a b. (a -> b) -> a -> b
$ NamedStructure (Maybe a) -> PStructure (Maybe a)
forall a. NamedArea a -> a
structure NamedStructure (Maybe a)
ns

    let mergedWaypoints :: [Originated Waypoint]
mergedWaypoints = [Originated Waypoint]
inputWaypoints [Originated Waypoint]
-> [Originated Waypoint] -> [Originated Waypoint]
forall a. Semigroup a => a -> a -> a
<> (Originated Waypoint -> Originated Waypoint)
-> [Originated Waypoint] -> [Originated Waypoint]
forall a b. (a -> b) -> [a] -> [b]
map ((Waypoint -> Waypoint)
-> Originated Waypoint -> Originated Waypoint
forall a b. (a -> b) -> Originated a -> Originated b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Waypoint -> Waypoint)
 -> Originated Waypoint -> Originated Waypoint)
-> (Waypoint -> Waypoint)
-> Originated Waypoint
-> Originated Waypoint
forall a b. (a -> b) -> a -> b
$ PositionedGrid (Maybe a) -> Waypoint -> Waypoint
forall {c} {a}. HasLocation c => PositionedGrid a -> c -> c
placeOnArea PositionedGrid (Maybe a)
overlayArea) [Originated Waypoint]
overlayWaypoints
        mergedPlacements :: [LocatedStructure]
mergedPlacements = [LocatedStructure]
inputPlacements [LocatedStructure] -> [LocatedStructure] -> [LocatedStructure]
forall a. Semigroup a => a -> a -> a
<> (LocatedStructure -> LocatedStructure)
-> [LocatedStructure] -> [LocatedStructure]
forall a b. (a -> b) -> [a] -> [b]
map (PositionedGrid (Maybe a) -> LocatedStructure -> LocatedStructure
forall {c} {a}. HasLocation c => PositionedGrid a -> c -> c
placeOnArea PositionedGrid (Maybe a)
overlayArea) [LocatedStructure]
overlayPlacements
        mergedArea :: PositionedGrid (Maybe a)
mergedArea = Grid (Maybe a)
-> Pose -> PositionedGrid (Maybe a) -> PositionedGrid (Maybe a)
forall a.
Grid (Maybe a)
-> Pose -> PositionedGrid (Maybe a) -> PositionedGrid (Maybe a)
overlayGridExpanded (PositionedGrid (Maybe a) -> Grid (Maybe a)
forall a. PositionedGrid a -> Grid a
gridContent PositionedGrid (Maybe a)
inputArea) Pose
pose PositionedGrid (Maybe a)
overlayArea

    MergedStructure (Maybe a)
-> Either Text (MergedStructure (Maybe a))
forall a. a -> Either Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (MergedStructure (Maybe a)
 -> Either Text (MergedStructure (Maybe a)))
-> MergedStructure (Maybe a)
-> Either Text (MergedStructure (Maybe a))
forall a b. (a -> b) -> a -> b
$ PositionedGrid (Maybe a)
-> [LocatedStructure]
-> [Originated Waypoint]
-> MergedStructure (Maybe a)
forall c.
PositionedGrid c
-> [LocatedStructure] -> [Originated Waypoint] -> MergedStructure c
MergedStructure PositionedGrid (Maybe a)
mergedArea [LocatedStructure]
mergedPlacements [Originated Waypoint]
mergedWaypoints
   where
    placeOnArea :: PositionedGrid a -> c -> c
placeOnArea (PositionedGrid Location
_ Grid a
overArea) =
      V2 Int32 -> c -> c
forall a. HasLocation a => V2 Int32 -> a -> a
offsetLoc (Location -> V2 Int32
forall a b. Coercible a b => a -> b
coerce Location
loc)
        (c -> c) -> (c -> c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Location -> Location) -> c -> c
forall a. HasLocation a => (Location -> Location) -> a -> a
modifyLoc (Orientation -> AreaDimensions -> Location -> Location
reorientLandmark Orientation
orientation (AreaDimensions -> Location -> Location)
-> AreaDimensions -> Location -> Location
forall a b. (a -> b) -> a -> b
$ Grid a -> AreaDimensions
forall a. Grid a -> AreaDimensions
getGridDimensions Grid a
overArea)

-- | Overlays all of the "child placements", such that the children encountered later
-- in the YAML file supersede the earlier ones (dictated by using 'foldl' instead of 'foldr').
mergeStructures ::
  M.Map StructureName (NamedStructure (Maybe a)) ->
  Parentage Placement ->
  PStructure (Maybe a) ->
  Either Text (MergedStructure (Maybe a))
mergeStructures :: forall a.
Map StructureName (NamedStructure (Maybe a))
-> Parentage Placement
-> PStructure (Maybe a)
-> Either Text (MergedStructure (Maybe a))
mergeStructures Map StructureName (NamedStructure (Maybe a))
inheritedStrucDefs Parentage Placement
parentPlacement (Structure PositionedGrid (Maybe a)
origArea [NamedStructure (Maybe a)]
subStructures [Placement]
subPlacements [Waypoint]
subWaypoints) = do
  [Placed (Maybe a)]
overlays <-
    (Text -> Text)
-> Either Text [Placed (Maybe a)] -> Either Text [Placed (Maybe a)]
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (Parentage Placement -> Text
elaboratePlacement Parentage Placement
parentPlacement Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Either Text [Placed (Maybe a)] -> Either Text [Placed (Maybe a)])
-> Either Text [Placed (Maybe a)] -> Either Text [Placed (Maybe a)]
forall a b. (a -> b) -> a -> b
$
      (Placement -> Either Text (Placed (Maybe a)))
-> [Placement] -> Either Text [Placed (Maybe a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Map StructureName (NamedStructure (Maybe a))
-> Placement -> Either Text (Placed (Maybe a))
forall a.
Map StructureName (NamedStructure (Maybe a))
-> Placement -> Either Text (Placed (Maybe a))
validatePlacement Map StructureName (NamedStructure (Maybe a))
structureMap) [Placement]
subPlacements

  let wrapPlacement :: Placed c -> LocatedStructure
wrapPlacement (Placed Placement
z NamedStructure c
ns) =
        StructureName -> AbsoluteDir -> Location -> LocatedStructure
LocatedStructure
          (NamedStructure c -> StructureName
forall a. NamedArea a -> StructureName
name NamedStructure c
ns)
          (Orientation -> AbsoluteDir
up (Orientation -> AbsoluteDir) -> Orientation -> AbsoluteDir
forall a b. (a -> b) -> a -> b
$ Pose -> Orientation
orient Pose
structPose)
          (Pose -> Location
offset Pose
structPose)
       where
        structPose :: Pose
structPose = Placement -> Pose
structurePose Placement
z

      wrappedOverlays :: [LocatedStructure]
wrappedOverlays =
        (Placed (Maybe a) -> LocatedStructure)
-> [Placed (Maybe a)] -> [LocatedStructure]
forall a b. (a -> b) -> [a] -> [b]
map Placed (Maybe a) -> LocatedStructure
forall {c}. Placed c -> LocatedStructure
wrapPlacement ([Placed (Maybe a)] -> [LocatedStructure])
-> [Placed (Maybe a)] -> [LocatedStructure]
forall a b. (a -> b) -> a -> b
$
          (Placed (Maybe a) -> Bool)
-> [Placed (Maybe a)] -> [Placed (Maybe a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Placed Placement
_ NamedStructure (Maybe a)
ns) -> NamedStructure (Maybe a) -> Bool
forall a. NamedArea a -> Bool
isRecognizable NamedStructure (Maybe a)
ns) [Placed (Maybe a)]
overlays

  (MergedStructure (Maybe a)
 -> Placed (Maybe a) -> Either Text (MergedStructure (Maybe a)))
-> MergedStructure (Maybe a)
-> [Placed (Maybe a)]
-> Either Text (MergedStructure (Maybe a))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
    ((Placed (Maybe a)
 -> MergedStructure (Maybe a)
 -> Either Text (MergedStructure (Maybe a)))
-> MergedStructure (Maybe a)
-> Placed (Maybe a)
-> Either Text (MergedStructure (Maybe a))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Placed (Maybe a)
  -> MergedStructure (Maybe a)
  -> Either Text (MergedStructure (Maybe a)))
 -> MergedStructure (Maybe a)
 -> Placed (Maybe a)
 -> Either Text (MergedStructure (Maybe a)))
-> (Placed (Maybe a)
    -> MergedStructure (Maybe a)
    -> Either Text (MergedStructure (Maybe a)))
-> MergedStructure (Maybe a)
-> Placed (Maybe a)
-> Either Text (MergedStructure (Maybe a))
forall a b. (a -> b) -> a -> b
$ Map StructureName (NamedStructure (Maybe a))
-> Placed (Maybe a)
-> MergedStructure (Maybe a)
-> Either Text (MergedStructure (Maybe a))
forall a.
Map StructureName (NamedStructure (Maybe a))
-> Placed (Maybe a)
-> MergedStructure (Maybe a)
-> Either Text (MergedStructure (Maybe a))
overlaySingleStructure Map StructureName (NamedStructure (Maybe a))
structureMap)
    (PositionedGrid (Maybe a)
-> [LocatedStructure]
-> [Originated Waypoint]
-> MergedStructure (Maybe a)
forall c.
PositionedGrid c
-> [LocatedStructure] -> [Originated Waypoint] -> MergedStructure c
MergedStructure PositionedGrid (Maybe a)
origArea [LocatedStructure]
wrappedOverlays [Originated Waypoint]
originatedWaypoints)
    [Placed (Maybe a)]
overlays
 where
  originatedWaypoints :: [Originated Waypoint]
originatedWaypoints = (Waypoint -> Originated Waypoint)
-> [Waypoint] -> [Originated Waypoint]
forall a b. (a -> b) -> [a] -> [b]
map (Parentage Placement -> Waypoint -> Originated Waypoint
forall a. Parentage Placement -> a -> Originated a
Originated Parentage Placement
parentPlacement) [Waypoint]
subWaypoints

  -- deeper definitions override the outer (toplevel) ones
  structureMap :: Map StructureName (NamedStructure (Maybe a))
structureMap =
    Map StructureName (NamedStructure (Maybe a))
-> Map StructureName (NamedStructure (Maybe a))
-> Map StructureName (NamedStructure (Maybe a))
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union
      ([(StructureName, NamedStructure (Maybe a))]
-> Map StructureName (NamedStructure (Maybe a))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(StructureName, NamedStructure (Maybe a))]
 -> Map StructureName (NamedStructure (Maybe a)))
-> [(StructureName, NamedStructure (Maybe a))]
-> Map StructureName (NamedStructure (Maybe a))
forall a b. (a -> b) -> a -> b
$ (NamedStructure (Maybe a)
 -> (StructureName, NamedStructure (Maybe a)))
-> [NamedStructure (Maybe a)]
-> [(StructureName, NamedStructure (Maybe a))]
forall a b. (a -> b) -> [a] -> [b]
map (NamedStructure (Maybe a) -> StructureName
forall a. NamedArea a -> StructureName
name (NamedStructure (Maybe a) -> StructureName)
-> (NamedStructure (Maybe a) -> NamedStructure (Maybe a))
-> NamedStructure (Maybe a)
-> (StructureName, NamedStructure (Maybe a))
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& NamedStructure (Maybe a) -> NamedStructure (Maybe a)
forall a. a -> a
id) [NamedStructure (Maybe a)]
subStructures)
      Map StructureName (NamedStructure (Maybe a))
inheritedStrucDefs

-- * Grid manipulation

overlayGridExpanded ::
  Grid (Maybe a) ->
  Pose ->
  PositionedGrid (Maybe a) ->
  PositionedGrid (Maybe a)
overlayGridExpanded :: forall a.
Grid (Maybe a)
-> Pose -> PositionedGrid (Maybe a) -> PositionedGrid (Maybe a)
overlayGridExpanded
  Grid (Maybe a)
inputGrid
  (Pose Location
loc Orientation
orientation)
  (PositionedGrid Location
_ Grid (Maybe a)
overlayArea) =
    Location -> Grid (Maybe a) -> PositionedGrid (Maybe a)
forall a. Location -> Grid a -> PositionedGrid a
PositionedGrid Location
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin Grid (Maybe a)
inputGrid PositionedGrid (Maybe a)
-> PositionedGrid (Maybe a) -> PositionedGrid (Maybe a)
forall a. Semigroup a => a -> a -> a
<> PositionedGrid (Maybe a)
positionedOverlay
   where
    reorientedOverlayCells :: Grid (Maybe a)
reorientedOverlayCells = Orientation -> Grid (Maybe a) -> Grid (Maybe a)
forall a. Orientation -> Grid a -> Grid a
applyOrientationTransform Orientation
orientation Grid (Maybe a)
overlayArea
    positionedOverlay :: PositionedGrid (Maybe a)
positionedOverlay = Location -> Grid (Maybe a) -> PositionedGrid (Maybe a)
forall a. Location -> Grid a -> PositionedGrid a
PositionedGrid Location
loc Grid (Maybe a)
reorientedOverlayCells

-- * Validation

elaboratePlacement :: Parentage Placement -> Text
elaboratePlacement :: Parentage Placement -> Text
elaboratePlacement Parentage Placement
p =
  [Text] -> Text
T.unwords
    [ Text
"Within"
    , Text
pTxt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":"
    , Text
""
    ]
 where
  pTxt :: Text
pTxt = case Parentage Placement
p of
    Parentage Placement
Root -> Text
"root placement"
    WithParent (Placement (StructureName Text
sn) (Pose Location
loc Orientation
_)) ->
      [Text] -> Text
T.unwords
        [ Text
"placement of"
        , Text -> Text
quote Text
sn
        , Text
"at"
        , Location -> Text
forall a. Show a => a -> Text
showT Location
loc
        ]

validatePlacement ::
  M.Map StructureName (NamedStructure (Maybe a)) ->
  Placement ->
  Either Text (Placed (Maybe a))
validatePlacement :: forall a.
Map StructureName (NamedStructure (Maybe a))
-> Placement -> Either Text (Placed (Maybe a))
validatePlacement
  Map StructureName (NamedStructure (Maybe a))
structureMap
  placement :: Placement
placement@(Placement sName :: StructureName
sName@(StructureName Text
n) (Pose Location
_ Orientation
orientation)) = do
    t :: (Placement, NamedStructure (Maybe a))
t@(Placement
_, NamedStructure (Maybe a)
ns) <-
      Text
-> Maybe (Placement, NamedStructure (Maybe a))
-> Either Text (Placement, NamedStructure (Maybe a))
forall a b. a -> Maybe b -> Either a b
maybeToEither
        ([Text] -> Text
T.unwords [Text
"Could not look up structure", Text -> Text
quote Text
n])
        (Maybe (Placement, NamedStructure (Maybe a))
 -> Either Text (Placement, NamedStructure (Maybe a)))
-> Maybe (Placement, NamedStructure (Maybe a))
-> Either Text (Placement, NamedStructure (Maybe a))
forall a b. (a -> b) -> a -> b
$ (Placement, Maybe (NamedStructure (Maybe a)))
-> Maybe (Placement, NamedStructure (Maybe a))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
(Placement, f a) -> f (Placement, a)
sequenceA (Placement
placement, StructureName
-> Map StructureName (NamedStructure (Maybe a))
-> Maybe (NamedStructure (Maybe a))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup StructureName
sName Map StructureName (NamedStructure (Maybe a))
structureMap)

    let placementDirection :: AbsoluteDir
placementDirection = Orientation -> AbsoluteDir
up Orientation
orientation
        recognizedOrientations :: Set AbsoluteDir
recognizedOrientations = NamedStructure (Maybe a) -> Set AbsoluteDir
forall a. NamedArea a -> Set AbsoluteDir
recognize NamedStructure (Maybe a)
ns

    Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NamedStructure (Maybe a) -> Bool
forall a. NamedArea a -> Bool
isRecognizable NamedStructure (Maybe a)
ns) (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$ do
      Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Orientation -> Bool
flipped Orientation
orientation) (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$
        Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$
          [Text] -> Text
T.unwords
            [ Text
"Placing recognizable structure"
            , Text -> Text
quote Text
n
            , Text
"with flipped orientation is not supported."
            ]

      -- Redundant orientations by rotational symmetry are accounted
      -- for at scenario parse time
      Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AbsoluteDir -> Set AbsoluteDir -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember AbsoluteDir
placementDirection Set AbsoluteDir
recognizedOrientations) (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$
        Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$
          [Text] -> Text
T.unwords
            [ Text
"Placing recognizable structure"
            , Text -> Text
quote Text
n
            , Text
"with"
            , AbsoluteDir -> Text
renderDir AbsoluteDir
placementDirection
            , Text
"orientation is not supported."
            , Text
"Try"
            , [Text] -> Text
commaList ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (AbsoluteDir -> Text) -> [AbsoluteDir] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map AbsoluteDir -> Text
renderDir ([AbsoluteDir] -> [Text]) -> [AbsoluteDir] -> [Text]
forall a b. (a -> b) -> a -> b
$ Set AbsoluteDir -> [AbsoluteDir]
forall a. Set a -> [a]
Set.toList Set AbsoluteDir
recognizedOrientations
            , Text
"instead."
            ]
    Placed (Maybe a) -> Either Text (Placed (Maybe a))
forall a. a -> Either Text a
forall (m :: * -> *) a. Monad m => a -> m a
return (Placed (Maybe a) -> Either Text (Placed (Maybe a)))
-> Placed (Maybe a) -> Either Text (Placed (Maybe a))
forall a b. (a -> b) -> a -> b
$ (Placement -> NamedStructure (Maybe a) -> Placed (Maybe a))
-> (Placement, NamedStructure (Maybe a)) -> Placed (Maybe a)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Placement -> NamedStructure (Maybe a) -> Placed (Maybe a)
forall c. Placement -> NamedStructure c -> Placed c
Placed (Placement, NamedStructure (Maybe a))
t
   where
    renderDir :: AbsoluteDir -> Text
renderDir = Text -> Text
quote (Text -> Text) -> (AbsoluteDir -> Text) -> AbsoluteDir -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (AbsoluteDir -> String) -> AbsoluteDir -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
directionJsonModifier (String -> String)
-> (AbsoluteDir -> String) -> AbsoluteDir -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsoluteDir -> String
forall a. Show a => a -> String
show