{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
module Swarm.Game.Scenario.Topography.ProtoCell (
  SignpostableCell (..),
  StructurePalette (..),
  StructureMarker (..),
) where

import Control.Applicative ((<|>))
import Data.Aeson.Key qualified as K
import Data.Aeson.KeyMap qualified as KM
import Data.Map (Map, fromList, toList)
import Data.Text qualified as T
import Data.Tuple (swap)
import Data.Yaml as Y
import GHC.Generics (Generic)
import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointConfig)
import Swarm.Game.Scenario.Topography.Placement
import Swarm.Game.Scenario.Topography.Structure.Named (StructureName)
import Swarm.Util (quote)
import Swarm.Util.Yaml

newtype StructurePalette e = StructurePalette
  {forall e. StructurePalette e -> Map Char (SignpostableCell e)
unPalette :: Map Char (SignpostableCell e)}
  deriving (StructurePalette e -> StructurePalette e -> Bool
(StructurePalette e -> StructurePalette e -> Bool)
-> (StructurePalette e -> StructurePalette e -> Bool)
-> Eq (StructurePalette e)
forall e. Eq e => StructurePalette e -> StructurePalette e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall e. Eq e => StructurePalette e -> StructurePalette e -> Bool
== :: StructurePalette e -> StructurePalette e -> Bool
$c/= :: forall e. Eq e => StructurePalette e -> StructurePalette e -> Bool
/= :: StructurePalette e -> StructurePalette e -> Bool
Eq, Int -> StructurePalette e -> ShowS
[StructurePalette e] -> ShowS
StructurePalette e -> String
(Int -> StructurePalette e -> ShowS)
-> (StructurePalette e -> String)
-> ([StructurePalette e] -> ShowS)
-> Show (StructurePalette e)
forall e. Show e => Int -> StructurePalette e -> ShowS
forall e. Show e => [StructurePalette e] -> ShowS
forall e. Show e => StructurePalette e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall e. Show e => Int -> StructurePalette e -> ShowS
showsPrec :: Int -> StructurePalette e -> ShowS
$cshow :: forall e. Show e => StructurePalette e -> String
show :: StructurePalette e -> String
$cshowList :: forall e. Show e => [StructurePalette e] -> ShowS
showList :: [StructurePalette e] -> ShowS
Show)

instance (FromJSONE e a) => FromJSONE e (StructurePalette a) where
  parseJSONE :: Value -> ParserE e (StructurePalette a)
parseJSONE =
    String
-> (Object -> ParserE e (StructurePalette a))
-> Value
-> ParserE e (StructurePalette a)
forall e a.
String -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE String
"palette" ((Object -> ParserE e (StructurePalette a))
 -> Value -> ParserE e (StructurePalette a))
-> (Object -> ParserE e (StructurePalette a))
-> Value
-> ParserE e (StructurePalette a)
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
      KeyMap (SignpostableCell a)
m <- (Value -> With e Parser (SignpostableCell a))
-> Object -> With e Parser (KeyMap (SignpostableCell 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) -> KeyMap a -> m (KeyMap b)
mapM Value -> With e Parser (SignpostableCell a)
forall e a. FromJSONE e a => Value -> ParserE e a
parseJSONE Object
v
      -- We swap the tuples twice so we can traverse over the second
      -- element of the tuple in between.
      [(SignpostableCell a, Char)]
swappedPairs <- ((Key, SignpostableCell a)
 -> With e Parser (SignpostableCell a, Char))
-> [(Key, SignpostableCell a)]
-> With e Parser [(SignpostableCell a, Char)]
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 ((SignpostableCell a, Key)
-> With e Parser (SignpostableCell a, Char)
verifyChar ((SignpostableCell a, Key)
 -> With e Parser (SignpostableCell a, Char))
-> ((Key, SignpostableCell a) -> (SignpostableCell a, Key))
-> (Key, SignpostableCell a)
-> With e Parser (SignpostableCell a, Char)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, SignpostableCell a) -> (SignpostableCell a, Key)
forall a b. (a, b) -> (b, a)
swap) ([(Key, SignpostableCell a)]
 -> With e Parser [(SignpostableCell a, Char)])
-> [(Key, SignpostableCell a)]
-> With e Parser [(SignpostableCell a, Char)]
forall a b. (a -> b) -> a -> b
$ Map Key (SignpostableCell a) -> [(Key, SignpostableCell a)]
forall k a. Map k a -> [(k, a)]
toList (Map Key (SignpostableCell a) -> [(Key, SignpostableCell a)])
-> Map Key (SignpostableCell a) -> [(Key, SignpostableCell a)]
forall a b. (a -> b) -> a -> b
$ KeyMap (SignpostableCell a) -> Map Key (SignpostableCell a)
forall v. KeyMap v -> Map Key v
KM.toMap KeyMap (SignpostableCell a)
m
      StructurePalette a -> ParserE e (StructurePalette a)
forall a. a -> With e Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (StructurePalette a -> ParserE e (StructurePalette a))
-> ([(Char, SignpostableCell a)] -> StructurePalette a)
-> [(Char, SignpostableCell a)]
-> ParserE e (StructurePalette a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Char (SignpostableCell a) -> StructurePalette a
forall e. Map Char (SignpostableCell e) -> StructurePalette e
StructurePalette (Map Char (SignpostableCell a) -> StructurePalette a)
-> ([(Char, SignpostableCell a)] -> Map Char (SignpostableCell a))
-> [(Char, SignpostableCell a)]
-> StructurePalette a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Char, SignpostableCell a)] -> Map Char (SignpostableCell a)
forall k a. Ord k => [(k, a)] -> Map k a
fromList ([(Char, SignpostableCell a)] -> ParserE e (StructurePalette a))
-> [(Char, SignpostableCell a)] -> ParserE e (StructurePalette a)
forall a b. (a -> b) -> a -> b
$ ((SignpostableCell a, Char) -> (Char, SignpostableCell a))
-> [(SignpostableCell a, Char)] -> [(Char, SignpostableCell a)]
forall a b. (a -> b) -> [a] -> [b]
map (SignpostableCell a, Char) -> (Char, SignpostableCell a)
forall a b. (a, b) -> (b, a)
swap [(SignpostableCell a, Char)]
swappedPairs
   where
    verifyChar :: (SignpostableCell a, Key)
-> With e Parser (SignpostableCell a, Char)
verifyChar = (Key -> With e Parser Char)
-> (SignpostableCell a, Key)
-> With e Parser (SignpostableCell a, Char)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (SignpostableCell a, a) -> f (SignpostableCell a, b)
traverse ((Key -> With e Parser Char)
 -> (SignpostableCell a, Key)
 -> With e Parser (SignpostableCell a, Char))
-> (Key -> With e Parser Char)
-> (SignpostableCell a, Key)
-> With e Parser (SignpostableCell a, Char)
forall a b. (a -> b) -> a -> b
$ String -> With e Parser Char
forall {m :: * -> *}. MonadFail m => String -> m Char
ensureSingleChar (String -> With e Parser Char)
-> (Key -> String) -> Key -> With e Parser Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> String
K.toString
    ensureSingleChar :: String -> m Char
ensureSingleChar [Char
x] = Char -> m Char
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
x
    ensureSingleChar String
x =
      String -> m Char
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Char) -> String -> m Char
forall a b. (a -> b) -> a -> b
$
        Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
          [Text] -> Text
T.unwords
            [ Text
"Palette entry is not a single character:"
            , Text -> Text
quote (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
x
            ]

data StructureMarker = StructureMarker
  { StructureMarker -> StructureName
name :: StructureName
  , StructureMarker -> Maybe Orientation
orientation :: Maybe Orientation
  }
  deriving (StructureMarker -> StructureMarker -> Bool
(StructureMarker -> StructureMarker -> Bool)
-> (StructureMarker -> StructureMarker -> Bool)
-> Eq StructureMarker
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StructureMarker -> StructureMarker -> Bool
== :: StructureMarker -> StructureMarker -> Bool
$c/= :: StructureMarker -> StructureMarker -> Bool
/= :: StructureMarker -> StructureMarker -> Bool
Eq, Int -> StructureMarker -> ShowS
[StructureMarker] -> ShowS
StructureMarker -> String
(Int -> StructureMarker -> ShowS)
-> (StructureMarker -> String)
-> ([StructureMarker] -> ShowS)
-> Show StructureMarker
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StructureMarker -> ShowS
showsPrec :: Int -> StructureMarker -> ShowS
$cshow :: StructureMarker -> String
show :: StructureMarker -> String
$cshowList :: [StructureMarker] -> ShowS
showList :: [StructureMarker] -> ShowS
Show, (forall x. StructureMarker -> Rep StructureMarker x)
-> (forall x. Rep StructureMarker x -> StructureMarker)
-> Generic StructureMarker
forall x. Rep StructureMarker x -> StructureMarker
forall x. StructureMarker -> Rep StructureMarker x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StructureMarker -> Rep StructureMarker x
from :: forall x. StructureMarker -> Rep StructureMarker x
$cto :: forall x. Rep StructureMarker x -> StructureMarker
to :: forall x. Rep StructureMarker x -> StructureMarker
Generic, Maybe StructureMarker
Value -> Parser [StructureMarker]
Value -> Parser StructureMarker
(Value -> Parser StructureMarker)
-> (Value -> Parser [StructureMarker])
-> Maybe StructureMarker
-> FromJSON StructureMarker
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser StructureMarker
parseJSON :: Value -> Parser StructureMarker
$cparseJSONList :: Value -> Parser [StructureMarker]
parseJSONList :: Value -> Parser [StructureMarker]
$comittedField :: Maybe StructureMarker
omittedField :: Maybe StructureMarker
FromJSON)

-- | Supplements a cell with waypoint and/or structure placement information
data SignpostableCell c = SignpostableCell
  { forall c. SignpostableCell c -> Maybe WaypointConfig
waypointCfg :: Maybe WaypointConfig
  , forall c. SignpostableCell c -> Maybe StructureMarker
structureMarker :: Maybe StructureMarker
  , forall c. SignpostableCell c -> c
standardCell :: c
  }
  deriving (SignpostableCell c -> SignpostableCell c -> Bool
(SignpostableCell c -> SignpostableCell c -> Bool)
-> (SignpostableCell c -> SignpostableCell c -> Bool)
-> Eq (SignpostableCell c)
forall c. Eq c => SignpostableCell c -> SignpostableCell c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall c. Eq c => SignpostableCell c -> SignpostableCell c -> Bool
== :: SignpostableCell c -> SignpostableCell c -> Bool
$c/= :: forall c. Eq c => SignpostableCell c -> SignpostableCell c -> Bool
/= :: SignpostableCell c -> SignpostableCell c -> Bool
Eq, Int -> SignpostableCell c -> ShowS
[SignpostableCell c] -> ShowS
SignpostableCell c -> String
(Int -> SignpostableCell c -> ShowS)
-> (SignpostableCell c -> String)
-> ([SignpostableCell c] -> ShowS)
-> Show (SignpostableCell c)
forall c. Show c => Int -> SignpostableCell c -> ShowS
forall c. Show c => [SignpostableCell c] -> ShowS
forall c. Show c => SignpostableCell c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. Show c => Int -> SignpostableCell c -> ShowS
showsPrec :: Int -> SignpostableCell c -> ShowS
$cshow :: forall c. Show c => SignpostableCell c -> String
show :: SignpostableCell c -> String
$cshowList :: forall c. Show c => [SignpostableCell c] -> ShowS
showList :: [SignpostableCell c] -> ShowS
Show)

instance (FromJSONE e a) => FromJSONE e (SignpostableCell a) where
  parseJSONE :: Value -> ParserE e (SignpostableCell a)
parseJSONE Value
x =
    String
-> (Object -> ParserE e (SignpostableCell a))
-> Value
-> ParserE e (SignpostableCell a)
forall e a.
String -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE String
"SignpostableCell" Object -> ParserE e (SignpostableCell a)
forall {e} {c}.
FromJSONE e c =>
Object -> With e Parser (SignpostableCell c)
objParse Value
x
      ParserE e (SignpostableCell a)
-> ParserE e (SignpostableCell a) -> ParserE e (SignpostableCell a)
forall a. With e Parser a -> With e Parser a -> With e Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Maybe WaypointConfig
-> Maybe StructureMarker -> a -> SignpostableCell a
forall c.
Maybe WaypointConfig
-> Maybe StructureMarker -> c -> SignpostableCell c
SignpostableCell Maybe WaypointConfig
forall a. Maybe a
Nothing Maybe StructureMarker
forall a. Maybe a
Nothing (a -> SignpostableCell a)
-> With e Parser a -> ParserE e (SignpostableCell a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> With e Parser a
forall e a. FromJSONE e a => Value -> ParserE e a
parseJSONE Value
x)
   where
    objParse :: Object -> With e Parser (SignpostableCell c)
objParse Object
v = do
      Maybe WaypointConfig
waypointCfg <- Parser (Maybe WaypointConfig)
-> With e Parser (Maybe WaypointConfig)
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser (Maybe WaypointConfig)
 -> With e Parser (Maybe WaypointConfig))
-> Parser (Maybe WaypointConfig)
-> With e Parser (Maybe WaypointConfig)
forall a b. (a -> b) -> a -> b
$ Object
v Object -> Key -> Parser (Maybe WaypointConfig)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"waypoint"
      Maybe StructureMarker
structureMarker <- Parser (Maybe StructureMarker)
-> With e Parser (Maybe StructureMarker)
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser (Maybe StructureMarker)
 -> With e Parser (Maybe StructureMarker))
-> Parser (Maybe StructureMarker)
-> With e Parser (Maybe StructureMarker)
forall a b. (a -> b) -> a -> b
$ Object
v Object -> Key -> Parser (Maybe StructureMarker)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"structure"
      c
standardCell <- Object
v Object -> Text -> ParserE e c
forall e a. FromJSONE e a => Object -> Text -> ParserE e a
..: Text
"cell"
      SignpostableCell c -> With e Parser (SignpostableCell c)
forall a. a -> With e Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SignpostableCell c -> With e Parser (SignpostableCell c))
-> SignpostableCell c -> With e Parser (SignpostableCell c)
forall a b. (a -> b) -> a -> b
$ SignpostableCell {c
Maybe WaypointConfig
Maybe StructureMarker
waypointCfg :: Maybe WaypointConfig
structureMarker :: Maybe StructureMarker
standardCell :: c
waypointCfg :: Maybe WaypointConfig
structureMarker :: Maybe StructureMarker
standardCell :: c
..}