{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- 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.Monad (unless)
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.List.NonEmpty qualified as NE
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
import Swarm.Game.Location
import Swarm.Game.Scenario.Topography.Grid
import Swarm.Game.Scenario.Topography.Navigation.Waypoint
import Swarm.Game.Scenario.Topography.Placement
import Swarm.Game.Scenario.Topography.ProtoCell
import Swarm.Game.Scenario.Topography.Structure.Overlay
import Swarm.Game.World.Coords
import Swarm.Language.Syntax.Direction (AbsoluteDir)
import Swarm.Util (failT, showT)
import Swarm.Util.Yaml

data NamedArea a = NamedArea
  { forall a. NamedArea a -> StructureName
name :: StructureName
  , forall a. NamedArea a -> Set AbsoluteDir
recognize :: Set AbsoluteDir
  -- ^ whether this structure should be registered for automatic recognition
  -- and which orientations shall be recognized.
  -- The supplied direction indicates which cardinal direction the
  -- original map's "North" has been re-oriented to.
  -- E.g., 'DWest' represents a rotation of 90 degrees counter-clockwise.
  , forall a. NamedArea a -> Maybe Text
description :: Maybe Text
  -- ^ will be UI-facing only if this is a recognizable structure
  , forall a. NamedArea a -> a
structure :: a
  }
  deriving (NamedArea a -> NamedArea a -> Bool
(NamedArea a -> NamedArea a -> Bool)
-> (NamedArea a -> NamedArea a -> Bool) -> Eq (NamedArea a)
forall a. Eq a => NamedArea a -> NamedArea a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => NamedArea a -> NamedArea a -> Bool
== :: NamedArea a -> NamedArea a -> Bool
$c/= :: forall a. Eq a => NamedArea a -> NamedArea a -> Bool
/= :: NamedArea a -> NamedArea a -> Bool
Eq, Int -> NamedArea a -> ShowS
[NamedArea a] -> ShowS
NamedArea a -> String
(Int -> NamedArea a -> ShowS)
-> (NamedArea a -> String)
-> ([NamedArea a] -> ShowS)
-> Show (NamedArea a)
forall a. Show a => Int -> NamedArea a -> ShowS
forall a. Show a => [NamedArea a] -> ShowS
forall a. Show a => NamedArea a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> NamedArea a -> ShowS
showsPrec :: Int -> NamedArea a -> ShowS
$cshow :: forall a. Show a => NamedArea a -> String
show :: NamedArea a -> String
$cshowList :: forall a. Show a => [NamedArea a] -> ShowS
showList :: [NamedArea a] -> ShowS
Show, (forall a b. (a -> b) -> NamedArea a -> NamedArea b)
-> (forall a b. a -> NamedArea b -> NamedArea a)
-> Functor NamedArea
forall a b. a -> NamedArea b -> NamedArea a
forall a b. (a -> b) -> NamedArea a -> NamedArea b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> NamedArea a -> NamedArea b
fmap :: forall a b. (a -> b) -> NamedArea a -> NamedArea b
$c<$ :: forall a b. a -> NamedArea b -> NamedArea a
<$ :: forall a b. a -> NamedArea b -> NamedArea a
Functor)

isRecognizable :: NamedArea a -> Bool
isRecognizable :: forall a. NamedArea a -> Bool
isRecognizable = Bool -> Bool
not (Bool -> Bool) -> (NamedArea a -> Bool) -> NamedArea a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set AbsoluteDir -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Set AbsoluteDir -> Bool)
-> (NamedArea a -> Set AbsoluteDir) -> NamedArea a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArea a -> Set AbsoluteDir
forall a. NamedArea a -> Set AbsoluteDir
recognize

type NamedGrid c = NamedArea (Grid c)

type NamedStructure c = NamedArea (PStructure c)

data PStructure c = Structure
  { forall c. PStructure c -> PositionedGrid c
area :: PositionedGrid 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
(PStructure c -> PStructure c -> Bool)
-> (PStructure c -> PStructure c -> Bool) -> Eq (PStructure c)
forall c. Eq c => PStructure c -> PStructure c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: PStructure c -> PStructure c -> Bool
Eq, Int -> PStructure c -> ShowS
[PStructure c] -> ShowS
PStructure c -> String
(Int -> PStructure c -> ShowS)
-> (PStructure c -> String)
-> ([PStructure c] -> ShowS)
-> Show (PStructure c)
forall c. Int -> PStructure c -> ShowS
forall c. [PStructure c] -> ShowS
forall c. PStructure c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. Int -> PStructure c -> ShowS
showsPrec :: Int -> PStructure c -> ShowS
$cshow :: forall c. PStructure c -> String
show :: PStructure c -> String
$cshowList :: forall c. [PStructure c] -> ShowS
showList :: [PStructure c] -> ShowS
Show)

data Placed c = Placed Placement (NamedStructure c)
  deriving (Int -> Placed c -> ShowS
[Placed c] -> ShowS
Placed c -> String
(Int -> Placed c -> ShowS)
-> (Placed c -> String) -> ([Placed c] -> ShowS) -> Show (Placed c)
forall c. Int -> Placed c -> ShowS
forall c. [Placed c] -> ShowS
forall c. Placed c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. Int -> Placed c -> ShowS
showsPrec :: Int -> Placed c -> ShowS
$cshow :: forall c. Placed c -> String
show :: Placed c -> String
$cshowList :: forall c. [Placed c] -> ShowS
showList :: [Placed c] -> ShowS
Show)

-- | For use in registering recognizable pre-placed structures
data LocatedStructure = LocatedStructure
  { LocatedStructure -> StructureName
placedName :: StructureName
  , LocatedStructure -> AbsoluteDir
upDirection :: AbsoluteDir
  , LocatedStructure -> Location
cornerLoc :: Location
  }
  deriving (Int -> LocatedStructure -> ShowS
[LocatedStructure] -> ShowS
LocatedStructure -> String
(Int -> LocatedStructure -> ShowS)
-> (LocatedStructure -> String)
-> ([LocatedStructure] -> ShowS)
-> Show LocatedStructure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LocatedStructure -> ShowS
showsPrec :: Int -> LocatedStructure -> ShowS
$cshow :: LocatedStructure -> String
show :: LocatedStructure -> String
$cshowList :: [LocatedStructure] -> ShowS
showList :: [LocatedStructure] -> ShowS
Show)

instance HasLocation LocatedStructure where
  modifyLoc :: (Location -> Location) -> LocatedStructure -> LocatedStructure
modifyLoc Location -> Location
f (LocatedStructure StructureName
x AbsoluteDir
y Location
originalLoc) =
    StructureName -> AbsoluteDir -> Location -> LocatedStructure
LocatedStructure StructureName
x AbsoluteDir
y (Location -> LocatedStructure) -> Location -> LocatedStructure
forall a b. (a -> b) -> a -> b
$ Location -> Location
f Location
originalLoc

data MergedStructure c = MergedStructure (PositionedGrid c) [LocatedStructure] [Originated Waypoint]

instance (FromJSONE e a) => FromJSONE e (NamedStructure (Maybe a)) where
  parseJSONE :: Value -> ParserE e (NamedStructure (Maybe a))
parseJSONE = String
-> (Object -> ParserE e (NamedStructure (Maybe a)))
-> Value
-> ParserE e (NamedStructure (Maybe a))
forall e a.
String -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE String
"named structure" ((Object -> ParserE e (NamedStructure (Maybe a)))
 -> Value -> ParserE e (NamedStructure (Maybe a)))
-> (Object -> ParserE e (NamedStructure (Maybe a)))
-> Value
-> ParserE e (NamedStructure (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    PStructure (Maybe a)
structure <- Object
v Object -> Text -> ParserE e (PStructure (Maybe a))
forall e a. FromJSONE e a => Object -> Text -> ParserE e a
..: Text
"structure"
    Parser (NamedStructure (Maybe a))
-> ParserE e (NamedStructure (Maybe a))
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser (NamedStructure (Maybe a))
 -> ParserE e (NamedStructure (Maybe a)))
-> Parser (NamedStructure (Maybe a))
-> ParserE e (NamedStructure (Maybe a))
forall a b. (a -> b) -> a -> b
$ do
      StructureName
name <- Object
v Object -> Key -> Parser StructureName
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
      Set AbsoluteDir
recognize <- Object
v Object -> Key -> Parser (Maybe (Set AbsoluteDir))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"recognize" Parser (Maybe (Set AbsoluteDir))
-> Set AbsoluteDir -> Parser (Set AbsoluteDir)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Set AbsoluteDir
forall a. Monoid a => a
mempty
      Maybe Text
description <- Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"description"
      NamedStructure (Maybe a) -> Parser (NamedStructure (Maybe a))
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedStructure (Maybe a) -> Parser (NamedStructure (Maybe a)))
-> NamedStructure (Maybe a) -> Parser (NamedStructure (Maybe a))
forall a b. (a -> b) -> a -> b
$ NamedArea {Maybe Text
Set AbsoluteDir
StructureName
PStructure (Maybe a)
name :: StructureName
recognize :: Set AbsoluteDir
description :: Maybe Text
structure :: PStructure (Maybe a)
structure :: PStructure (Maybe a)
name :: StructureName
recognize :: Set AbsoluteDir
description :: Maybe Text
..}

instance FromJSON (Grid Char) where
  parseJSON :: Value -> Parser (Grid Char)
parseJSON = String
-> (Text -> Parser (Grid Char)) -> Value -> Parser (Grid Char)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"area" ((Text -> Parser (Grid Char)) -> Value -> Parser (Grid Char))
-> (Text -> Parser (Grid Char)) -> Value -> Parser (Grid Char)
forall a b. (a -> b) -> a -> b
$ \Text
t -> do
    let textLines :: [String]
textLines = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack ([Text] -> [String]) -> [Text] -> [String]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
t
        g :: Grid Char
g = [String] -> Grid Char
forall a. [[a]] -> Grid a
mkGrid [String]
textLines
    case [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [String]
textLines of
      Maybe (NonEmpty String)
Nothing -> Grid Char -> Parser (Grid Char)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Grid Char
forall c. Grid c
EmptyGrid
      Just NonEmpty String
nonemptyRows -> do
        let firstRowLength :: Int
firstRowLength = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> String
forall a. NonEmpty a -> a
NE.head NonEmpty String
nonemptyRows
        Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
firstRowLength) (Int -> Bool) -> (String -> Int) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.tail NonEmpty String
nonemptyRows) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$
          String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Grid is not rectangular!"
        Grid Char -> Parser (Grid Char)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Grid Char
g

instance (FromJSONE e a) => FromJSONE e (PStructure (Maybe a)) where
  parseJSONE :: Value -> ParserE e (PStructure (Maybe a))
parseJSONE = String
-> (Object -> ParserE e (PStructure (Maybe a)))
-> Value
-> ParserE e (PStructure (Maybe a))
forall e a.
String -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE String
"structure definition" ((Object -> ParserE e (PStructure (Maybe a)))
 -> Value -> ParserE e (PStructure (Maybe a)))
-> (Object -> ParserE e (PStructure (Maybe a)))
-> Value
-> ParserE e (PStructure (Maybe a))
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    StructurePalette a
pal <- Object
v Object -> Text -> ParserE e (Maybe (StructurePalette a))
forall e a. FromJSONE e a => Object -> Text -> ParserE e (Maybe a)
..:? Text
"palette" ParserE e (Maybe (StructurePalette a))
-> StructurePalette a -> With e Parser (StructurePalette a)
forall (f :: * -> *) a. Functor f => f (Maybe a) -> a -> f a
..!= KeyMap (SignpostableCell a) -> StructurePalette a
forall e. KeyMap (SignpostableCell e) -> StructurePalette e
StructurePalette KeyMap (SignpostableCell a)
forall a. Monoid a => a
mempty
    [NamedStructure (Maybe a)]
structures <- Object
v Object -> Text -> ParserE e (Maybe [NamedStructure (Maybe a)])
forall e a. FromJSONE e a => Object -> Text -> ParserE e (Maybe a)
..:? Text
"structures" ParserE e (Maybe [NamedStructure (Maybe a)])
-> [NamedStructure (Maybe a)]
-> With e Parser [NamedStructure (Maybe a)]
forall (f :: * -> *) a. Functor f => f (Maybe a) -> a -> f a
..!= []
    Parser (PStructure (Maybe a)) -> ParserE e (PStructure (Maybe a))
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser (PStructure (Maybe a)) -> ParserE e (PStructure (Maybe a)))
-> Parser (PStructure (Maybe a))
-> ParserE e (PStructure (Maybe a))
forall a b. (a -> b) -> a -> b
$ do
      [Placement]
placements <- Object
v Object -> Key -> Parser (Maybe [Placement])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"placements" Parser (Maybe [Placement]) -> [Placement] -> Parser [Placement]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
      [Waypoint]
waypointDefs <- Object
v Object -> Key -> Parser (Maybe [Waypoint])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"waypoints" Parser (Maybe [Waypoint]) -> [Waypoint] -> Parser [Waypoint]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
      Maybe Char
maybeMaskChar <- Object
v Object -> Key -> Parser (Maybe Char)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"mask"
      Grid Char
rawGrid <- Object
v Object -> Key -> Parser (Maybe (Grid Char))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"map" Parser (Maybe (Grid Char)) -> Grid Char -> Parser (Grid Char)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Grid Char
forall c. Grid c
EmptyGrid
      (Grid (Maybe a)
maskedArea, [Waypoint]
mapWaypoints) <- Maybe Char
-> StructurePalette a
-> Grid Char
-> Parser (Grid (Maybe a), [Waypoint])
forall (m :: * -> *) c.
MonadFail m =>
Maybe Char
-> StructurePalette c
-> Grid Char
-> m (Grid (Maybe c), [Waypoint])
paintMap Maybe Char
maybeMaskChar StructurePalette a
pal Grid Char
rawGrid
      let area :: PositionedGrid (Maybe a)
area = 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)
maskedArea
          waypoints :: [Waypoint]
waypoints = [Waypoint]
waypointDefs [Waypoint] -> [Waypoint] -> [Waypoint]
forall a. Semigroup a => a -> a -> a
<> [Waypoint]
mapWaypoints
      PStructure (Maybe a) -> Parser (PStructure (Maybe a))
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Structure {[Placement]
[Waypoint]
[NamedStructure (Maybe a)]
PositionedGrid (Maybe a)
area :: PositionedGrid (Maybe a)
structures :: [NamedStructure (Maybe a)]
placements :: [Placement]
waypoints :: [Waypoint]
structures :: [NamedStructure (Maybe a)]
placements :: [Placement]
area :: PositionedGrid (Maybe a)
waypoints :: [Waypoint]
..}

-- | \"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 ->
  StructurePalette c ->
  Grid Char ->
  m (Grid (Maybe c), [Waypoint])
paintMap :: forall (m :: * -> *) c.
MonadFail m =>
Maybe Char
-> StructurePalette c
-> Grid Char
-> m (Grid (Maybe c), [Waypoint])
paintMap Maybe Char
maskChar StructurePalette c
pal Grid Char
g = do
  Grid (Maybe (SignpostableCell c))
nestedLists <- (Char -> m (Maybe (SignpostableCell c)))
-> Grid Char -> m (Grid (Maybe (SignpostableCell c)))
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) -> Grid a -> m (Grid b)
mapM Char -> m (Maybe (SignpostableCell c))
forall {m :: * -> *}.
MonadFail m =>
Char -> m (Maybe (SignpostableCell c))
toCell Grid Char
g
  let usedChars :: Set Text
usedChars = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ (Char -> Text) -> String -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
T.singleton (String -> [Text]) -> String -> [Text]
forall a b. (a -> b) -> a -> b
$ Grid Char -> String
forall a. Grid a -> [a]
allMembers Grid Char
g
      unusedChars :: [Text]
unusedChars =
        (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Text
usedChars)
          ([Text] -> [Text])
-> (KeyMap (SignpostableCell c) -> [Text])
-> KeyMap (SignpostableCell c)
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text (SignpostableCell c) -> [Text]
forall k a. Map k a -> [k]
M.keys
          (Map Text (SignpostableCell c) -> [Text])
-> (KeyMap (SignpostableCell c) -> Map Text (SignpostableCell c))
-> KeyMap (SignpostableCell c)
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyMap (SignpostableCell c) -> Map Text (SignpostableCell c)
forall v. KeyMap v -> Map Text v
KeyMap.toMapText
          (KeyMap (SignpostableCell c) -> [Text])
-> KeyMap (SignpostableCell c) -> [Text]
forall a b. (a -> b) -> a -> b
$ StructurePalette c -> KeyMap (SignpostableCell c)
forall e. StructurePalette e -> KeyMap (SignpostableCell e)
unPalette StructurePalette c
pal

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
unusedChars) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
      [String] -> String
unwords
        [ String
"Unused characters in palette:"
        , Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
", " [Text]
unusedChars
        ]

  let cells :: Grid (Maybe c)
cells = (SignpostableCell c -> c) -> Maybe (SignpostableCell c) -> Maybe c
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SignpostableCell c -> c
forall c. SignpostableCell c -> c
standardCell (Maybe (SignpostableCell c) -> Maybe c)
-> Grid (Maybe (SignpostableCell c)) -> Grid (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Grid (Maybe (SignpostableCell c))
nestedLists
      getWp :: Coords -> Maybe (SignpostableCell c) -> Maybe Waypoint
getWp Coords
coords Maybe (SignpostableCell c)
maybeAugmentedCell = do
        WaypointConfig
wpCfg <- SignpostableCell c -> Maybe WaypointConfig
forall c. SignpostableCell c -> Maybe WaypointConfig
waypointCfg (SignpostableCell c -> Maybe WaypointConfig)
-> Maybe (SignpostableCell c) -> Maybe WaypointConfig
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (SignpostableCell c)
maybeAugmentedCell
        Waypoint -> Maybe Waypoint
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Waypoint -> Maybe Waypoint)
-> (Coords -> Waypoint) -> Coords -> Maybe Waypoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WaypointConfig -> Location -> Waypoint
Waypoint WaypointConfig
wpCfg (Location -> Waypoint)
-> (Coords -> Location) -> Coords -> Waypoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coords -> Location
coordsToLoc (Coords -> Maybe Waypoint) -> Coords -> Maybe Waypoint
forall a b. (a -> b) -> a -> b
$ Coords
coords
      wps :: [Waypoint]
wps = [Maybe Waypoint] -> [Waypoint]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Waypoint] -> [Waypoint]) -> [Maybe Waypoint] -> [Waypoint]
forall a b. (a -> b) -> a -> b
$ (Coords -> Maybe (SignpostableCell c) -> Maybe Waypoint)
-> Grid (Maybe (SignpostableCell c)) -> [Maybe Waypoint]
forall a b. (Coords -> a -> b) -> Grid a -> [b]
mapIndexedMembers Coords -> Maybe (SignpostableCell c) -> Maybe Waypoint
forall {c}. Coords -> Maybe (SignpostableCell c) -> Maybe Waypoint
getWp Grid (Maybe (SignpostableCell c))
nestedLists

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