{-# LANGUAGE OverloadedStrings #-}

-- |
-- 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 (transpose)
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.Language.Syntax (AbsoluteDir (..))

newtype StructureName = StructureName Text
  deriving (StructureName -> StructureName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StructureName -> StructureName -> Bool
$c/= :: StructureName -> StructureName -> Bool
== :: StructureName -> StructureName -> Bool
$c== :: StructureName -> StructureName -> Bool
Eq, Eq 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
min :: StructureName -> StructureName -> StructureName
$cmin :: StructureName -> StructureName -> StructureName
max :: StructureName -> StructureName -> StructureName
$cmax :: StructureName -> StructureName -> StructureName
>= :: StructureName -> StructureName -> Bool
$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
compare :: StructureName -> StructureName -> Ordering
$ccompare :: StructureName -> StructureName -> Ordering
Ord, Int -> StructureName -> ShowS
[StructureName] -> ShowS
StructureName -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StructureName] -> ShowS
$cshowList :: [StructureName] -> ShowS
show :: StructureName -> String
$cshow :: StructureName -> String
showsPrec :: Int -> StructureName -> ShowS
$cshowsPrec :: Int -> StructureName -> ShowS
Show, 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
$cto :: forall x. Rep StructureName x -> StructureName
$cfrom :: forall x. StructureName -> Rep StructureName x
Generic, Value -> Parser [StructureName]
Value -> Parser StructureName
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [StructureName]
$cparseJSONList :: Value -> Parser [StructureName]
parseJSON :: Value -> Parser StructureName
$cparseJSON :: Value -> Parser StructureName
FromJSON)

-- | 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Orientation -> Orientation -> Bool
$c/= :: Orientation -> Orientation -> Bool
== :: Orientation -> Orientation -> Bool
$c== :: Orientation -> Orientation -> Bool
Eq, Int -> Orientation -> ShowS
[Orientation] -> ShowS
Orientation -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Orientation] -> ShowS
$cshowList :: [Orientation] -> ShowS
show :: Orientation -> String
$cshow :: Orientation -> String
showsPrec :: Int -> Orientation -> ShowS
$cshowsPrec :: Int -> Orientation -> ShowS
Show)

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

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

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

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

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

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