{-# 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 (forM_, unless)
import Data.List (intercalate)
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe (catMaybes, fromMaybe)
import Data.Set qualified as Set
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.Named
import Swarm.Game.Scenario.Topography.Structure.Overlay
import Swarm.Game.Scenario.Topography.Structure.Recognition.Static
import Swarm.Game.World.Coords
import Swarm.Util (failT, showT)
import Swarm.Util.Yaml

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)

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)
structure :: PStructure (Maybe a)
name :: StructureName
recognize :: Set AbsoluteDir
description :: Maybe Text
structure :: PStructure (Maybe a)
description :: Maybe Text
recognize :: Set AbsoluteDir
name :: StructureName
..}

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

parseStructure ::
  StructurePalette c ->
  [NamedStructure (Maybe c)] ->
  Object ->
  Parser (PStructure (Maybe c))
parseStructure :: forall c.
StructurePalette c
-> [NamedStructure (Maybe c)]
-> Object
-> Parser (PStructure (Maybe c))
parseStructure StructurePalette c
pal [NamedStructure (Maybe c)]
structures Object
v = do
  [Placement]
explicitPlacements <- 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 c)
maskedArea, [Waypoint]
mapWaypoints, [Placement]
palettePlacements) <- Maybe Char
-> StructurePalette c
-> Grid Char
-> Parser (Grid (Maybe c), [Waypoint], [Placement])
forall (m :: * -> *) c.
MonadFail m =>
Maybe Char
-> StructurePalette c
-> Grid Char
-> m (Grid (Maybe c), [Waypoint], [Placement])
paintMap Maybe Char
maybeMaskChar StructurePalette c
pal Grid Char
rawGrid
  let area :: PositionedGrid (Maybe c)
area = Location -> Grid (Maybe c) -> PositionedGrid (Maybe c)
forall a. Location -> Grid a -> PositionedGrid a
PositionedGrid Location
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin Grid (Maybe c)
maskedArea
      waypoints :: [Waypoint]
waypoints = [Waypoint]
waypointDefs [Waypoint] -> [Waypoint] -> [Waypoint]
forall a. Semigroup a => a -> a -> a
<> [Waypoint]
mapWaypoints
      placements :: [Placement]
placements = [Placement]
explicitPlacements [Placement] -> [Placement] -> [Placement]
forall a. Semigroup a => a -> a -> a
<> [Placement]
palettePlacements
  PStructure (Maybe c) -> Parser (PStructure (Maybe c))
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Structure {[NamedStructure (Maybe c)]
[Placement]
[Waypoint]
PositionedGrid (Maybe c)
area :: PositionedGrid (Maybe c)
structures :: [NamedStructure (Maybe c)]
placements :: [Placement]
waypoints :: [Waypoint]
structures :: [NamedStructure (Maybe c)]
area :: PositionedGrid (Maybe c)
waypoints :: [Waypoint]
placements :: [Placement]
..}

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
..!= Map Char (SignpostableCell a) -> StructurePalette a
forall e. Map Char (SignpostableCell e) -> StructurePalette e
StructurePalette Map Char (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
$ StructurePalette a
-> [NamedStructure (Maybe a)]
-> Object
-> Parser (PStructure (Maybe a))
forall c.
StructurePalette c
-> [NamedStructure (Maybe c)]
-> Object
-> Parser (PStructure (Maybe c))
parseStructure StructurePalette a
pal [NamedStructure (Maybe a)]
structures Object
v

-- | \"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], [Placement])
paintMap :: forall (m :: * -> *) c.
MonadFail m =>
Maybe Char
-> StructurePalette c
-> Grid Char
-> m (Grid (Maybe c), [Waypoint], [Placement])
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
  Maybe Char -> (Char -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Char
maskChar ((Char -> m ()) -> m ()) -> (Char -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Char
c ->
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Char -> Set Char -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember Char
c Set Char
paletteKeys) (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
"Mask character"
          , [Char
'"', Char
c, Char
'"']
          , String
"overlaps palette entry"
          ]

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set Char -> Bool
forall a. Set a -> Bool
Set.null Set Char
unusedPaletteChars) (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:"
        , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Char -> String
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ Set Char -> String
forall a. Set a -> [a]
Set.toList Set Char
unusedPaletteChars
        ]

  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
      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]
mapWithCoords Coords -> Maybe (SignpostableCell c) -> Maybe Waypoint
forall {c}. Coords -> Maybe (SignpostableCell c) -> Maybe Waypoint
getWp Grid (Maybe (SignpostableCell c))
nestedLists

  let extraPlacements :: [Placement]
extraPlacements =
        [Maybe Placement] -> [Placement]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Placement] -> [Placement])
-> [Maybe Placement] -> [Placement]
forall a b. (a -> b) -> a -> b
$ (Coords -> Maybe (SignpostableCell c) -> Maybe Placement)
-> Grid (Maybe (SignpostableCell c)) -> [Maybe Placement]
forall a b. (Coords -> a -> b) -> Grid a -> [b]
mapWithCoords Coords -> Maybe (SignpostableCell c) -> Maybe Placement
forall {c}. Coords -> Maybe (SignpostableCell c) -> Maybe Placement
getStructureMarker Grid (Maybe (SignpostableCell c))
nestedLists

  (Grid (Maybe c), [Waypoint], [Placement])
-> m (Grid (Maybe c), [Waypoint], [Placement])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Grid (Maybe c)
cells, [Waypoint]
wps, [Placement]
extraPlacements)
 where
  getStructureMarker :: Coords -> Maybe (SignpostableCell c) -> Maybe Placement
getStructureMarker Coords
coords Maybe (SignpostableCell c)
maybeAugmentedCell = do
    StructureMarker StructureName
sName Maybe Orientation
orientation <- SignpostableCell c -> Maybe StructureMarker
forall c. SignpostableCell c -> Maybe StructureMarker
structureMarker (SignpostableCell c -> Maybe StructureMarker)
-> Maybe (SignpostableCell c) -> Maybe StructureMarker
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (SignpostableCell c)
maybeAugmentedCell
    Placement -> Maybe Placement
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return
      (Placement -> Maybe Placement)
-> (Orientation -> Placement) -> Orientation -> Maybe Placement
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StructureName -> Pose -> Placement
Placement StructureName
sName
      (Pose -> Placement)
-> (Orientation -> Pose) -> Orientation -> Placement
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> Orientation -> Pose
Pose (Coords -> Location
coordsToLoc Coords
coords)
      (Orientation -> Maybe Placement) -> Orientation -> Maybe Placement
forall a b. (a -> b) -> a -> b
$ Orientation -> Maybe Orientation -> Orientation
forall a. a -> Maybe a -> a
fromMaybe Orientation
defaultOrientation Maybe Orientation
orientation

  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

  usedChars :: Set Char
usedChars = String -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList (String -> Set Char) -> String -> Set Char
forall a b. (a -> b) -> a -> b
$ Grid Char -> String
forall a. Grid a -> [a]
allMembers Grid Char
g
  paletteKeys :: Set Char
paletteKeys = Map Char (SignpostableCell c) -> Set Char
forall k a. Map k a -> Set k
M.keysSet (Map Char (SignpostableCell c) -> Set Char)
-> Map Char (SignpostableCell c) -> Set Char
forall a b. (a -> b) -> a -> b
$ StructurePalette c -> Map Char (SignpostableCell c)
forall e. StructurePalette e -> Map Char (SignpostableCell e)
unPalette StructurePalette c
pal
  unusedPaletteChars :: Set Char
unusedPaletteChars = Set Char -> Set Char -> Set Char
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set Char
paletteKeys Set Char
usedChars

  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 Char -> Map Char (SignpostableCell c) -> Maybe (SignpostableCell c)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Char
c (StructurePalette c -> Map Char (SignpostableCell c)
forall e. StructurePalette e -> Map Char (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