content: {-# LANGUAGE OverloadedStrings #-}
  
  -- |
  -- SPDX-License-Identifier: BSD-3-Clause
  --
  -- Terrain types and properties.
  module Swarm.Game.Terrain (
    TerrainType (..),
    TerrainObj (..),
    TerrainMap (..),
    blankTerrainIndex,
    getTerrainDefaultPaletteChar,
    getTerrainWord,
    terrainFromText,
    loadTerrain,
    mkTerrainMap,
    validateTerrainAttrRefs,
  ) where
  
  import Control.Algebra (Has)
  import Control.Arrow (first, (&&&))
  import Control.Effect.Lift (Lift, sendIO)
  import Control.Effect.Throw (Throw, liftEither, throwError)
  import Control.Monad (forM, unless, (<=<))
  import Data.Char (toUpper)
  import Data.Hashable (Hashable)
  import Data.IntMap (IntMap)
  import Data.IntMap qualified as IM
  import Data.Map (Map)
  import Data.Map qualified as M
  import Data.Set (Set)
  import Data.Set qualified as Set
  import Data.Text (Text)
  import Data.Text qualified as T
  import Data.Tuple (swap)
  import Data.Yaml
  import GHC.Generics (Generic)
  import Swarm.Failure
  import Swarm.Game.Cosmetic.Attribute
  import Swarm.ResourceLoading (getDataFileNameSafe)
  import Swarm.Util (enumeratedMap, quote)
  import Swarm.Util.Effect (withThrow)
  
  data TerrainType = BlankT | TerrainType Text
    deriving (Eq, Ord, Show, Generic, ToJSON, Hashable)
  
  blankTerrainIndex :: Int
  blankTerrainIndex = 0
  
  terrainFromText :: Text -> TerrainType
  terrainFromText "blank" = BlankT
  terrainFromText x = TerrainType x
  
  getTerrainWord :: TerrainType -> Text
  getTerrainWord BlankT = "blank"
  getTerrainWord (TerrainType x) = x
  
  instance FromJSON TerrainType where
    parseJSON =
      withText "TerrainType" $
        return . terrainFromText
  
  instance Semigroup TerrainType where
    t <> BlankT = t
    _ <> t = t
  
  instance Monoid TerrainType where
    mempty = BlankT
  
  getTerrainDefaultPaletteChar :: TerrainType -> Char
  getTerrainDefaultPaletteChar = toUpper . T.head . getTerrainWord
  
  -- | Representation for parsing only. Not exported.
  data TerrainItem = TerrainItem
    { name :: TerrainType
    , attr :: Text
    , description :: Text
    }
    deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)
  
  data TerrainObj = TerrainObj
    { terrainName :: TerrainType
    , terrainDesc :: Text
    , terrainAttr :: Attribute
    }
    deriving (Show)
  
  promoteTerrainObjects :: [TerrainItem] -> [TerrainObj]
  promoteTerrainObjects =
    map (\(TerrainItem n a d) -> TerrainObj n d (AWorld a))
  
  invertedIndexMap :: IntMap TerrainObj -> Map TerrainType Int
  invertedIndexMap = M.fromList . map (first terrainName . swap) . IM.toList
  
  -- | Each terrain type shall have a unique
  -- integral index. The indices should
  -- be consecutive by parse order.
  data TerrainMap = TerrainMap
    { terrainByName :: Map TerrainType TerrainObj
    , terrainByIndex :: IntMap TerrainObj
    , terrainIndexByName :: Map TerrainType Int
    -- ^ basically the inverse of 'terrainByIndex'.
    -- This needs to be (is) recomputed upon every update to
    -- the other fields in 'TerrainMap'.
    }
    deriving (Show)
  
  instance Semigroup TerrainMap where
    TerrainMap oldByName oldByIndex _ <> TerrainMap newByName newByIndex _ =
      TerrainMap
        (oldByName <> newByName)
        combinedTerrainByIndex
        (invertedIndexMap combinedTerrainByIndex)
     where
      combinedTerrainByIndex = oldByIndex <> enumeratedMap (IM.size oldByIndex) (IM.elems newByIndex)
  
  instance Monoid TerrainMap where
    mempty = TerrainMap mempty mempty mempty
  
  mkTerrainMap :: [TerrainObj] -> TerrainMap
  mkTerrainMap items =
    TerrainMap
      { terrainByName = M.fromList $ map (terrainName &&& id) items
      , terrainByIndex = byIndex
      , terrainIndexByName = invertedIndexMap byIndex
      }
   where
    byIndex = enumeratedMap blankTerrainIndex items
  
  -- | Validates references to 'Display' attributes
  validateTerrainAttrRefs :: Has (Throw LoadingFailure) sig m => Set Attribute -> [TerrainItem] -> m [TerrainObj]
  validateTerrainAttrRefs validAttrs rawTerrains =
    forM rawTerrains $ \(TerrainItem n a d) -> do
      unless (Set.member (AWorld a) validAttrs)
        . throwError
        . SystemFailure
        . CustomFailure
        $ T.unwords
          [ "Nonexistent attribute"
          , quote a
          , "referenced by terrain"
          , quote $ getTerrainWord n
          ]
  
      return $ TerrainObj n d (AWorld a)
  
  -- | Load terrain from a data file called @terrains.yaml@, producing
  --   either an 'TerrainMap' or a parse error.
  loadTerrain ::
    (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
    m TerrainMap
  loadTerrain = do
    fileName <- getDataFileNameSafe Terrain terrainFile
    decoded <-
      withThrow (terrainFailure . CanNotParseYaml) . (liftEither <=< sendIO) $
        decodeFileEither fileName
  
    let terrainObjs = promoteTerrainObjects decoded
    -- Ensures that the blank terrain gets index 0
    return $ mkTerrainMap $ blankTerrainObj : terrainObjs
   where
    terrainFile = "terrains.yaml"
    terrainFailure = AssetNotLoaded (Data Terrain) terrainFile
  
    blankTerrainObj = TerrainObj BlankT "Blank terrain" ABlank
  