{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- Orphan JSON instances for Location and Heading

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Locations and headings.
module Swarm.Game.Location (
  Location,
  pattern Location,

  -- ** Heading and Direction functions
  Heading,
  applyTurn,
  relativeTo,
  toDirection,
  toAbsDirection,
  nearestDirection,
  fromDirection,
  isCardinal,
  north,
  south,
  east,
  west,

  -- ** Utility functions
  manhattan,
  euclidean,
  getElemsInArea,

  -- ** Re-exports for convenience
  Affine (..),
  Point (..),
  origin,
) where

import Control.Arrow ((&&&))
import Data.Aeson (FromJSONKey, ToJSONKey)
import Data.Function (on, (&))
import Data.Int (Int32)
import Data.Map (Map)
import Data.Map qualified as M
import Data.Yaml (FromJSON (parseJSON), ToJSON (toJSON))
import Linear (Additive (..), V2 (..), negated, norm, perp, unangle)
import Linear.Affine (Affine (..), Point (..), origin)
import Swarm.Language.Syntax (AbsoluteDir (..), Direction (..), PlanarRelativeDir (..), RelativeDir (..), isCardinal)
import Swarm.Util qualified as Util

-- $setup
-- >>> import qualified Data.Map as Map
-- >>> import Linear
-- >>> import Swarm.Language.Direction

-- | A t'Location' is a pair of @(x,y)@ coordinates, both up to 32 bits.
--   The positive x-axis points east and the positive y-axis points
--   north.  These are the coordinates that are shown to players.
--
--   See also the 'Swarm.Game.World.Coords' type defined in "Swarm.Game.World", which
--   use a (row, column) format instead, which is more convenient for
--   internal use.  The "Swarm.Game.World" module also defines
--   conversions between t'Location' and 'Swarm.Game.World.Coords'.
type Location = Point V2 Int32

-- | A convenient way to pattern-match on t'Location' values.
pattern Location :: Int32 -> Int32 -> Location
pattern $bLocation :: Int32 -> Int32 -> Location
$mLocation :: forall {r}. Location -> (Int32 -> Int32 -> r) -> ((# #) -> r) -> r
Location x y = P (V2 x y)

{-# COMPLETE Location #-}

instance FromJSON Location where
  parseJSON :: Value -> Parser Location
parseJSON = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. f a -> Point f a
P forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser a
parseJSON

instance ToJSON Location where
  toJSON :: Location -> Value
toJSON (P V2 Int32
v) = forall a. ToJSON a => a -> Value
toJSON V2 Int32
v

-- | A @Heading@ is a 2D vector, with 32-bit coordinates.
--
--   t'Location' and 'Heading' are both represented using types from
--   the @linear@ package, so they can be manipulated using a large
--   number of operators from that package.  For example:
--
--   * Two headings can be added with '^+^'.
--   * The difference between two t'Location's is a 'Heading' (via '.-.').
--   * A t'Location' plus a 'Heading' is another t'Location' (via 'Linear.Affine..^+').
type Heading = V2 Int32

deriving instance ToJSON (V2 Int32)
deriving instance FromJSON (V2 Int32)

deriving instance FromJSONKey (V2 Int32)
deriving instance ToJSONKey (V2 Int32)

toHeading :: AbsoluteDir -> Heading
toHeading :: AbsoluteDir -> V2 Int32
toHeading = \case
  AbsoluteDir
DNorth -> V2 Int32
north
  AbsoluteDir
DSouth -> V2 Int32
south
  AbsoluteDir
DEast -> V2 Int32
east
  AbsoluteDir
DWest -> V2 Int32
west

-- | The cardinal direction north = @V2 0 1@.
north :: Heading
north :: V2 Int32
north = forall a. a -> a -> V2 a
V2 Int32
0 Int32
1

-- | The cardinal direction south = @V2 0 (-1)@.
south :: Heading
south :: V2 Int32
south = forall a. a -> a -> V2 a
V2 Int32
0 (-Int32
1)

-- | The cardinal direction east = @V2 1 0@.
east :: Heading
east :: V2 Int32
east = forall a. a -> a -> V2 a
V2 Int32
1 Int32
0

-- | The cardinal direction west = @V2 (-1) 0@.
west :: Heading
west :: V2 Int32
west = forall a. a -> a -> V2 a
V2 (-Int32
1) Int32
0

-- | The direction for viewing the current cell = @V2 0 0@.
down :: Heading
down :: V2 Int32
down = forall (f :: * -> *) a. (Additive f, Num a) => f a
zero

-- | The 'applyTurn' function gives the meaning of each 'Direction' by
--   turning relative to the given heading or by turning to an absolute
--   heading.
--
--   >>> applyTurn (DRelative (DPlanar DLeft)) (V2 5 3)
--   V2 (-3) 5
--   >>> applyTurn (DAbsolute DWest) (V2 5 3)
--   V2 (-1) 0
applyTurn :: Direction -> Heading -> Heading
applyTurn :: Direction -> V2 Int32 -> V2 Int32
applyTurn Direction
d = case Direction
d of
  DRelative RelativeDir
e -> case RelativeDir
e of
    DPlanar PlanarRelativeDir
DLeft -> forall a. Num a => V2 a -> V2 a
perp
    DPlanar PlanarRelativeDir
DRight -> forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => V2 a -> V2 a
perp
    DPlanar PlanarRelativeDir
DBack -> forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated
    DPlanar PlanarRelativeDir
DForward -> forall a. a -> a
id
    RelativeDir
DDown -> forall a b. a -> b -> a
const V2 Int32
down
  DAbsolute AbsoluteDir
e -> forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ AbsoluteDir -> V2 Int32
toHeading AbsoluteDir
e

-- | Mapping from heading to their corresponding cardinal directions.
--   Only absolute directions are mapped.
cardinalDirs :: M.Map Heading AbsoluteDir
cardinalDirs :: Map (V2 Int32) AbsoluteDir
cardinalDirs =
  forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (AbsoluteDir -> V2 Int32
toHeading forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id) forall e. (Enum e, Bounded e) => [e]
Util.listEnums

-- | Possibly convert a heading into a 'Direction'---that is, if the
--   vector happens to be a unit vector in one of the cardinal
--   directions.
--
--   >>> toDirection (V2 0 (-1))
--   Just (DAbsolute DSouth)
--   >>> toDirection (V2 3 7)
--   Nothing
toDirection :: Heading -> Maybe Direction
toDirection :: V2 Int32 -> Maybe Direction
toDirection = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbsoluteDir -> Direction
DAbsolute forall b c a. (b -> c) -> (a -> b) -> a -> c
. V2 Int32 -> Maybe AbsoluteDir
toAbsDirection

-- | Like 'toDirection', but preserve the type guarantee of an absolute direction
toAbsDirection :: Heading -> Maybe AbsoluteDir
toAbsDirection :: V2 Int32 -> Maybe AbsoluteDir
toAbsDirection V2 Int32
v = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup V2 Int32
v Map (V2 Int32) AbsoluteDir
cardinalDirs

-- | Return the 'PlanarRelativeDir' which would result in turning to
--   the first (target) direction from the second (reference) direction.
--
--   >>> DWest `relativeTo` DSouth
--   DRight
--   >>> DWest `relativeTo` DWest
--   DForward
relativeTo :: AbsoluteDir -> AbsoluteDir -> PlanarRelativeDir
relativeTo :: AbsoluteDir -> AbsoluteDir -> PlanarRelativeDir
relativeTo AbsoluteDir
targetDir AbsoluteDir
referenceDir =
  forall a. Enum a => Int -> a
toEnum Int
indexDiff
 where
  enumCount :: Int
enumCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall e. (Enum e, Bounded e) => [e]
Util.listEnums :: [AbsoluteDir])
  indexDiff :: Int
indexDiff = ((-) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a. Enum a => a -> Int
fromEnum) AbsoluteDir
targetDir AbsoluteDir
referenceDir forall a. Integral a => a -> a -> a
`mod` Int
enumCount

-- | Compute the absolute direction nearest to a given 'Heading'.
--
--   Logic adapted from <https://gamedev.stackexchange.com/questions/49290/#comment213403_49300>.
nearestDirection :: Heading -> AbsoluteDir
nearestDirection :: V2 Int32 -> AbsoluteDir
nearestDirection V2 Int32
coord =
  forall b a. Integral b => NonEmpty a -> b -> a
Util.indexWrapNonEmpty NonEmpty AbsoluteDir
orderedDirs Int
index
 where
  angle :: Double
  angle :: Double
angle = forall a. (Floating a, Ord a) => V2 a -> a
unangle (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral V2 Int32
coord) forall a. Fractional a => a -> a -> a
/ (Double
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi)

  index :: Int
  index :: Int
index = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty AbsoluteDir
orderedDirs) forall a. Num a => a -> a -> a
* Double
angle
  orderedDirs :: NonEmpty AbsoluteDir
orderedDirs = forall e. (Enum e, Bounded e) => NonEmpty e
Util.listEnumsNonempty

-- | Convert a 'Direction' into a corresponding 'Heading'.  Note that
--   this only does something reasonable for 'DNorth', 'DSouth', 'DEast',
--   and 'DWest'---other 'Direction's return the zero vector.
fromDirection :: Direction -> Heading
fromDirection :: Direction -> V2 Int32
fromDirection = \case
  DAbsolute AbsoluteDir
x -> AbsoluteDir -> V2 Int32
toHeading AbsoluteDir
x
  Direction
_ -> forall (f :: * -> *) a. (Additive f, Num a) => f a
zero

-- | Manhattan distance between world locations.
manhattan :: Location -> Location -> Int32
manhattan :: Location -> Location -> Int32
manhattan (Location Int32
x1 Int32
y1) (Location Int32
x2 Int32
y2) = forall a. Num a => a -> a
abs (Int32
x1 forall a. Num a => a -> a -> a
- Int32
x2) forall a. Num a => a -> a -> a
+ forall a. Num a => a -> a
abs (Int32
y1 forall a. Num a => a -> a -> a
- Int32
y2)

-- | Euclidean distance between world locations.
euclidean :: Location -> Location -> Double
euclidean :: Location -> Location -> Double
euclidean Location
p1 Location
p2 = forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Location
p2 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Location
p1))

-- | Get elements that are within a certain manhattan distance from location.
--
-- >>> v2s i = [(p, manhattan origin p) | x <- [-i..i], y <- [-i..i], let p = Location x y]
-- >>> v2s 0
-- [(P (V2 0 0),0)]
-- >>> map (\i -> length (getElemsInArea origin i (Map.fromList $ v2s i))) [0..8]
-- [1,5,13,25,41,61,85,113,145]
--
-- The last test is the sequence "Centered square numbers":
-- https://oeis.org/A001844
getElemsInArea :: Location -> Int32 -> Map Location e -> [e]
getElemsInArea :: forall e. Location -> Int32 -> Map Location e -> [e]
getElemsInArea o :: Location
o@(Location Int32
x Int32
y) Int32
d Map Location e
m = forall k a. Map k a -> [a]
M.elems Map Location e
sm'
 where
  -- to be more efficient we basically split on first coordinate
  -- (which is logarithmic) and then we have to linearly filter
  -- the second coordinate to get a square - this is how it looks:
  --         ▲▲▲▲
  --         ││││    the arrows mark points that are greater then A
  --         ││s│                                 and lesser then B
  --         │sssB (2,1)
  --         ssoss   <-- o=(x=0,y=0) with d=2
  -- (-2,-1) Asss│
  --          │s││   the point o and all s are in manhattan
  --          ││││                  distance 2 from point o
  --          ▼▼▼▼
  sm :: Map Location e
sm =
    Map Location e
m
      forall a b. a -> (a -> b) -> b
& forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
M.split (Int32 -> Int32 -> Location
Location (Int32
x forall a. Num a => a -> a -> a
- Int32
d) (Int32
y forall a. Num a => a -> a -> a
- Int32
1)) -- A
      forall a b. a -> (a -> b) -> b
& forall a b. (a, b) -> b
snd -- A<
      forall a b. a -> (a -> b) -> b
& forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
M.split (Int32 -> Int32 -> Location
Location (Int32
x forall a. Num a => a -> a -> a
+ Int32
d) (Int32
y forall a. Num a => a -> a -> a
+ Int32
1)) -- B
      forall a b. a -> (a -> b) -> b
& forall a b. (a, b) -> a
fst -- B>
  sm' :: Map Location e
sm' = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Ord a => a -> a -> Bool
<= Int32
d) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> Location -> Int32
manhattan Location
o) Map Location e
sm