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

-- Orphan JSON instances for Location and Heading

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

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

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

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

import Control.Arrow ((&&&))
import Data.Aeson (FromJSONKey, ToJSONKey)
import Data.Function (on, (&))
import Data.Int (Int32)
import Data.List (nub)
import Data.List.Extra (enumerate)
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.Direction (AbsoluteDir (..), Direction (..), PlanarRelativeDir (..), RelativeDir (..), isCardinal)
import Swarm.Util qualified as Util

-- $setup
-- >>> import qualified Data.Map as Map
-- >>> import Linear
-- >>> import Swarm.Language.Syntax.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 '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 $mLocation :: forall {r}. Location -> (Int32 -> Int32 -> r) -> ((# #) -> r) -> r
$bLocation :: Int32 -> Int32 -> Location
Location x y = P (V2 x y)

{-# COMPLETE Location #-}

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

instance ToJSON Location where
  toJSON :: Location -> Value
toJSON (P Heading
v) = Heading -> Value
forall a. ToJSON a => a -> Value
toJSON Heading
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 -> Heading
toHeading = \case
  AbsoluteDir
DNorth -> Heading
north
  AbsoluteDir
DSouth -> Heading
south
  AbsoluteDir
DEast -> Heading
east
  AbsoluteDir
DWest -> Heading
west

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

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

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

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

-- | The direction for viewing the current cell = @V2 0 0@.
down :: Heading
down :: Heading
down = Heading
forall a. Num a => V2 a
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 -> Heading -> Heading
applyTurn Direction
d = case Direction
d of
  DRelative RelativeDir
e -> case RelativeDir
e of
    DPlanar PlanarRelativeDir
DLeft -> Heading -> Heading
forall a. Num a => V2 a -> V2 a
perp
    DPlanar PlanarRelativeDir
DRight -> Heading -> Heading
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated (Heading -> Heading) -> (Heading -> Heading) -> Heading -> Heading
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Heading -> Heading
forall a. Num a => V2 a -> V2 a
perp
    DPlanar PlanarRelativeDir
DBack -> Heading -> Heading
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated
    DPlanar PlanarRelativeDir
DForward -> Heading -> Heading
forall a. a -> a
id
    RelativeDir
DDown -> Heading -> Heading -> Heading
forall a b. a -> b -> a
const Heading
down
  DAbsolute AbsoluteDir
e -> Heading -> Heading -> Heading
forall a b. a -> b -> a
const (Heading -> Heading -> Heading) -> Heading -> Heading -> Heading
forall a b. (a -> b) -> a -> b
$ AbsoluteDir -> Heading
toHeading AbsoluteDir
e

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

-- | 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 :: Heading -> Maybe Direction
toDirection = (AbsoluteDir -> Direction) -> Maybe AbsoluteDir -> Maybe Direction
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbsoluteDir -> Direction
DAbsolute (Maybe AbsoluteDir -> Maybe Direction)
-> (Heading -> Maybe AbsoluteDir) -> Heading -> Maybe Direction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Heading -> Maybe AbsoluteDir
toAbsDirection

-- | Like 'toDirection', but preserve the type guarantee of an absolute direction
toAbsDirection :: Heading -> Maybe AbsoluteDir
toAbsDirection :: Heading -> Maybe AbsoluteDir
toAbsDirection Heading
v = Heading -> Map Heading AbsoluteDir -> Maybe AbsoluteDir
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Heading
v Map Heading 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 =
  Int -> PlanarRelativeDir
forall a. Enum a => Int -> a
toEnum Int
indexDiff
 where
  enumCount :: Int
enumCount = [AbsoluteDir] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([AbsoluteDir]
forall a. (Enum a, Bounded a) => [a]
enumerate :: [AbsoluteDir])
  indexDiff :: Int
indexDiff = ((-) (Int -> Int -> Int)
-> (AbsoluteDir -> Int) -> AbsoluteDir -> AbsoluteDir -> Int
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` AbsoluteDir -> Int
forall a. Enum a => a -> Int
fromEnum) AbsoluteDir
targetDir AbsoluteDir
referenceDir Int -> Int -> Int
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 :: Heading -> AbsoluteDir
nearestDirection Heading
coord =
  NonEmpty AbsoluteDir -> Int -> AbsoluteDir
forall b a. Integral b => NonEmpty a -> b -> a
Util.indexWrapNonEmpty NonEmpty AbsoluteDir
orderedDirs Int
index
 where
  angle :: Double
  angle :: Double
angle = V2 Double -> Double
forall a. (Floating a, Ord a) => V2 a -> a
unangle ((Int32 -> Double) -> Heading -> V2 Double
forall a b. (a -> b) -> V2 a -> V2 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Heading
coord) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi)

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

-- | 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 -> Heading
fromDirection = \case
  DAbsolute AbsoluteDir
x -> AbsoluteDir -> Heading
toHeading AbsoluteDir
x
  Direction
_ -> Heading
forall a. Num a => V2 a
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) = Int32 -> Int32
forall a. Num a => a -> a
abs (Int32
x1 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
x2) Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32 -> Int32
forall a. Num a => a -> a
abs (Int32
y1 Int32 -> Int32 -> Int32
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 = V2 Double -> Double
forall a. Floating a => V2 a -> a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm (Int32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Double) -> Heading -> V2 Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Location
p2 Location -> Location -> Diff (Point V2) Int32
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Location
p1))

-- | Get all the locations that are within a certain manhattan
--   distance from a given location.
--
-- >>> getLocsInArea (P (V2 0 0)) 1
-- [P (V2 0 0),P (V2 0 1),P (V2 0 (-1)),P (V2 1 0),P (V2 (-1) 0)]
-- >>> map (\i -> length (getLocsInArea origin i)) [0..8]
-- [1,5,13,25,41,61,85,113,145]
--
--   See also @Swarm.Game.Step.Const.genDiamondSides@.
getLocsInArea :: Location -> Int32 -> [Location]
getLocsInArea :: Location -> Int32 -> [Location]
getLocsInArea Location
loc Int32
r =
  [Location
loc Location -> Diff (Point V2) Int32 -> Location
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ Int32 -> Int32 -> Heading
forall a. a -> a -> V2 a
V2 Int32
dx Int32
dy | Int32
x <- [Int32
0 .. Int32
r], Int32
y <- [Int32
0 .. Int32
r Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
x], Int32
dx <- [Int32] -> [Int32]
forall a. Eq a => [a] -> [a]
nub [Int32
x, -Int32
x], Int32
dy <- [Int32] -> [Int32]
forall a. Eq a => [a] -> [a]
nub [Int32
y, -Int32
y]]

-- | 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 = Map Location e -> [e]
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
      Map Location e
-> (Map Location e -> (Map Location e, Map Location e))
-> (Map Location e, Map Location e)
forall a b. a -> (a -> b) -> b
& Location -> Map Location e -> (Map Location e, Map Location e)
forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
M.split (Int32 -> Int32 -> Location
Location (Int32
x Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
d) (Int32
y Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
1)) -- A
      (Map Location e, Map Location e)
-> ((Map Location e, Map Location e) -> Map Location e)
-> Map Location e
forall a b. a -> (a -> b) -> b
& (Map Location e, Map Location e) -> Map Location e
forall a b. (a, b) -> b
snd -- A<
      Map Location e
-> (Map Location e -> (Map Location e, Map Location e))
-> (Map Location e, Map Location e)
forall a b. a -> (a -> b) -> b
& Location -> Map Location e -> (Map Location e, Map Location e)
forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
M.split (Int32 -> Int32 -> Location
Location (Int32
x Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
d) (Int32
y Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
1)) -- B
      (Map Location e, Map Location e)
-> ((Map Location e, Map Location e) -> Map Location e)
-> Map Location e
forall a b. a -> (a -> b) -> b
& (Map Location e, Map Location e) -> Map Location e
forall a b. (a, b) -> a
fst -- B>
  sm' :: Map Location e
sm' = (Location -> e -> Bool) -> Map Location e -> Map Location e
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (Bool -> e -> Bool
forall a b. a -> b -> a
const (Bool -> e -> Bool) -> (Location -> Bool) -> Location -> e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int32
d) (Int32 -> Bool) -> (Location -> Int32) -> Location -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> Location -> Int32
manhattan Location
o) Map Location e
sm

-- * Locatable things

class HasLocation a where
  -- | Basically 'fmap' for the 'Location' field of a record
  modifyLoc :: (Location -> Location) -> a -> a

  -- | Translation by a vector
  offsetLoc :: V2 Int32 -> a -> a
  offsetLoc Heading
locOffset = (Location -> Location) -> a -> a
forall a. HasLocation a => (Location -> Location) -> a -> a
modifyLoc (Location -> Diff (Point V2) Int32 -> Location
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ Heading
Diff (Point V2) Int32
locOffset)