Overlay.hs

{-# 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
  { gridPosition :: Location
  -- ^ location of the upper-left cell
  , gridContent :: Grid a
  }
  deriving (Eq)

instance HasLocation (PositionedGrid a) where
  modifyLoc f (PositionedGrid originalLoc g) =
    PositionedGrid (f originalLoc) g

instance Show (PositionedGrid a) where
  show (PositionedGrid p g) =
    unwords
      [ "Grid with dimension"
      , renderRectDimensions $ getGridDimensions g
      , "located at"
      , show p
      ]

data OverlayPair a = OverlayPair
  { _base :: a
  , _overlay :: a
  }

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

getNorthwesternExtent :: Location -> Location -> Location
getNorthwesternExtent ul1 ul2 =
  Location westernMostX northernMostY
 where
  westernMostX = (min `on` view _x) ul1 ul2
  northernMostY = (max `on` view _y) ul1 ul2

getSoutheasternExtent :: Location -> Location -> Location
getSoutheasternExtent br1 br2 =
  Location easternMostX southernMostY
 where
  easternMostX = (max `on` view _x) br1 br2
  southernMostY = (min `on` view _y) br1 br2

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

getSubsumingRect :: PositionedGrid a -> SubsumingRect
getSubsumingRect (PositionedGrid loc g) =
  SubsumingRect loc $ computeBottomRightFromUpperLeft (getGridDimensions g) loc

computeMergedArea :: OverlayPair (PositionedGrid a) -> AreaDimensions
computeMergedArea (OverlayPair pg1 pg2) =
  cornersToArea ul br
 where
  SubsumingRect ul br = ((<>) `on` getSubsumingRect) pg1 pg2

zipGridRows ::
  Alternative f =>
  AreaDimensions ->
  OverlayPair [[f a]] ->
  Grid (f a)
zipGridRows dims (OverlayPair paddedBaseRows paddedOverlayRows) =
  mkGrid $ (pad2D paddedBaseRows . pad2D paddedOverlayRows) blankGrid
 where
  -- Right-biased; that is, takes the last non-empty value
  pad2D = zipPadded $ zipPadded $ flip (<|>)
  blankGrid = getRows $ fillGrid dims 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 baseLoc baseGrid) <> a2@(PositionedGrid overlayLoc overlayGrid) =
    PositionedGrid newUpperLeftCornerPosition combinedGrid
   where
    mergedSize = computeMergedArea $ OverlayPair a1 a2
    combinedGrid = zipGridRows mergedSize 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 = overlayLoc .-. baseLoc

    newUpperLeftCornerPosition = getNorthwesternExtent baseLoc overlayLoc

    paddedOverlayPair =
      padNorthwest upperLeftCornersDelta $
        OverlayPair baseGrid 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 (V2 deltaX deltaY) (OverlayPair baseGrid overlayGrid) =
  OverlayPair paddedBaseGrid paddedOverlayGrid
 where
  prefixPadDimension delta f = f (padding <>)
   where
    padding = replicate (abs $ fromIntegral delta) empty

  prefixPadRows = prefixPadDimension deltaY id
  prefixPadColumns = prefixPadDimension deltaX map

  -- Assume only the *overlay* requires vertical (top-)padding.
  -- However, if the conditional is true, then
  -- the *base* needs vertical padding instead.
  (baseVerticalPadFunc, overlayVerticalPadFunc) =
    applyWhen (deltaY > 0) swap (id, prefixPadRows)

  -- Assume only the *overlay* requires horizontal (left-)padding.
  -- However, if the conditional is true, then
  -- the *base* needs horizontal padding instead.
  (baseHorizontalPadFunc, overlayHorizontalPadFunc) =
    applyWhen (deltaX < 0) swap (id, prefixPadColumns)

  paddedBaseGrid = baseVerticalPadFunc $ baseHorizontalPadFunc $ getRows baseGrid
  paddedOverlayGrid = overlayVerticalPadFunc $ overlayHorizontalPadFunc $ getRows 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 _ [] ys = ys
zipPadded _ xs [] = xs
zipPadded f (x : xs) (y : ys) = f x y : zipPadded f xs ys