{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Generic overlay operations on grids
module Swarm.Game.Scenario.Topography.Structure.Overlay (
  PositionedGrid (..),

  -- * Exported for unit tests
  computeMergedArea,
  OverlayPair (..),
) where

import Control.Applicative
import Control.Lens (view)
import Data.Function (on)
import Data.Int (Int32)
import Data.Tuple (swap)
import Linear.V2 (R1 (_x), R2 (_y), V2 (..))
import Swarm.Game.Location
import Swarm.Game.Scenario.Topography.Area
import Swarm.Game.Scenario.Topography.Grid
import Swarm.Util (applyWhen)

data PositionedGrid a = PositionedGrid
  { forall a. PositionedGrid a -> Location
gridPosition :: Location
  -- ^ location of the upper-left cell
  , forall a. PositionedGrid a -> Grid a
gridContent :: Grid a
  }
  deriving (PositionedGrid a -> PositionedGrid a -> Bool
(PositionedGrid a -> PositionedGrid a -> Bool)
-> (PositionedGrid a -> PositionedGrid a -> Bool)
-> Eq (PositionedGrid a)
forall a. Eq a => PositionedGrid a -> PositionedGrid a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => PositionedGrid a -> PositionedGrid a -> Bool
== :: PositionedGrid a -> PositionedGrid a -> Bool
$c/= :: forall a. Eq a => PositionedGrid a -> PositionedGrid a -> Bool
/= :: PositionedGrid a -> PositionedGrid a -> Bool
Eq)

instance HasLocation (PositionedGrid a) where
  modifyLoc :: (Location -> Location) -> PositionedGrid a -> PositionedGrid a
modifyLoc Location -> Location
f (PositionedGrid Location
originalLoc Grid a
g) =
    Location -> Grid a -> PositionedGrid a
forall a. Location -> Grid a -> PositionedGrid a
PositionedGrid (Location -> Location
f Location
originalLoc) Grid a
g

instance Show (PositionedGrid a) where
  show :: PositionedGrid a -> String
show (PositionedGrid Location
p Grid a
g) =
    [String] -> String
unwords
      [ String
"Grid with dimension"
      , AreaDimensions -> String
renderRectDimensions (AreaDimensions -> String) -> AreaDimensions -> String
forall a b. (a -> b) -> a -> b
$ Grid a -> AreaDimensions
forall a. Grid a -> AreaDimensions
getGridDimensions Grid a
g
      , String
"located at"
      , Location -> String
forall a. Show a => a -> String
show Location
p
      ]

data OverlayPair a = OverlayPair
  { forall a. OverlayPair a -> a
_base :: a
  , forall a. OverlayPair a -> a
_overlay :: a
  }

-- | Has a 'Semigroup' instance to determine the smallest
-- bounds that enclose two rectangles
data SubsumingRect = SubsumingRect
  { SubsumingRect -> Location
_northwestCorner :: Location
  , SubsumingRect -> Location
_southeastCorner :: Location
  }

getNorthwesternExtent :: Location -> Location -> Location
getNorthwesternExtent :: Location -> Location -> Location
getNorthwesternExtent Location
ul1 Location
ul2 =
  Int32 -> Int32 -> Location
Location Int32
westernMostX Int32
northernMostY
 where
  westernMostX :: Int32
westernMostX = (Int32 -> Int32 -> Int32
forall a. Ord a => a -> a -> a
min (Int32 -> Int32 -> Int32)
-> (Location -> Int32) -> Location -> Location -> Int32
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Getting Int32 Location Int32 -> Location -> Int32
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int32 Location Int32
forall a. Lens' (Point V2 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) Location
ul1 Location
ul2
  northernMostY :: Int32
northernMostY = (Int32 -> Int32 -> Int32
forall a. Ord a => a -> a -> a
max (Int32 -> Int32 -> Int32)
-> (Location -> Int32) -> Location -> Location -> Int32
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Getting Int32 Location Int32 -> Location -> Int32
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int32 Location Int32
forall a. Lens' (Point V2 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) Location
ul1 Location
ul2

getSoutheasternExtent :: Location -> Location -> Location
getSoutheasternExtent :: Location -> Location -> Location
getSoutheasternExtent Location
br1 Location
br2 =
  Int32 -> Int32 -> Location
Location Int32
easternMostX Int32
southernMostY
 where
  easternMostX :: Int32
easternMostX = (Int32 -> Int32 -> Int32
forall a. Ord a => a -> a -> a
max (Int32 -> Int32 -> Int32)
-> (Location -> Int32) -> Location -> Location -> Int32
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Getting Int32 Location Int32 -> Location -> Int32
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int32 Location Int32
forall a. Lens' (Point V2 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) Location
br1 Location
br2
  southernMostY :: Int32
southernMostY = (Int32 -> Int32 -> Int32
forall a. Ord a => a -> a -> a
min (Int32 -> Int32 -> Int32)
-> (Location -> Int32) -> Location -> Location -> Int32
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Getting Int32 Location Int32 -> Location -> Int32
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int32 Location Int32
forall a. Lens' (Point V2 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) Location
br1 Location
br2

-- | @r1 <> r2@ is the smallest rectangle that contains both @r1@ and @r2@.
instance Semigroup SubsumingRect where
  SubsumingRect Location
ul1 Location
br1 <> :: SubsumingRect -> SubsumingRect -> SubsumingRect
<> SubsumingRect Location
ul2 Location
br2 =
    Location -> Location -> SubsumingRect
SubsumingRect Location
northwesternExtent Location
southeasternExtent
   where
    northwesternExtent :: Location
northwesternExtent = Location -> Location -> Location
getNorthwesternExtent Location
ul1 Location
ul2
    southeasternExtent :: Location
southeasternExtent = Location -> Location -> Location
getSoutheasternExtent Location
br1 Location
br2

getSubsumingRect :: PositionedGrid a -> SubsumingRect
getSubsumingRect :: forall a. PositionedGrid a -> SubsumingRect
getSubsumingRect (PositionedGrid Location
loc Grid a
g) =
  Location -> Location -> SubsumingRect
SubsumingRect Location
loc (Location -> SubsumingRect) -> Location -> SubsumingRect
forall a b. (a -> b) -> a -> b
$ AreaDimensions -> Location -> Location
computeBottomRightFromUpperLeft (Grid a -> AreaDimensions
forall a. Grid a -> AreaDimensions
getGridDimensions Grid a
g) Location
loc

computeMergedArea :: OverlayPair (PositionedGrid a) -> AreaDimensions
computeMergedArea :: forall a. OverlayPair (PositionedGrid a) -> AreaDimensions
computeMergedArea (OverlayPair PositionedGrid a
pg1 PositionedGrid a
pg2) =
  Location -> Location -> AreaDimensions
cornersToArea Location
ul Location
br
 where
  SubsumingRect Location
ul Location
br = (SubsumingRect -> SubsumingRect -> SubsumingRect
forall a. Semigroup a => a -> a -> a
(<>) (SubsumingRect -> SubsumingRect -> SubsumingRect)
-> (PositionedGrid a -> SubsumingRect)
-> PositionedGrid a
-> PositionedGrid a
-> SubsumingRect
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` PositionedGrid a -> SubsumingRect
forall a. PositionedGrid a -> SubsumingRect
getSubsumingRect) PositionedGrid a
pg1 PositionedGrid a
pg2

zipGridRows ::
  Alternative f =>
  AreaDimensions ->
  OverlayPair [[f a]] ->
  Grid (f a)
zipGridRows :: forall (f :: * -> *) a.
Alternative f =>
AreaDimensions -> OverlayPair [[f a]] -> Grid (f a)
zipGridRows AreaDimensions
dims (OverlayPair [[f a]]
paddedBaseRows [[f a]]
paddedOverlayRows) =
  [[f a]] -> Grid (f a)
forall a. [[a]] -> Grid a
mkGrid ([[f a]] -> Grid (f a)) -> [[f a]] -> Grid (f a)
forall a b. (a -> b) -> a -> b
$ ([[f a]] -> [[f a]] -> [[f a]]
forall {a}. [[f a]] -> [[f a]] -> [[f a]]
pad2D [[f a]]
paddedBaseRows ([[f a]] -> [[f a]]) -> ([[f a]] -> [[f a]]) -> [[f a]] -> [[f a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[f a]] -> [[f a]] -> [[f a]]
forall {a}. [[f a]] -> [[f a]] -> [[f a]]
pad2D [[f a]]
paddedOverlayRows) [[f a]]
forall {a}. [[f a]]
blankGrid
 where
  -- Right-biased; that is, takes the last non-empty value
  pad2D :: [[f a]] -> [[f a]] -> [[f a]]
pad2D = ([f a] -> [f a] -> [f a]) -> [[f a]] -> [[f a]] -> [[f a]]
forall a. (a -> a -> a) -> [a] -> [a] -> [a]
zipPadded (([f a] -> [f a] -> [f a]) -> [[f a]] -> [[f a]] -> [[f a]])
-> ([f a] -> [f a] -> [f a]) -> [[f a]] -> [[f a]] -> [[f a]]
forall a b. (a -> b) -> a -> b
$ (f a -> f a -> f a) -> [f a] -> [f a] -> [f a]
forall a. (a -> a -> a) -> [a] -> [a] -> [a]
zipPadded ((f a -> f a -> f a) -> [f a] -> [f a] -> [f a])
-> (f a -> f a -> f a) -> [f a] -> [f a] -> [f a]
forall a b. (a -> b) -> a -> b
$ (f a -> f a -> f a) -> f a -> f a -> f a
forall a b c. (a -> b -> c) -> b -> a -> c
flip f a -> f a -> f a
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
  blankGrid :: [[f a]]
blankGrid = Grid (f a) -> [[f a]]
forall a. Grid a -> [[a]]
getRows (Grid (f a) -> [[f a]]) -> Grid (f a) -> [[f a]]
forall a b. (a -> b) -> a -> b
$ AreaDimensions -> f a -> Grid (f a)
forall a. AreaDimensions -> a -> Grid a
fillGrid AreaDimensions
dims f a
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty

-- |
-- First arg: base layer
-- Second arg: overlay layer
--
-- The upper-left corner of the base layer is the original "origin".
--
-- If the overlay is to the west or north of the base layer,
-- then we must pad the base layer on the left or top.
-- And since the area expands relative to the "origin" of the
-- base layer, we must shift the combined grid's "origin" location
-- to the new position of the base layer's upper-left corner.
--
-- If the overlay is to the east/south, we do not have to
-- modify the origin, since no padding is added to the left/top
-- of the base layer.
instance (Alternative f) => Semigroup (PositionedGrid (f a)) where
  a1 :: PositionedGrid (f a)
a1@(PositionedGrid Location
baseLoc Grid (f a)
baseGrid) <> :: PositionedGrid (f a)
-> PositionedGrid (f a) -> PositionedGrid (f a)
<> a2 :: PositionedGrid (f a)
a2@(PositionedGrid Location
overlayLoc Grid (f a)
overlayGrid) =
    Location -> Grid (f a) -> PositionedGrid (f a)
forall a. Location -> Grid a -> PositionedGrid a
PositionedGrid Location
newUpperLeftCornerPosition Grid (f a)
combinedGrid
   where
    mergedSize :: AreaDimensions
mergedSize = OverlayPair (PositionedGrid (f a)) -> AreaDimensions
forall a. OverlayPair (PositionedGrid a) -> AreaDimensions
computeMergedArea (OverlayPair (PositionedGrid (f a)) -> AreaDimensions)
-> OverlayPair (PositionedGrid (f a)) -> AreaDimensions
forall a b. (a -> b) -> a -> b
$ PositionedGrid (f a)
-> PositionedGrid (f a) -> OverlayPair (PositionedGrid (f a))
forall a. a -> a -> OverlayPair a
OverlayPair PositionedGrid (f a)
a1 PositionedGrid (f a)
a2
    combinedGrid :: Grid (f a)
combinedGrid = AreaDimensions -> OverlayPair [[f a]] -> Grid (f a)
forall (f :: * -> *) a.
Alternative f =>
AreaDimensions -> OverlayPair [[f a]] -> Grid (f a)
zipGridRows AreaDimensions
mergedSize OverlayPair [[f a]]
paddedOverlayPair

    -- We create a vector from the overlay position,
    -- such that the displacement vector will have:
    -- \* negative X component if the origin must be shifted east
    -- \* positive Y component if the origin must be shifted south
    upperLeftCornersDelta :: Diff (Point V2) Int32
upperLeftCornersDelta = Location
overlayLoc 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
baseLoc

    newUpperLeftCornerPosition :: Location
newUpperLeftCornerPosition = Location -> Location -> Location
getNorthwesternExtent Location
baseLoc Location
overlayLoc

    paddedOverlayPair :: OverlayPair [[f a]]
paddedOverlayPair =
      V2 Int32 -> OverlayPair (Grid (f a)) -> OverlayPair [[f a]]
forall (f :: * -> *) a.
Alternative f =>
V2 Int32 -> OverlayPair (Grid (f a)) -> OverlayPair [[f a]]
padNorthwest V2 Int32
upperLeftCornersDelta (OverlayPair (Grid (f a)) -> OverlayPair [[f a]])
-> OverlayPair (Grid (f a)) -> OverlayPair [[f a]]
forall a b. (a -> b) -> a -> b
$
        Grid (f a) -> Grid (f a) -> OverlayPair (Grid (f a))
forall a. a -> a -> OverlayPair a
OverlayPair Grid (f a)
baseGrid Grid (f a)
overlayGrid

-- |
-- 'deltaX' and 'deltaY' refer to the positioning of the *overlay grid*
-- relative to the *base grid*.
-- A negative 'deltaY' means that the top edge of the overlay
-- lies to the south of the top edge of the base grid.
-- A positive 'deltaX' means that the left edge of the overlay
-- lies to the east of the left edge of base grid.
--
-- We add padding to either the overlay grid or the base grid
-- so as to align their upper-left corners.
--
-- NOTE: We only make explicit grid adjustments for
-- left/top padding.  Any padding that is needed on the right/bottom
-- of either grid will be taken care of by the 'zipPadded' function.
--
-- TODO(#2004): The return type should be 'Grid'.
padNorthwest ::
  Alternative f =>
  V2 Int32 ->
  OverlayPair (Grid (f a)) ->
  OverlayPair [[f a]]
padNorthwest :: forall (f :: * -> *) a.
Alternative f =>
V2 Int32 -> OverlayPair (Grid (f a)) -> OverlayPair [[f a]]
padNorthwest (V2 Int32
deltaX Int32
deltaY) (OverlayPair Grid (f a)
baseGrid Grid (f a)
overlayGrid) =
  [[f a]] -> [[f a]] -> OverlayPair [[f a]]
forall a. a -> a -> OverlayPair a
OverlayPair [[f a]]
paddedBaseGrid [[f a]]
paddedOverlayGrid
 where
  prefixPadDimension :: p -> (([f a] -> [f a]) -> t) -> t
prefixPadDimension p
delta ([f a] -> [f a]) -> t
f = ([f a] -> [f a]) -> t
f ([f a]
forall {a}. [f a]
padding [f a] -> [f a] -> [f a]
forall a. Semigroup a => a -> a -> a
<>)
   where
    padding :: [f a]
padding = Int -> f a -> [f a]
forall a. Int -> a -> [a]
replicate (Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ p -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
delta) f a
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty

  prefixPadRows :: [[a]] -> [[a]]
prefixPadRows = Int32 -> (([[a]] -> [[a]]) -> [[a]] -> [[a]]) -> [[a]] -> [[a]]
forall {p} {f :: * -> *} {a} {t}.
(Integral p, Alternative f) =>
p -> (([f a] -> [f a]) -> t) -> t
prefixPadDimension Int32
deltaY ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a. a -> a
id
  prefixPadColumns :: [[f a]] -> [[f a]]
prefixPadColumns = Int32
-> (([f a] -> [f a]) -> [[f a]] -> [[f a]]) -> [[f a]] -> [[f a]]
forall {p} {f :: * -> *} {a} {t}.
(Integral p, Alternative f) =>
p -> (([f a] -> [f a]) -> t) -> t
prefixPadDimension Int32
deltaX ([f a] -> [f a]) -> [[f a]] -> [[f a]]
forall a b. (a -> b) -> [a] -> [b]
map

  -- Assume only the *overlay* requires vertical (top-)padding.
  -- However, if the conditional is true, then
  -- the *base* needs vertical padding instead.
  ([[a]] -> [[a]]
baseVerticalPadFunc, [[a]] -> [[a]]
overlayVerticalPadFunc) =
    Bool
-> (([[a]] -> [[a]], [[a]] -> [[a]])
    -> ([[a]] -> [[a]], [[a]] -> [[a]]))
-> ([[a]] -> [[a]], [[a]] -> [[a]])
-> ([[a]] -> [[a]], [[a]] -> [[a]])
forall a. Bool -> (a -> a) -> a -> a
applyWhen (Int32
deltaY Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> Int32
0) ([[a]] -> [[a]], [[a]] -> [[a]])
-> ([[a]] -> [[a]], [[a]] -> [[a]])
forall a b. (a, b) -> (b, a)
swap ([[a]] -> [[a]]
forall a. a -> a
id, [[a]] -> [[a]]
forall {a}. [[a]] -> [[a]]
prefixPadRows)

  -- Assume only the *overlay* requires horizontal (left-)padding.
  -- However, if the conditional is true, then
  -- the *base* needs horizontal padding instead.
  ([[f a]] -> [[f a]]
baseHorizontalPadFunc, [[f a]] -> [[f a]]
overlayHorizontalPadFunc) =
    Bool
-> (([[f a]] -> [[f a]], [[f a]] -> [[f a]])
    -> ([[f a]] -> [[f a]], [[f a]] -> [[f a]]))
-> ([[f a]] -> [[f a]], [[f a]] -> [[f a]])
-> ([[f a]] -> [[f a]], [[f a]] -> [[f a]])
forall a. Bool -> (a -> a) -> a -> a
applyWhen (Int32
deltaX Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
0) ([[f a]] -> [[f a]], [[f a]] -> [[f a]])
-> ([[f a]] -> [[f a]], [[f a]] -> [[f a]])
forall a b. (a, b) -> (b, a)
swap ([[f a]] -> [[f a]]
forall a. a -> a
id, [[f a]] -> [[f a]]
forall {a}. [[f a]] -> [[f a]]
prefixPadColumns)

  paddedBaseGrid :: [[f a]]
paddedBaseGrid = [[f a]] -> [[f a]]
forall {a}. [[a]] -> [[a]]
baseVerticalPadFunc ([[f a]] -> [[f a]]) -> [[f a]] -> [[f a]]
forall a b. (a -> b) -> a -> b
$ [[f a]] -> [[f a]]
forall {a}. [[f a]] -> [[f a]]
baseHorizontalPadFunc ([[f a]] -> [[f a]]) -> [[f a]] -> [[f a]]
forall a b. (a -> b) -> a -> b
$ Grid (f a) -> [[f a]]
forall a. Grid a -> [[a]]
getRows Grid (f a)
baseGrid
  paddedOverlayGrid :: [[f a]]
paddedOverlayGrid = [[f a]] -> [[f a]]
forall {a}. [[a]] -> [[a]]
overlayVerticalPadFunc ([[f a]] -> [[f a]]) -> [[f a]] -> [[f a]]
forall a b. (a -> b) -> a -> b
$ [[f a]] -> [[f a]]
forall {a}. [[f a]] -> [[f a]]
overlayHorizontalPadFunc ([[f a]] -> [[f a]]) -> [[f a]] -> [[f a]]
forall a b. (a -> b) -> a -> b
$ Grid (f a) -> [[f a]]
forall a. Grid a -> [[a]]
getRows Grid (f a)
overlayGrid

-- * Utils

-- | Apply a function to combine elements from two lists
-- of potentially different lengths.
-- Produces a result with length equal to the longer list.
-- Elements from the longer list are placed directly in the
-- resulting list when the shorter list runs out of elements.
zipPadded :: (a -> a -> a) -> [a] -> [a] -> [a]
zipPadded :: forall a. (a -> a -> a) -> [a] -> [a] -> [a]
zipPadded a -> a -> a
_ [] [a]
ys = [a]
ys
zipPadded a -> a -> a
_ [a]
xs [] = [a]
xs
zipPadded a -> a -> a
f (a
x : [a]
xs) (a
y : [a]
ys) = a -> a -> a
f a
x a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> a -> a) -> [a] -> [a] -> [a]
forall a. (a -> a -> a) -> [a] -> [a] -> [a]
zipPadded a -> a -> a
f [a]
xs [a]
ys