{-# 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,
  nearestDirection,
  fromDirection,
  isCardinal,
  north,
  south,
  east,
  west,

  -- ** utility functions
  manhattan,
  euclidean,
  getElemsInArea,

  -- ** reexports 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

-- | A 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 '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 'Location' and 'Coords'.
type Location = Point V2 Int32

-- | A convenient way to pattern-match on '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.
--
--   '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 'Location's is a 'Heading' (via '.-.').
--   * A 'Location' plus a 'Heading' is another 'Location' (via '.^+').
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 :: 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 Direction
cardinalDirs :: Map (V2 Int32) Direction
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')
&&& AbsoluteDir -> Direction
DAbsolute) 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 :: Heading -> Maybe Direction
toDirection :: V2 Int32 -> Maybe Direction
toDirection V2 Int32
v = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup V2 Int32
v Map (V2 Int32) Direction
cardinalDirs

-- | Example:
--      DWest `relativeTo` DSouth == DRight
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

-- | Logic adapted from:
-- https://gamedev.stackexchange.com/questions/49290/#comment213403_49300
nearestDirection :: Heading -> AbsoluteDir
nearestDirection :: V2 Int32 -> AbsoluteDir
nearestDirection V2 Int32
coord =
  [AbsoluteDir]
orderedDirs forall a. [a] -> Int -> a
!! 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 = forall a b. (RealFrac a, Integral b) => a -> b
round (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
enumCount forall a. Num a => a -> a -> a
* Double
angle) forall a. Integral a => a -> a -> a
`mod` Int
enumCount
  orderedDirs :: [AbsoluteDir]
orderedDirs = forall e. (Enum e, Bounded e) => [e]
Util.listEnums
  enumCount :: Int
enumCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length [AbsoluteDir]
orderedDirs

-- | 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 in 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