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

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Descriptions of the orientation and offset by
-- which a structure should be placed.
module Swarm.Game.Scenario.Topography.Placement where

import Data.List.NonEmpty qualified as NE
import Data.Text (Text)
import Data.Yaml as Y
import GHC.Generics (Generic)
import Swarm.Game.Location
import Swarm.Game.Scenario.Topography.Area
import Swarm.Game.Scenario.Topography.Grid
import Swarm.Language.Syntax.Direction (AbsoluteDir (..))

newtype StructureName = StructureName Text
  deriving (StructureName -> StructureName -> Bool
(StructureName -> StructureName -> Bool)
-> (StructureName -> StructureName -> Bool) -> Eq StructureName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StructureName -> StructureName -> Bool
== :: StructureName -> StructureName -> Bool
$c/= :: StructureName -> StructureName -> Bool
/= :: StructureName -> StructureName -> Bool
Eq, Eq StructureName
Eq StructureName =>
(StructureName -> StructureName -> Ordering)
-> (StructureName -> StructureName -> Bool)
-> (StructureName -> StructureName -> Bool)
-> (StructureName -> StructureName -> Bool)
-> (StructureName -> StructureName -> Bool)
-> (StructureName -> StructureName -> StructureName)
-> (StructureName -> StructureName -> StructureName)
-> Ord StructureName
StructureName -> StructureName -> Bool
StructureName -> StructureName -> Ordering
StructureName -> StructureName -> StructureName
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 :: StructureName -> StructureName -> Ordering
compare :: StructureName -> StructureName -> Ordering
$c< :: StructureName -> StructureName -> Bool
< :: StructureName -> StructureName -> Bool
$c<= :: StructureName -> StructureName -> Bool
<= :: StructureName -> StructureName -> Bool
$c> :: StructureName -> StructureName -> Bool
> :: StructureName -> StructureName -> Bool
$c>= :: StructureName -> StructureName -> Bool
>= :: StructureName -> StructureName -> Bool
$cmax :: StructureName -> StructureName -> StructureName
max :: StructureName -> StructureName -> StructureName
$cmin :: StructureName -> StructureName -> StructureName
min :: StructureName -> StructureName -> StructureName
Ord, Int -> StructureName -> ShowS
[StructureName] -> ShowS
StructureName -> String
(Int -> StructureName -> ShowS)
-> (StructureName -> String)
-> ([StructureName] -> ShowS)
-> Show StructureName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StructureName -> ShowS
showsPrec :: Int -> StructureName -> ShowS
$cshow :: StructureName -> String
show :: StructureName -> String
$cshowList :: [StructureName] -> ShowS
showList :: [StructureName] -> ShowS
Show, (forall x. StructureName -> Rep StructureName x)
-> (forall x. Rep StructureName x -> StructureName)
-> Generic StructureName
forall x. Rep StructureName x -> StructureName
forall x. StructureName -> Rep StructureName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StructureName -> Rep StructureName x
from :: forall x. StructureName -> Rep StructureName x
$cto :: forall x. Rep StructureName x -> StructureName
to :: forall x. Rep StructureName x -> StructureName
Generic, Maybe StructureName
Value -> Parser [StructureName]
Value -> Parser StructureName
(Value -> Parser StructureName)
-> (Value -> Parser [StructureName])
-> Maybe StructureName
-> FromJSON StructureName
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser StructureName
parseJSON :: Value -> Parser StructureName
$cparseJSONList :: Value -> Parser [StructureName]
parseJSONList :: Value -> Parser [StructureName]
$comittedField :: Maybe StructureName
omittedField :: Maybe StructureName
FromJSON, [StructureName] -> Value
[StructureName] -> Encoding
StructureName -> Bool
StructureName -> Value
StructureName -> Encoding
(StructureName -> Value)
-> (StructureName -> Encoding)
-> ([StructureName] -> Value)
-> ([StructureName] -> Encoding)
-> (StructureName -> Bool)
-> ToJSON StructureName
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: StructureName -> Value
toJSON :: StructureName -> Value
$ctoEncoding :: StructureName -> Encoding
toEncoding :: StructureName -> Encoding
$ctoJSONList :: [StructureName] -> Value
toJSONList :: [StructureName] -> Value
$ctoEncodingList :: [StructureName] -> Encoding
toEncodingList :: [StructureName] -> Encoding
$comitField :: StructureName -> Bool
omitField :: StructureName -> Bool
ToJSON)

getStructureName :: StructureName -> Text
getStructureName :: StructureName -> Text
getStructureName (StructureName Text
sn) = Text
sn

-- | Orientation transformations are applied before translation.
data Orientation = Orientation
  { Orientation -> AbsoluteDir
up :: AbsoluteDir
  -- ^ e.g. For "East", rotates 270 degrees.
  , Orientation -> Bool
flipped :: Bool
  -- ^ vertical flip, applied before rotation
  }
  deriving (Orientation -> Orientation -> Bool
(Orientation -> Orientation -> Bool)
-> (Orientation -> Orientation -> Bool) -> Eq Orientation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Orientation -> Orientation -> Bool
== :: Orientation -> Orientation -> Bool
$c/= :: Orientation -> Orientation -> Bool
/= :: Orientation -> Orientation -> Bool
Eq, Int -> Orientation -> ShowS
[Orientation] -> ShowS
Orientation -> String
(Int -> Orientation -> ShowS)
-> (Orientation -> String)
-> ([Orientation] -> ShowS)
-> Show Orientation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Orientation -> ShowS
showsPrec :: Int -> Orientation -> ShowS
$cshow :: Orientation -> String
show :: Orientation -> String
$cshowList :: [Orientation] -> ShowS
showList :: [Orientation] -> ShowS
Show)

instance FromJSON Orientation where
  parseJSON :: Value -> Parser Orientation
parseJSON = String
-> (Object -> Parser Orientation) -> Value -> Parser Orientation
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"structure orientation" ((Object -> Parser Orientation) -> Value -> Parser Orientation)
-> (Object -> Parser Orientation) -> Value -> Parser Orientation
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    AbsoluteDir
up <- Object
v Object -> Key -> Parser (Maybe AbsoluteDir)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"up" Parser (Maybe AbsoluteDir) -> AbsoluteDir -> Parser AbsoluteDir
forall a. Parser (Maybe a) -> a -> Parser a
.!= AbsoluteDir
DNorth
    Bool
flipped <- Object
v Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"flip" Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False
    Orientation -> Parser Orientation
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Orientation {Bool
AbsoluteDir
up :: AbsoluteDir
flipped :: Bool
up :: AbsoluteDir
flipped :: Bool
..}

defaultOrientation :: Orientation
defaultOrientation :: Orientation
defaultOrientation = AbsoluteDir -> Bool -> Orientation
Orientation AbsoluteDir
DNorth Bool
False

-- | This is the point-wise equivalent of "applyOrientationTransform"
reorientLandmark :: Orientation -> AreaDimensions -> Location -> Location
reorientLandmark :: Orientation -> AreaDimensions -> Location -> Location
reorientLandmark (Orientation AbsoluteDir
upDir Bool
shouldFlip) (AreaDimensions Int32
width Int32
height) =
  Location -> Location
rotational (Location -> Location)
-> (Location -> Location) -> Location -> Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> Location
flipping
 where
  transposeLoc :: Location -> Location
transposeLoc (Location Int32
x Int32
y) = Int32 -> Int32 -> Location
Location (-Int32
y) (-Int32
x)
  flipV :: Location -> Location
flipV (Location Int32
x Int32
y) = Int32 -> Int32 -> Location
Location Int32
x (Int32 -> Location) -> Int32 -> Location
forall a b. (a -> b) -> a -> b
$ -(Int32
height Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
1) Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
y
  flipH :: Location -> Location
flipH (Location Int32
x Int32
y) = Int32 -> Int32 -> Location
Location (Int32
width Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
1 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
x) Int32
y
  flipping :: Location -> Location
flipping = if Bool
shouldFlip then Location -> Location
flipV else Location -> Location
forall a. a -> a
id
  rotational :: Location -> Location
rotational = case AbsoluteDir
upDir of
    AbsoluteDir
DNorth -> Location -> Location
forall a. a -> a
id
    AbsoluteDir
DSouth -> Location -> Location
flipH (Location -> Location)
-> (Location -> Location) -> Location -> Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> Location
flipV
    AbsoluteDir
DEast -> Location -> Location
transposeLoc (Location -> Location)
-> (Location -> Location) -> Location -> Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> Location
flipV
    AbsoluteDir
DWest -> Location -> Location
transposeLoc (Location -> Location)
-> (Location -> Location) -> Location -> Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> Location
flipH

-- | affine transformation
applyOrientationTransform :: Orientation -> Grid a -> Grid a
applyOrientationTransform :: forall a. Orientation -> Grid a -> Grid a
applyOrientationTransform (Orientation AbsoluteDir
upDir Bool
shouldFlip) =
  (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a))
-> Grid a -> Grid a
forall a b.
(NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty b))
-> Grid a -> Grid b
mapRows NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
forall {a}. NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
f
 where
  f :: NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
f = NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
forall {a}. NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
rotational (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a))
-> (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a))
-> NonEmpty (NonEmpty a)
-> NonEmpty (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
forall {a}. NonEmpty a -> NonEmpty a
flipping
  flipV :: NonEmpty a -> NonEmpty a
flipV = NonEmpty a -> NonEmpty a
forall {a}. NonEmpty a -> NonEmpty a
NE.reverse
  flipping :: NonEmpty a -> NonEmpty a
flipping = if Bool
shouldFlip then NonEmpty a -> NonEmpty a
forall {a}. NonEmpty a -> NonEmpty a
flipV else NonEmpty a -> NonEmpty a
forall a. a -> a
id
  rotational :: NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
rotational = case AbsoluteDir
upDir of
    AbsoluteDir
DNorth -> NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
forall a. a -> a
id
    AbsoluteDir
DSouth -> NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
forall {a}. NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
NE.transpose (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a))
-> (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a))
-> NonEmpty (NonEmpty a)
-> NonEmpty (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
forall {a}. NonEmpty a -> NonEmpty a
flipV (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a))
-> (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a))
-> NonEmpty (NonEmpty a)
-> NonEmpty (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
forall {a}. NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
NE.transpose (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a))
-> (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a))
-> NonEmpty (NonEmpty a)
-> NonEmpty (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
forall {a}. NonEmpty a -> NonEmpty a
flipV
    AbsoluteDir
DEast -> NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
forall {a}. NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
NE.transpose (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a))
-> (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a))
-> NonEmpty (NonEmpty a)
-> NonEmpty (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
forall {a}. NonEmpty a -> NonEmpty a
flipV
    AbsoluteDir
DWest -> NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
forall {a}. NonEmpty a -> NonEmpty a
flipV (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a))
-> (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a))
-> NonEmpty (NonEmpty a)
-> NonEmpty (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
forall {a}. NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a)
NE.transpose

data Pose = Pose
  { Pose -> Location
offset :: Location
  , Pose -> Orientation
orient :: Orientation
  }
  deriving (Pose -> Pose -> Bool
(Pose -> Pose -> Bool) -> (Pose -> Pose -> Bool) -> Eq Pose
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Pose -> Pose -> Bool
== :: Pose -> Pose -> Bool
$c/= :: Pose -> Pose -> Bool
/= :: Pose -> Pose -> Bool
Eq, Int -> Pose -> ShowS
[Pose] -> ShowS
Pose -> String
(Int -> Pose -> ShowS)
-> (Pose -> String) -> ([Pose] -> ShowS) -> Show Pose
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pose -> ShowS
showsPrec :: Int -> Pose -> ShowS
$cshow :: Pose -> String
show :: Pose -> String
$cshowList :: [Pose] -> ShowS
showList :: [Pose] -> ShowS
Show)

data Placement = Placement
  { Placement -> StructureName
src :: StructureName
  , Placement -> Pose
structurePose :: Pose
  }
  deriving (Placement -> Placement -> Bool
(Placement -> Placement -> Bool)
-> (Placement -> Placement -> Bool) -> Eq Placement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Placement -> Placement -> Bool
== :: Placement -> Placement -> Bool
$c/= :: Placement -> Placement -> Bool
/= :: Placement -> Placement -> Bool
Eq, Int -> Placement -> ShowS
[Placement] -> ShowS
Placement -> String
(Int -> Placement -> ShowS)
-> (Placement -> String)
-> ([Placement] -> ShowS)
-> Show Placement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Placement -> ShowS
showsPrec :: Int -> Placement -> ShowS
$cshow :: Placement -> String
show :: Placement -> String
$cshowList :: [Placement] -> ShowS
showList :: [Placement] -> ShowS
Show)

instance FromJSON Placement where
  parseJSON :: Value -> Parser Placement
parseJSON = String -> (Object -> Parser Placement) -> Value -> Parser Placement
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"structure placement" ((Object -> Parser Placement) -> Value -> Parser Placement)
-> (Object -> Parser Placement) -> Value -> Parser Placement
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    StructureName
src <- Object
v Object -> Key -> Parser StructureName
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"src"
    Location
offset <- Object
v Object -> Key -> Parser (Maybe Location)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"offset" Parser (Maybe Location) -> Location -> Parser Location
forall a. Parser (Maybe a) -> a -> Parser a
.!= Location
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin
    Orientation
orient <- Object
v Object -> Key -> Parser (Maybe Orientation)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"orient" Parser (Maybe Orientation) -> Orientation -> Parser Orientation
forall a. Parser (Maybe a) -> a -> Parser a
.!= Orientation
defaultOrientation
    let structurePose :: Pose
structurePose = Location -> Orientation -> Pose
Pose Location
offset Orientation
orient
    Placement -> Parser Placement
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Placement {Pose
StructureName
src :: StructureName
structurePose :: Pose
src :: StructureName
structurePose :: Pose
..}