TestOverlay.hs

{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Unit tests for generic grid overlay logic
module TestOverlay (testOverlay) where

import Control.Monad (when)
import Data.Function (on)
import Data.Text (Text)
import Swarm.Game.Location
import Swarm.Game.Scenario.Topography.Area (
  AreaDimensions (AreaDimensions),
 )
import Swarm.Game.Scenario.Topography.Grid
import Swarm.Game.Scenario.Topography.Placement
import Swarm.Game.Scenario.Topography.Structure
import Swarm.Game.Scenario.Topography.Structure.Assembly (
  foldLayer,
 )
import Swarm.Game.Scenario.Topography.Structure.Named
import Swarm.Game.Scenario.Topography.Structure.Overlay
import Test.Tasty
import Test.Tasty.HUnit

debugRenderGrid :: Bool
debugRenderGrid = False

-- * Example grids

-- | Single cell
oneByOneGrid :: [[Int]]
oneByOneGrid = [[0]]

-- | Single row with two columns
oneByTwoGrid :: [[Int]]
oneByTwoGrid = [[5, 6]]

-- | Two rows with two columns
twoByTwoGrid :: [[Int]]
twoByTwoGrid =
  [ [1, 2]
  , [3, 4]
  ]

testOverlay :: TestTree
testOverlay =
  testGroup
    "Overlay"
    [ testGroup
        "Empty grids, base grid at origin"
        [ mkOriginTestCase "Northward" (Location 3 2) (Location 0 2)
        , mkOriginTestCase "Westward" (Location (-7) (-1)) (Location (-7) 0)
        ]
    , testGroup
        "Overlay sequences"
        [ testGroup
            "Horizontal siblings"
            [ mkOverlaySequenceOriginTest
                "negative first west of second"
                [ placeUnshifted "sibling1" (Location (-2) 0) twoByTwoGrid
                , placeUnshifted "sibling2" (Location 0 0) oneByTwoGrid
                ]
                (Location (-2) 0)
            , mkOverlaySequenceOriginTest
                "first east of negative second"
                [ placeUnshifted "sibling1" (Location 0 0) twoByTwoGrid
                , placeUnshifted "sibling2" (Location (-2) 0) oneByTwoGrid
                ]
                (Location (-2) 0)
            ]
        , testGroup
            "Vertical siblings"
            [ mkOverlaySequenceOriginTest
                "positive first south of second"
                [ placeUnshifted "sibling1" (Location 0 2) twoByTwoGrid
                , placeUnshifted "sibling2" (Location 0 0) oneByTwoGrid
                ]
                (Location 0 2)
            , mkOverlaySequenceOriginTest
                "first north of positive second"
                [ placeUnshifted "sibling1" (Location 0 0) twoByTwoGrid
                , placeUnshifted "sibling2" (Location 0 2) oneByTwoGrid
                ]
                (Location 0 2)
            ]
        , testGroup
            "Merge sizes"
            [ testMergedSize
                "merge an offset 1x1 atop a 0x0 base"
                (mkNamedStructure "baseLayer" (Location 0 0) [[]])
                (mkNamedStructure "sibling1" (Location (-1) 1) oneByOneGrid)
                (AreaDimensions 1 1)
            , testMergedSize
                "merge a 2x2 atop a 1x1 with an offset"
                (mkNamedStructure "sibling1" (Location (-1) 1) oneByOneGrid)
                (mkNamedStructure "sibling2" (Location 0 0) twoByTwoGrid)
                (AreaDimensions 3 3)
            ]
        , testGroup
            "Northwesterly offset of first sibling"
            [ mkOverlaySequenceOriginTest
                "positive first south of second"
                [ placeUnshifted "sibling1" (Location (-1) 1) oneByOneGrid
                , placeUnshifted "sibling2" (Location 0 0) twoByTwoGrid
                ]
                (Location (-1) 1)
            ]
        ]
    ]

-- * Test construction
testMergedSize ::
  String ->
  NamedStructure (Maybe Int) ->
  NamedStructure (Maybe Int) ->
  AreaDimensions ->
  TestTree
testMergedSize testLabel ns1 ns2 expectedArea =
  testCase testLabel $ do
    assertEqual "Merged area is wrong" expectedArea mergedSize
 where
  mergedSize =
    computeMergedArea $
      (OverlayPair `on` (area . structure)) ns1 ns2

-- | Base layer is at the origin (0, 0).
mkOriginTestCase ::
  String ->
  Location ->
  Location ->
  TestTree
mkOriginTestCase adjustmentDescription overlayLocation expectedBaseLoc =
  testCase (unwords [adjustmentDescription, "origin adjustment"]) $ do
    assertEqual "Base loc wrong" expectedBaseLoc actualBaseLoc
 where
  baseLayer = PositionedGrid (Location 0 0) (EmptyGrid :: Grid (Maybe ()))
  overlayLayer = PositionedGrid overlayLocation EmptyGrid
  PositionedGrid actualBaseLoc _ = baseLayer <> overlayLayer

mkOverlaySequenceOriginTest ::
  String ->
  [Placed (Maybe Int)] ->
  Location ->
  TestTree
mkOverlaySequenceOriginTest = mkOverlaySequenceTest gridPosition

mkOverlaySequenceTest ::
  (Show a, Eq a) =>
  (PositionedGrid (Maybe Int) -> a) ->
  String ->
  [Placed (Maybe Int)] ->
  a ->
  TestTree
mkOverlaySequenceTest f testLabel overlays expectedBaseLoc =
  testCase testLabel $ do
    when debugRenderGrid $
      renderGridResult eitherResultGrid

    assertEqual "Base loc wrong" (Right expectedBaseLoc) $
      f <$> eitherResultGrid
 where
  baseArea = PositionedGrid (Location 0 0) (EmptyGrid :: Grid (Maybe Int))

  eitherResultGrid = getGridFromMergedStructure <$> eitherResult
  eitherResult =
    foldLayer
      mempty
      baseArea
      overlays
      []

getGridFromMergedStructure :: MergedStructure c -> PositionedGrid c
getGridFromMergedStructure (MergedStructure g _ _) = g

-- | Place an structure at an offset.
-- The structure's local origin is (0, 0).
placeUnshifted ::
  Text ->
  Location ->
  [[a]] ->
  Placed (Maybe a)
placeUnshifted = place (Location 0 0)

-- | Place a structure at an offset.
-- That structure's local origin might not be (0, 0).
place ::
  Location ->
  Text ->
  Location ->
  [[a]] ->
  Placed (Maybe a)
place localOrigin theName placementOffset g =
  Placed (Placement sName (Pose placementOffset defaultOrientation)) $
    mkNamedStructure theName localOrigin g
 where
  sName = StructureName theName

mkNamedStructure ::
  Text ->
  Location ->
  [[a]] ->
  NamedArea (PStructure (Maybe a))
mkNamedStructure theName pos g =
  NamedArea sName mempty mempty s
 where
  sName = StructureName theName
  s =
    Structure
      (PositionedGrid pos $ Just <$> mkGrid g)
      mempty
      mempty
      mempty

renderGridResult :: Either a (PositionedGrid (Maybe Int)) -> IO ()
renderGridResult = mapM_ $ \pg -> do
  print pg
  print $ getRows $ gridContent pg