{-# 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 where

import Control.Applicative ((<|>))
import Control.Arrow ((&&&))
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Coerce
import Data.Map qualified as M
import Data.Maybe (catMaybes, mapMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Yaml as Y
import Swarm.Game.Entity
import Swarm.Game.Location
import Swarm.Game.Scenario.RobotLookup
import Swarm.Game.Scenario.Topography.Area
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.Util (failT, showT)
import Swarm.Util.Yaml
import Witch (into)

data NamedStructure c = NamedStructure
  { forall c. NamedStructure c -> StructureName
name :: StructureName
  , forall c. NamedStructure c -> PStructure c
structure :: PStructure c
  }
  deriving (NamedStructure c -> NamedStructure c -> Bool
forall c. Eq c => NamedStructure c -> NamedStructure c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NamedStructure c -> NamedStructure c -> Bool
$c/= :: forall c. Eq c => NamedStructure c -> NamedStructure c -> Bool
== :: NamedStructure c -> NamedStructure c -> Bool
$c== :: forall c. Eq c => NamedStructure c -> NamedStructure c -> Bool
Eq, Int -> NamedStructure c -> ShowS
forall c. Show c => Int -> NamedStructure c -> ShowS
forall c. Show c => [NamedStructure c] -> ShowS
forall c. Show c => NamedStructure c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NamedStructure c] -> ShowS
$cshowList :: forall c. Show c => [NamedStructure c] -> ShowS
show :: NamedStructure c -> String
$cshow :: forall c. Show c => NamedStructure c -> String
showsPrec :: Int -> NamedStructure c -> ShowS
$cshowsPrec :: forall c. Show c => Int -> NamedStructure c -> ShowS
Show)

type InheritedStructureDefs = [NamedStructure (Maybe (PCell Entity))]

instance FromJSONE (EntityMap, RobotMap) (NamedStructure (Maybe (PCell Entity))) where
  parseJSONE :: Value
-> ParserE
     (EntityMap, RobotMap) (NamedStructure (Maybe (PCell Entity)))
parseJSONE = forall e a.
String -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE String
"named structure" forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    forall c. StructureName -> PStructure c -> NamedStructure c
NamedStructure
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v
        forall e a. FromJSONE e a => Object -> Text -> ParserE e a
..: Text
"structure"

data PStructure c = Structure
  { forall c. PStructure c -> [[c]]
area :: [[c]]
  , forall c. PStructure c -> [NamedStructure c]
structures :: [NamedStructure c]
  -- ^ structure definitions from parents shall be accessible by children
  , forall c. PStructure c -> [Placement]
placements :: [Placement]
  -- ^ earlier placements will be overlaid on top of later placements in the YAML file
  , forall c. PStructure c -> [Waypoint]
waypoints :: [Waypoint]
  }
  deriving (PStructure c -> PStructure c -> Bool
forall c. Eq c => PStructure c -> PStructure c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PStructure c -> PStructure c -> Bool
$c/= :: forall c. Eq c => PStructure c -> PStructure c -> Bool
== :: PStructure c -> PStructure c -> Bool
$c== :: forall c. Eq c => PStructure c -> PStructure c -> Bool
Eq, Int -> PStructure c -> ShowS
forall c. Show c => Int -> PStructure c -> ShowS
forall c. Show c => [PStructure c] -> ShowS
forall c. Show c => PStructure c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PStructure c] -> ShowS
$cshowList :: forall c. Show c => [PStructure c] -> ShowS
show :: PStructure c -> String
$cshow :: forall c. Show c => PStructure c -> String
showsPrec :: Int -> PStructure c -> ShowS
$cshowsPrec :: forall c. Show c => Int -> PStructure c -> ShowS
Show)

data MergedStructure c = MergedStructure [[c]] [Originated Waypoint]

-- | Destructively overlays one direct child structure
-- upon the input structure.
-- However, the child structure is assembled recursively.
overlaySingleStructure ::
  M.Map StructureName (PStructure (Maybe a)) ->
  (Placement, PStructure (Maybe a)) ->
  MergedStructure (Maybe a) ->
  MergedStructure (Maybe a)
overlaySingleStructure :: forall a.
Map StructureName (PStructure (Maybe a))
-> (Placement, PStructure (Maybe a))
-> MergedStructure (Maybe a)
-> MergedStructure (Maybe a)
overlaySingleStructure
  Map StructureName (PStructure (Maybe a))
inheritedStrucDefs
  (p :: Placement
p@(Placement StructureName
_ loc :: Location
loc@(Location Int32
colOffset Int32
rowOffset) Orientation
orientation), PStructure (Maybe a)
struc)
  (MergedStructure [[Maybe a]]
inputArea [Originated Waypoint]
inputWaypoints) =
    forall c. [[c]] -> [Originated Waypoint] -> MergedStructure c
MergedStructure [[Maybe a]]
mergedArea [Originated Waypoint]
mergedWaypoints
   where
    mergedArea :: [[Maybe a]]
mergedArea = forall {a} {a} {c}. (a -> Maybe a -> c) -> [a] -> [Maybe a] -> [c]
zipWithPad forall {a}. [Maybe a] -> Maybe [Maybe a] -> [Maybe a]
mergeSingleRow [[Maybe a]]
inputArea [Maybe [Maybe a]]
paddedOverlayRows

    placeWaypoint :: Waypoint -> Waypoint
placeWaypoint =
      V2 Int32 -> Waypoint -> Waypoint
offsetWaypoint (coerce :: forall a b. Coercible a b => a -> b
coerce Location
loc)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Location -> Location) -> Waypoint -> Waypoint
modifyLocation (Orientation -> AreaDimensions -> Location -> Location
reorientWaypoint Orientation
orientation forall a b. (a -> b) -> a -> b
$ forall a. [[a]] -> AreaDimensions
getAreaDimensions [[Maybe a]]
overlayArea)
    mergedWaypoints :: [Originated Waypoint]
mergedWaypoints = [Originated Waypoint]
inputWaypoints forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Waypoint -> Waypoint
placeWaypoint) [Originated Waypoint]
overlayWaypoints

    zipWithPad :: (a -> Maybe a -> c) -> [a] -> [Maybe a] -> [c]
zipWithPad a -> Maybe a -> c
f [a]
a [Maybe a]
b = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> Maybe a -> c
f [a]
a forall a b. (a -> b) -> a -> b
$ [Maybe a]
b forall a. Semigroup a => a -> a -> a
<> forall a. a -> [a]
repeat forall a. Maybe a
Nothing

    MergedStructure [[Maybe a]]
overlayArea [Originated Waypoint]
overlayWaypoints = forall a.
Map StructureName (PStructure (Maybe a))
-> Maybe Placement
-> PStructure (Maybe a)
-> MergedStructure (Maybe a)
mergeStructures Map StructureName (PStructure (Maybe a))
inheritedStrucDefs (forall a. a -> Maybe a
Just Placement
p) PStructure (Maybe a)
struc
    affineTransformedOverlay :: [[Maybe a]]
affineTransformedOverlay = forall a. Orientation -> [[a]] -> [[a]]
applyOrientationTransform Orientation
orientation [[Maybe a]]
overlayArea

    mergeSingleRow :: [Maybe a] -> Maybe [Maybe a] -> [Maybe a]
mergeSingleRow [Maybe a]
inputRow Maybe [Maybe a]
maybeOverlayRow =
      forall {a} {a} {c}. (a -> Maybe a -> c) -> [a] -> [Maybe a] -> [c]
zipWithPad (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)) [Maybe a]
inputRow [Maybe a]
paddedSingleOverlayRow
     where
      paddedSingleOverlayRow :: [Maybe a]
paddedSingleOverlayRow = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall {p} {a}. Integral p => p -> [Maybe a] -> [Maybe a]
applyOffset Int32
colOffset) Maybe [Maybe a]
maybeOverlayRow

    paddedOverlayRows :: [Maybe [Maybe a]]
paddedOverlayRows = forall {p} {a}. Integral p => p -> [Maybe a] -> [Maybe a]
applyOffset (forall a. Num a => a -> a
negate Int32
rowOffset) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [[Maybe a]]
affineTransformedOverlay
    applyOffset :: p -> [Maybe a] -> [Maybe a]
applyOffset p
offsetNum = forall {a}. [Maybe a] -> [Maybe a]
modifyFront
     where
      integralOffset :: Int
integralOffset = forall a b. (Integral a, Num b) => a -> b
fromIntegral p
offsetNum
      modifyFront :: [Maybe a] -> [Maybe a]
modifyFront =
        if Int
integralOffset forall a. Ord a => a -> a -> Bool
>= Int
0
          then (forall a. Int -> a -> [a]
replicate Int
integralOffset forall a. Maybe a
Nothing forall a. Semigroup a => a -> a -> a
<>)
          else forall a. Int -> [a] -> [a]
drop forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
abs Int
integralOffset

-- | 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 (PStructure (Maybe a)) ->
  Maybe Placement ->
  PStructure (Maybe a) ->
  MergedStructure (Maybe a)
mergeStructures :: forall a.
Map StructureName (PStructure (Maybe a))
-> Maybe Placement
-> PStructure (Maybe a)
-> MergedStructure (Maybe a)
mergeStructures Map StructureName (PStructure (Maybe a))
inheritedStrucDefs Maybe Placement
parentPlacement (Structure [[Maybe a]]
origArea [NamedStructure (Maybe a)]
subStructures [Placement]
subPlacements [Waypoint]
subWaypoints) =
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a.
Map StructureName (PStructure (Maybe a))
-> (Placement, PStructure (Maybe a))
-> MergedStructure (Maybe a)
-> MergedStructure (Maybe a)
overlaySingleStructure Map StructureName (PStructure (Maybe a))
structureMap) (forall c. [[c]] -> [Originated Waypoint] -> MergedStructure c
MergedStructure [[Maybe a]]
origArea [Originated Waypoint]
originatedWaypoints) [(Placement, PStructure (Maybe a))]
overlays
 where
  originatedWaypoints :: [Originated Waypoint]
originatedWaypoints = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Maybe Placement -> a -> Originated a
Originated Maybe Placement
parentPlacement) [Waypoint]
subWaypoints

  -- deeper definitions override the outer (toplevel) ones
  structureMap :: Map StructureName (PStructure (Maybe a))
structureMap = forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall c. NamedStructure c -> StructureName
name forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall c. NamedStructure c -> PStructure c
structure) [NamedStructure (Maybe a)]
subStructures) Map StructureName (PStructure (Maybe a))
inheritedStrucDefs
  overlays :: [(Placement, PStructure (Maybe a))]
overlays = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Placement -> Maybe (Placement, PStructure (Maybe a))
g [Placement]
subPlacements
  g :: Placement -> Maybe (Placement, PStructure (Maybe a))
g placement :: Placement
placement@(Placement StructureName
sName Location
_ Orientation
_) =
    forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (Placement
placement, forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup StructureName
sName Map StructureName (PStructure (Maybe a))
structureMap)

instance FromJSONE (EntityMap, RobotMap) (PStructure (Maybe (PCell Entity))) where
  parseJSONE :: Value
-> ParserE
     (EntityMap, RobotMap) (PStructure (Maybe (PCell Entity)))
parseJSONE = forall e a.
String -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE String
"structure definition" forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    WorldPalette Entity
pal <- Object
v forall e a. FromJSONE e a => Object -> Text -> ParserE e (Maybe a)
..:? Text
"palette" forall (f :: * -> *) a. Functor f => f (Maybe a) -> a -> f a
..!= forall e. KeyMap (AugmentedCell e) -> WorldPalette e
WorldPalette forall a. Monoid a => a
mempty
    [NamedStructure (Maybe (PCell Entity))]
localStructureDefs <- Object
v forall e a. FromJSONE e a => Object -> Text -> ParserE e (Maybe a)
..:? Text
"structures" forall (f :: * -> *) a. Functor f => f (Maybe a) -> a -> f a
..!= []
    [Placement]
placementDefs <- forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE forall a b. (a -> b) -> a -> b
$ Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"placements" forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    [Waypoint]
waypointDefs <- forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE forall a b. (a -> b) -> a -> b
$ Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"waypoints" forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    Maybe Char
maybeMaskChar <- forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE forall a b. (a -> b) -> a -> b
$ Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"mask"
    ([[Maybe (PCell Entity)]]
maskedArea, [Waypoint]
mapWaypoints) <- forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE forall a b. (a -> b) -> a -> b
$ (Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"map" forall a. Parser (Maybe a) -> a -> Parser a
.!= Text
"") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) e.
MonadFail m =>
Maybe Char
-> WorldPalette e -> Text -> m ([[Maybe (PCell e)]], [Waypoint])
paintMap Maybe Char
maybeMaskChar WorldPalette Entity
pal
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c.
[[c]]
-> [NamedStructure c] -> [Placement] -> [Waypoint] -> PStructure c
Structure [[Maybe (PCell Entity)]]
maskedArea [NamedStructure (Maybe (PCell Entity))]
localStructureDefs [Placement]
placementDefs forall a b. (a -> b) -> a -> b
$ [Waypoint]
waypointDefs forall a. Semigroup a => a -> a -> a
<> [Waypoint]
mapWaypoints

-- | \"Paint\" a world map using a 'WorldPalette', turning it from a raw
--   string into a nested list of 'PCell' values by looking up each
--   character in the palette, failing if any character in the raw map
--   is not contained in the palette.
paintMap ::
  MonadFail m =>
  Maybe Char ->
  WorldPalette e ->
  Text ->
  m ([[Maybe (PCell e)]], [Waypoint])
paintMap :: forall (m :: * -> *) e.
MonadFail m =>
Maybe Char
-> WorldPalette e -> Text -> m ([[Maybe (PCell e)]], [Waypoint])
paintMap Maybe Char
maskChar WorldPalette e
pal Text
a = do
  [[Maybe (AugmentedCell e)]]
nestedLists <- forall (f :: * -> *) b.
Applicative f =>
(Char -> f b) -> Text -> f [[b]]
readMap forall {m :: * -> *}.
MonadFail m =>
Char -> m (Maybe (AugmentedCell e))
toCell Text
a
  let cells :: [[Maybe (PCell e)]]
cells = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. AugmentedCell e -> PCell e
standardCell) [[Maybe (AugmentedCell e)]]
nestedLists
      f :: Int32 -> Int32 -> Maybe (AugmentedCell e) -> Maybe Waypoint
f Int32
i Int32
j Maybe (AugmentedCell e)
maybeAugmentedCell = do
        WaypointConfig
wpCfg <- forall e. AugmentedCell e -> Maybe WaypointConfig
waypointCfg forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (AugmentedCell e)
maybeAugmentedCell
        forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. WaypointConfig -> Location -> Waypoint
Waypoint WaypointConfig
wpCfg forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int32 -> Location
Location Int32
j forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
negate Int32
i
      wps :: [Waypoint]
wps = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int32
i -> forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall {e}.
Int32 -> Int32 -> Maybe (AugmentedCell e) -> Maybe Waypoint
f Int32
i) [Int32
0 ..]) [Int32
0 ..] [[Maybe (AugmentedCell e)]]
nestedLists

  forall (m :: * -> *) a. Monad m => a -> m a
return ([[Maybe (PCell e)]]
cells, [Waypoint]
wps)
 where
  toCell :: Char -> m (Maybe (AugmentedCell e))
toCell Char
c =
    if forall a. a -> Maybe a
Just Char
c forall a. Eq a => a -> a -> Bool
== Maybe Char
maskChar
      then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      else case forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (String -> Key
Key.fromString [Char
c]) (forall e. WorldPalette e -> KeyMap (AugmentedCell e)
unPalette WorldPalette e
pal) of
        Maybe (AugmentedCell e)
Nothing -> forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT [Text
"Char not in world palette:", forall a. Show a => a -> Text
showT Char
c]
        Just AugmentedCell e
cell -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just AugmentedCell e
cell

readMap :: Applicative f => (Char -> f b) -> Text -> f [[b]]
readMap :: forall (f :: * -> *) b.
Applicative f =>
(Char -> f b) -> Text -> f [[b]]
readMap Char -> f b
func = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Char -> f b
func forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall target source. From source target => source -> target
into @String) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines