{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Abstract syntax for the Swarm world description DSL.
module Swarm.Game.World.Syntax (
  -- | Various component types
  World,
  RawCellVal,
  CellTag (..),
  CellVal (..),
  Var,
  Axis (..),
  Op (..),
  -- | The main AST type
  WExp (..),
)
where

import Control.Lens (view, (^.))
import Data.List.NonEmpty qualified as NE
import Data.Semigroup (Last (..))
import Data.Text (Text)
import Data.Text qualified as T
import Prettyprinter
import Swarm.Game.Entity (Entity, entityName)
import Swarm.Game.Robot (TRobot, trobotName)
import Swarm.Game.Terrain
import Swarm.Game.World.Coords
import Swarm.Pretty (PrettyPrec (..))
import Swarm.Util (showT)
import Swarm.Util.Erasable

------------------------------------------------------------
-- Bits and bobs

type World b = Coords -> b

data CellTag = CellTerrain | CellEntity | CellRobot
  deriving (CellTag -> CellTag -> Bool
(CellTag -> CellTag -> Bool)
-> (CellTag -> CellTag -> Bool) -> Eq CellTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CellTag -> CellTag -> Bool
== :: CellTag -> CellTag -> Bool
$c/= :: CellTag -> CellTag -> Bool
/= :: CellTag -> CellTag -> Bool
Eq, Eq CellTag
Eq CellTag =>
(CellTag -> CellTag -> Ordering)
-> (CellTag -> CellTag -> Bool)
-> (CellTag -> CellTag -> Bool)
-> (CellTag -> CellTag -> Bool)
-> (CellTag -> CellTag -> Bool)
-> (CellTag -> CellTag -> CellTag)
-> (CellTag -> CellTag -> CellTag)
-> Ord CellTag
CellTag -> CellTag -> Bool
CellTag -> CellTag -> Ordering
CellTag -> CellTag -> CellTag
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
$ccompare :: CellTag -> CellTag -> Ordering
compare :: CellTag -> CellTag -> Ordering
$c< :: CellTag -> CellTag -> Bool
< :: CellTag -> CellTag -> Bool
$c<= :: CellTag -> CellTag -> Bool
<= :: CellTag -> CellTag -> Bool
$c> :: CellTag -> CellTag -> Bool
> :: CellTag -> CellTag -> Bool
$c>= :: CellTag -> CellTag -> Bool
>= :: CellTag -> CellTag -> Bool
$cmax :: CellTag -> CellTag -> CellTag
max :: CellTag -> CellTag -> CellTag
$cmin :: CellTag -> CellTag -> CellTag
min :: CellTag -> CellTag -> CellTag
Ord, Int -> CellTag -> ShowS
[CellTag] -> ShowS
CellTag -> String
(Int -> CellTag -> ShowS)
-> (CellTag -> String) -> ([CellTag] -> ShowS) -> Show CellTag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CellTag -> ShowS
showsPrec :: Int -> CellTag -> ShowS
$cshow :: CellTag -> String
show :: CellTag -> String
$cshowList :: [CellTag] -> ShowS
showList :: [CellTag] -> ShowS
Show, Int -> CellTag
CellTag -> Int
CellTag -> [CellTag]
CellTag -> CellTag
CellTag -> CellTag -> [CellTag]
CellTag -> CellTag -> CellTag -> [CellTag]
(CellTag -> CellTag)
-> (CellTag -> CellTag)
-> (Int -> CellTag)
-> (CellTag -> Int)
-> (CellTag -> [CellTag])
-> (CellTag -> CellTag -> [CellTag])
-> (CellTag -> CellTag -> [CellTag])
-> (CellTag -> CellTag -> CellTag -> [CellTag])
-> Enum CellTag
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: CellTag -> CellTag
succ :: CellTag -> CellTag
$cpred :: CellTag -> CellTag
pred :: CellTag -> CellTag
$ctoEnum :: Int -> CellTag
toEnum :: Int -> CellTag
$cfromEnum :: CellTag -> Int
fromEnum :: CellTag -> Int
$cenumFrom :: CellTag -> [CellTag]
enumFrom :: CellTag -> [CellTag]
$cenumFromThen :: CellTag -> CellTag -> [CellTag]
enumFromThen :: CellTag -> CellTag -> [CellTag]
$cenumFromTo :: CellTag -> CellTag -> [CellTag]
enumFromTo :: CellTag -> CellTag -> [CellTag]
$cenumFromThenTo :: CellTag -> CellTag -> CellTag -> [CellTag]
enumFromThenTo :: CellTag -> CellTag -> CellTag -> [CellTag]
Enum, CellTag
CellTag -> CellTag -> Bounded CellTag
forall a. a -> a -> Bounded a
$cminBound :: CellTag
minBound :: CellTag
$cmaxBound :: CellTag
maxBound :: CellTag
Bounded)

instance PrettyPrec CellTag where
  prettyPrec :: forall ann. Int -> CellTag -> Doc ann
prettyPrec Int
_ = \case
    CellTag
CellTerrain -> Doc ann
"terrain"
    CellTag
CellEntity -> Doc ann
"an entity"
    CellTag
CellRobot -> Doc ann
"a robot"

type RawCellVal = [(Maybe CellTag, Text)]

prettyRawCellItem :: (Maybe CellTag, Text) -> Doc ann
prettyRawCellItem :: forall ann. (Maybe CellTag, Text) -> Doc ann
prettyRawCellItem (Maybe CellTag
Nothing, Text
t) = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
t
prettyRawCellItem (Just CellTag
tag, Text
t) = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Text
T.toLower (Text -> Text) -> (CellTag -> Text) -> CellTag -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop Int
4 (Text -> Text) -> (CellTag -> Text) -> CellTag -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CellTag -> Text
forall a. Show a => a -> Text
showT (CellTag -> Text) -> CellTag -> Text
forall a b. (a -> b) -> a -> b
$ CellTag
tag) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
t

data CellVal = CellVal TerrainType (Erasable (Last Entity)) [TRobot]
  deriving (CellVal -> CellVal -> Bool
(CellVal -> CellVal -> Bool)
-> (CellVal -> CellVal -> Bool) -> Eq CellVal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CellVal -> CellVal -> Bool
== :: CellVal -> CellVal -> Bool
$c/= :: CellVal -> CellVal -> Bool
/= :: CellVal -> CellVal -> Bool
Eq, Int -> CellVal -> ShowS
[CellVal] -> ShowS
CellVal -> String
(Int -> CellVal -> ShowS)
-> (CellVal -> String) -> ([CellVal] -> ShowS) -> Show CellVal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CellVal -> ShowS
showsPrec :: Int -> CellVal -> ShowS
$cshow :: CellVal -> String
show :: CellVal -> String
$cshowList :: [CellVal] -> ShowS
showList :: [CellVal] -> ShowS
Show)

instance PrettyPrec CellVal where
  prettyPrec :: forall ann. Int -> CellVal -> Doc ann
prettyPrec Int
_ (CellVal TerrainType
terr Erasable (Last Entity)
ent [TRobot]
rs) =
    Doc ann
"{" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
"," (((Maybe CellTag, Text) -> Doc ann)
-> [(Maybe CellTag, Text)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe CellTag, Text) -> Doc ann
forall ann. (Maybe CellTag, Text) -> Doc ann
prettyRawCellItem [(Maybe CellTag, Text)]
items)) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"}"
   where
    items :: [(Maybe CellTag, Text)]
items =
      [(CellTag -> Maybe CellTag
forall a. a -> Maybe a
Just CellTag
CellTerrain, TerrainType -> Text
getTerrainWord TerrainType
terr) | TerrainType
terr TerrainType -> TerrainType -> Bool
forall a. Eq a => a -> a -> Bool
/= TerrainType
BlankT]
        [(Maybe CellTag, Text)]
-> [(Maybe CellTag, Text)] -> [(Maybe CellTag, Text)]
forall a. [a] -> [a] -> [a]
++ [(CellTag -> Maybe CellTag
forall a. a -> Maybe a
Just CellTag
CellEntity, Entity
e Entity -> Getting Text Entity Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Entity Text
Lens' Entity Text
entityName) | EJust (Last Entity
e) <- [Erasable (Last Entity)
ent]]
        [(Maybe CellTag, Text)]
-> [(Maybe CellTag, Text)] -> [(Maybe CellTag, Text)]
forall a. [a] -> [a] -> [a]
++ (TRobot -> (Maybe CellTag, Text))
-> [TRobot] -> [(Maybe CellTag, Text)]
forall a b. (a -> b) -> [a] -> [b]
map ((CellTag -> Maybe CellTag
forall a. a -> Maybe a
Just CellTag
CellRobot,) (Text -> (Maybe CellTag, Text))
-> (TRobot -> Text) -> TRobot -> (Maybe CellTag, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Text TRobot Text -> TRobot -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text TRobot Text
Lens' TRobot Text
trobotName) [TRobot]
rs

type Var = Text

data Axis = X | Y
  deriving (Axis -> Axis -> Bool
(Axis -> Axis -> Bool) -> (Axis -> Axis -> Bool) -> Eq Axis
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Axis -> Axis -> Bool
== :: Axis -> Axis -> Bool
$c/= :: Axis -> Axis -> Bool
/= :: Axis -> Axis -> Bool
Eq, Eq Axis
Eq Axis =>
(Axis -> Axis -> Ordering)
-> (Axis -> Axis -> Bool)
-> (Axis -> Axis -> Bool)
-> (Axis -> Axis -> Bool)
-> (Axis -> Axis -> Bool)
-> (Axis -> Axis -> Axis)
-> (Axis -> Axis -> Axis)
-> Ord Axis
Axis -> Axis -> Bool
Axis -> Axis -> Ordering
Axis -> Axis -> Axis
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
$ccompare :: Axis -> Axis -> Ordering
compare :: Axis -> Axis -> Ordering
$c< :: Axis -> Axis -> Bool
< :: Axis -> Axis -> Bool
$c<= :: Axis -> Axis -> Bool
<= :: Axis -> Axis -> Bool
$c> :: Axis -> Axis -> Bool
> :: Axis -> Axis -> Bool
$c>= :: Axis -> Axis -> Bool
>= :: Axis -> Axis -> Bool
$cmax :: Axis -> Axis -> Axis
max :: Axis -> Axis -> Axis
$cmin :: Axis -> Axis -> Axis
min :: Axis -> Axis -> Axis
Ord, Int -> Axis -> ShowS
[Axis] -> ShowS
Axis -> String
(Int -> Axis -> ShowS)
-> (Axis -> String) -> ([Axis] -> ShowS) -> Show Axis
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Axis -> ShowS
showsPrec :: Int -> Axis -> ShowS
$cshow :: Axis -> String
show :: Axis -> String
$cshowList :: [Axis] -> ShowS
showList :: [Axis] -> ShowS
Show, Axis
Axis -> Axis -> Bounded Axis
forall a. a -> a -> Bounded a
$cminBound :: Axis
minBound :: Axis
$cmaxBound :: Axis
maxBound :: Axis
Bounded, Int -> Axis
Axis -> Int
Axis -> [Axis]
Axis -> Axis
Axis -> Axis -> [Axis]
Axis -> Axis -> Axis -> [Axis]
(Axis -> Axis)
-> (Axis -> Axis)
-> (Int -> Axis)
-> (Axis -> Int)
-> (Axis -> [Axis])
-> (Axis -> Axis -> [Axis])
-> (Axis -> Axis -> [Axis])
-> (Axis -> Axis -> Axis -> [Axis])
-> Enum Axis
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Axis -> Axis
succ :: Axis -> Axis
$cpred :: Axis -> Axis
pred :: Axis -> Axis
$ctoEnum :: Int -> Axis
toEnum :: Int -> Axis
$cfromEnum :: Axis -> Int
fromEnum :: Axis -> Int
$cenumFrom :: Axis -> [Axis]
enumFrom :: Axis -> [Axis]
$cenumFromThen :: Axis -> Axis -> [Axis]
enumFromThen :: Axis -> Axis -> [Axis]
$cenumFromTo :: Axis -> Axis -> [Axis]
enumFromTo :: Axis -> Axis -> [Axis]
$cenumFromThenTo :: Axis -> Axis -> Axis -> [Axis]
enumFromThenTo :: Axis -> Axis -> Axis -> [Axis]
Enum)

instance PrettyPrec Axis where
  prettyPrec :: forall ann. Int -> Axis -> Doc ann
prettyPrec Int
_ = \case Axis
X -> Doc ann
"x"; Axis
Y -> Doc ann
"y"

data Op = Not | Neg | And | Or | Add | Sub | Mul | Div | Mod | Eq | Neq | Lt | Leq | Gt | Geq | If | Perlin | Mask | Overlay | Abs | IMap
  deriving (Op -> Op -> Bool
(Op -> Op -> Bool) -> (Op -> Op -> Bool) -> Eq Op
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Op -> Op -> Bool
== :: Op -> Op -> Bool
$c/= :: Op -> Op -> Bool
/= :: Op -> Op -> Bool
Eq, Eq Op
Eq Op =>
(Op -> Op -> Ordering)
-> (Op -> Op -> Bool)
-> (Op -> Op -> Bool)
-> (Op -> Op -> Bool)
-> (Op -> Op -> Bool)
-> (Op -> Op -> Op)
-> (Op -> Op -> Op)
-> Ord Op
Op -> Op -> Bool
Op -> Op -> Ordering
Op -> Op -> Op
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
$ccompare :: Op -> Op -> Ordering
compare :: Op -> Op -> Ordering
$c< :: Op -> Op -> Bool
< :: Op -> Op -> Bool
$c<= :: Op -> Op -> Bool
<= :: Op -> Op -> Bool
$c> :: Op -> Op -> Bool
> :: Op -> Op -> Bool
$c>= :: Op -> Op -> Bool
>= :: Op -> Op -> Bool
$cmax :: Op -> Op -> Op
max :: Op -> Op -> Op
$cmin :: Op -> Op -> Op
min :: Op -> Op -> Op
Ord, Int -> Op -> ShowS
[Op] -> ShowS
Op -> String
(Int -> Op -> ShowS)
-> (Op -> String) -> ([Op] -> ShowS) -> Show Op
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Op -> ShowS
showsPrec :: Int -> Op -> ShowS
$cshow :: Op -> String
show :: Op -> String
$cshowList :: [Op] -> ShowS
showList :: [Op] -> ShowS
Show)

------------------------------------------------------------
-- Main AST

data WExp where
  WInt :: Integer -> WExp
  WFloat :: Double -> WExp
  WBool :: Bool -> WExp
  WCell :: RawCellVal -> WExp
  WVar :: Text -> WExp
  -- Require all operators to be fully saturated.  Just embedding
  -- operators as constants and including function application would
  -- be a more elegant encoding, but it requires being more clever
  -- with type inference.
  WOp :: Op -> [WExp] -> WExp
  WSeed :: WExp
  WCoord :: Axis -> WExp
  WHash :: WExp
  WLet :: [(Var, WExp)] -> WExp -> WExp
  WOverlay :: NE.NonEmpty WExp -> WExp
  WImport :: Text -> WExp
  deriving (WExp -> WExp -> Bool
(WExp -> WExp -> Bool) -> (WExp -> WExp -> Bool) -> Eq WExp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WExp -> WExp -> Bool
== :: WExp -> WExp -> Bool
$c/= :: WExp -> WExp -> Bool
/= :: WExp -> WExp -> Bool
Eq, Int -> WExp -> ShowS
[WExp] -> ShowS
WExp -> String
(Int -> WExp -> ShowS)
-> (WExp -> String) -> ([WExp] -> ShowS) -> Show WExp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WExp -> ShowS
showsPrec :: Int -> WExp -> ShowS
$cshow :: WExp -> String
show :: WExp -> String
$cshowList :: [WExp] -> ShowS
showList :: [WExp] -> ShowS
Show)

-- We don't have an explicit Empty case because we can't infer its
-- type.  It could be done but it would require a lot more care with
-- inference vs checking mode.

-- TODO (#1394): Add hcat and vcat operations
-- WCat :: Axis -> [WExp] -> WExp

-- TODO (#1394): Add support for structures
-- WStruct :: WorldPalette Text -> [Text] -> WExp