{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Terrain types and properties.
module Swarm.Game.Terrain (
  -- * Terrain
  TerrainType (..),
  readTerrain,
  terrainMap,
  getTerrainDefaultPaletteChar,
  getTerrainWord,
) where

import Data.Aeson (FromJSON (..), withText)
import Data.List.NonEmpty qualified as NE
import Data.Map (Map)
import Data.Map qualified as M
import Data.Text qualified as T
import Swarm.Game.Display
import Swarm.Util (failT, showEnum)
import Text.Read (readMaybe)
import Witch (into)

-- | The different possible types of terrain. Unlike entities and
--   robots, these are hard-coded into the game.
data TerrainType
  = StoneT
  | DirtT
  | GrassT
  | IceT
  | BlankT
  deriving (TerrainType -> TerrainType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TerrainType -> TerrainType -> Bool
$c/= :: TerrainType -> TerrainType -> Bool
== :: TerrainType -> TerrainType -> Bool
$c== :: TerrainType -> TerrainType -> Bool
Eq, Eq TerrainType
TerrainType -> TerrainType -> Bool
TerrainType -> TerrainType -> Ordering
TerrainType -> TerrainType -> TerrainType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TerrainType -> TerrainType -> TerrainType
$cmin :: TerrainType -> TerrainType -> TerrainType
max :: TerrainType -> TerrainType -> TerrainType
$cmax :: TerrainType -> TerrainType -> TerrainType
>= :: TerrainType -> TerrainType -> Bool
$c>= :: TerrainType -> TerrainType -> Bool
> :: TerrainType -> TerrainType -> Bool
$c> :: TerrainType -> TerrainType -> Bool
<= :: TerrainType -> TerrainType -> Bool
$c<= :: TerrainType -> TerrainType -> Bool
< :: TerrainType -> TerrainType -> Bool
$c< :: TerrainType -> TerrainType -> Bool
compare :: TerrainType -> TerrainType -> Ordering
$ccompare :: TerrainType -> TerrainType -> Ordering
Ord, Int -> TerrainType -> ShowS
[TerrainType] -> ShowS
TerrainType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TerrainType] -> ShowS
$cshowList :: [TerrainType] -> ShowS
show :: TerrainType -> String
$cshow :: TerrainType -> String
showsPrec :: Int -> TerrainType -> ShowS
$cshowsPrec :: Int -> TerrainType -> ShowS
Show, ReadPrec [TerrainType]
ReadPrec TerrainType
Int -> ReadS TerrainType
ReadS [TerrainType]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TerrainType]
$creadListPrec :: ReadPrec [TerrainType]
readPrec :: ReadPrec TerrainType
$creadPrec :: ReadPrec TerrainType
readList :: ReadS [TerrainType]
$creadList :: ReadS [TerrainType]
readsPrec :: Int -> ReadS TerrainType
$creadsPrec :: Int -> ReadS TerrainType
Read, TerrainType
forall a. a -> a -> Bounded a
maxBound :: TerrainType
$cmaxBound :: TerrainType
minBound :: TerrainType
$cminBound :: TerrainType
Bounded, Int -> TerrainType
TerrainType -> Int
TerrainType -> [TerrainType]
TerrainType -> TerrainType
TerrainType -> TerrainType -> [TerrainType]
TerrainType -> TerrainType -> TerrainType -> [TerrainType]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: TerrainType -> TerrainType -> TerrainType -> [TerrainType]
$cenumFromThenTo :: TerrainType -> TerrainType -> TerrainType -> [TerrainType]
enumFromTo :: TerrainType -> TerrainType -> [TerrainType]
$cenumFromTo :: TerrainType -> TerrainType -> [TerrainType]
enumFromThen :: TerrainType -> TerrainType -> [TerrainType]
$cenumFromThen :: TerrainType -> TerrainType -> [TerrainType]
enumFrom :: TerrainType -> [TerrainType]
$cenumFrom :: TerrainType -> [TerrainType]
fromEnum :: TerrainType -> Int
$cfromEnum :: TerrainType -> Int
toEnum :: Int -> TerrainType
$ctoEnum :: Int -> TerrainType
pred :: TerrainType -> TerrainType
$cpred :: TerrainType -> TerrainType
succ :: TerrainType -> TerrainType
$csucc :: TerrainType -> TerrainType
Enum)

readTerrain :: T.Text -> Maybe TerrainType
readTerrain :: Text -> Maybe TerrainType
readTerrain Text
t = forall a. Read a => String -> Maybe a
readMaybe (forall target source. From source target => source -> target
into @String (Text -> Text
T.toTitle Text
t) forall a. [a] -> [a] -> [a]
++ String
"T")

instance Semigroup TerrainType where
  TerrainType
t <> :: TerrainType -> TerrainType -> TerrainType
<> TerrainType
BlankT = TerrainType
t
  TerrainType
_ <> TerrainType
t = TerrainType
t

instance Monoid TerrainType where
  mempty :: TerrainType
mempty = TerrainType
BlankT

instance FromJSON TerrainType where
  parseJSON :: Value -> Parser TerrainType
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"text" forall a b. (a -> b) -> a -> b
$ \Text
t ->
    case Text -> Maybe TerrainType
readTerrain Text
t of
      Just TerrainType
ter -> forall (m :: * -> *) a. Monad m => a -> m a
return TerrainType
ter
      Maybe TerrainType
Nothing -> forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT [Text
"Unknown terrain type:", Text
t]

getTerrainDefaultPaletteChar :: TerrainType -> Char
getTerrainDefaultPaletteChar :: TerrainType -> Char
getTerrainDefaultPaletteChar = forall a. NonEmpty a -> a
NE.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. (Show e, Enum e) => e -> NonEmpty Char
showEnum

getTerrainWord :: TerrainType -> T.Text
getTerrainWord :: TerrainType -> Text
getTerrainWord = Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
init forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

-- | A map containing a 'Display' record for each different 'TerrainType'.
terrainMap :: Map TerrainType Display
terrainMap :: Map TerrainType Display
terrainMap =
  forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
    [ (TerrainType
StoneT, Char -> Attribute -> Display
defaultTerrainDisplay Char
'▒' (Text -> Attribute
ATerrain Text
"stone"))
    , (TerrainType
DirtT, Char -> Attribute -> Display
defaultTerrainDisplay Char
'▒' (Text -> Attribute
ATerrain Text
"dirt"))
    , (TerrainType
GrassT, Char -> Attribute -> Display
defaultTerrainDisplay Char
'▒' (Text -> Attribute
ATerrain Text
"grass"))
    , (TerrainType
IceT, Char -> Attribute -> Display
defaultTerrainDisplay Char
' ' (Text -> Attribute
ATerrain Text
"ice"))
    , (TerrainType
BlankT, Char -> Attribute -> Display
defaultTerrainDisplay Char
' ' Attribute
ADefault)
    ]