{-# 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.Yaml as Y
import Swarm.Game.Location
import Swarm.Game.Scenario.Topography.Area (
  AreaDimensions (..),
 )
import Swarm.Game.Scenario.Topography.Grid
import Swarm.Game.Scenario.Topography.Structure.Named (
  StructureName,
 )
import Swarm.Language.Syntax.Direction (AbsoluteDir (..))
import Swarm.Util (applyWhen)

-- | 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 = Bool -> (Location -> Location) -> Location -> Location
forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
shouldFlip Location -> Location
flipV
  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

applyOrientationTransform ::
  Orientation ->
  Grid a ->
  Grid a
applyOrientationTransform :: forall a. Orientation -> Grid a -> Grid a
applyOrientationTransform Orientation
_ Grid a
EmptyGrid = Grid a
forall c. Grid c
EmptyGrid
applyOrientationTransform Orientation
f (Grid NonEmptyGrid a
g) = NonEmptyGrid a -> Grid a
forall c. NonEmptyGrid c -> Grid c
Grid (NonEmptyGrid a -> Grid a) -> NonEmptyGrid a -> Grid a
forall a b. (a -> b) -> a -> b
$ Orientation -> NonEmptyGrid a -> NonEmptyGrid a
forall a. Orientation -> NonEmptyGrid a -> NonEmptyGrid a
applyOrientationTransformNE Orientation
f NonEmptyGrid a
g

-- | affine transformation
applyOrientationTransformNE :: Orientation -> NonEmptyGrid a -> NonEmptyGrid a
applyOrientationTransformNE :: forall a. Orientation -> NonEmptyGrid a -> NonEmptyGrid a
applyOrientationTransformNE (Orientation AbsoluteDir
upDir Bool
shouldFlip) =
  (NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a))
-> NonEmptyGrid a -> NonEmptyGrid a
forall a b.
(NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty b))
-> NonEmptyGrid a -> NonEmptyGrid b
mapRowsNE 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 = Bool -> (NonEmpty a -> NonEmpty a) -> NonEmpty a -> NonEmpty a
forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
shouldFlip NonEmpty a -> NonEmpty a
forall {a}. NonEmpty a -> NonEmpty a
flipV
  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 {StructureName
Pose
src :: StructureName
structurePose :: Pose
src :: StructureName
structurePose :: Pose
..}