From b98116be4a9ef13c12b9e6457f35f78c765c5a2c Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 22 Sep 2024 00:17:49 -0700 Subject: [PATCH] WIP experiment --- .../Swarm/Game/Scenario/Topography/Area.hs | 1 + .../Scenario/Topography/Structure/Assembly.hs | 7 ++- .../Scenario/Topography/Structure/Overlay.hs | 16 ++++-- test/unit/Main.hs | 36 +++++++++---- test/unit/TestOverlay.hs | 52 ++++++++++++++----- 5 files changed, 84 insertions(+), 28 deletions(-) diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs index 6f6c632e9..d6cd81ee5 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs @@ -18,6 +18,7 @@ data AreaDimensions = AreaDimensions { rectWidth :: Int32 , rectHeight :: Int32 } + deriving (Show, Eq) getGridDimensions :: Grid a -> AreaDimensions getGridDimensions g = getAreaDimensions $ getRows g diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs index f8f5ae1d6..0755c00a5 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs @@ -125,7 +125,12 @@ overlayGridExpanded baseGrid <> positionedOverlay where reorientedOverlayCells = applyOrientationTransform orientation overlayArea - placementAdjustedByOrigin = (gridPosition baseGrid .+^ asVector yamlPlacementOffset) .-^ asVector childAdjustedOrigin + + -- placementAdjustedByOrigin = (gridPosition baseGrid .+^ asVector yamlPlacementOffset) .-^ asVector childAdjustedOrigin + -- FIXME This experiment gives incorrect results + -- (examine "simultaneous-north-and-west-offset.yaml"): + placementAdjustedByOrigin = yamlPlacementOffset .-^ asVector childAdjustedOrigin + positionedOverlay = PositionedGrid placementAdjustedByOrigin reorientedOverlayCells -- * Validation diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs index e866c1c43..a3d3aa281 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs @@ -6,13 +6,18 @@ -- Generic overlay operations on grids module Swarm.Game.Scenario.Topography.Structure.Overlay ( PositionedGrid (..), + + -- * Exported for unit tests + computeMergedArea, + OverlayPair (..), ) where +import Debug.Trace (trace) import Control.Applicative import Data.Function (on) import Data.Int (Int32) import Data.Tuple (swap) -import Linear +import Linear hiding (trace) import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Grid @@ -102,7 +107,8 @@ instance (Alternative f) => Semigroup (PositionedGrid (f a)) where a1@(PositionedGrid baseLoc baseGrid) <> a2@(PositionedGrid overlayLoc overlayGrid) = PositionedGrid newOrigin combinedGrid where - mergedSize = computeMergedArea $ OverlayPair a1 a2 + mergedSize2 = computeMergedArea $ OverlayPair a1 a2 + mergedSize = trace (unwords ["Merged size for ", show a1, "and", show a2, ":", show mergedSize2]) mergedSize2 combinedGrid = zipGridRows mergedSize paddedOverlayPair -- We create a vector from the overlay position, @@ -119,7 +125,7 @@ instance (Alternative f) => Semigroup (PositionedGrid (f a)) where newOrigin = baseLoc .-^ clampedDelta paddedOverlayPair = - padSouthwest originDelta $ + padNorthwest originDelta $ OverlayPair baseGrid overlayGrid -- | NOTE: We only make explicit grid adjustments for @@ -127,12 +133,12 @@ instance (Alternative f) => Semigroup (PositionedGrid (f a)) where -- of either grid will be taken care of by the 'zipPadded' function. -- -- TODO(#2004): The return type should be 'Grid'. -padSouthwest :: +padNorthwest :: Alternative f => V2 Int32 -> OverlayPair (Grid (f a)) -> OverlayPair [[f a]] -padSouthwest (V2 deltaX deltaY) (OverlayPair baseGrid overlayGrid) = +padNorthwest (V2 deltaX deltaY) (OverlayPair baseGrid overlayGrid) = OverlayPair paddedBaseGrid paddedOverlayGrid where prefixPadDimension delta f = f (padding <>) diff --git a/test/unit/Main.hs b/test/unit/Main.hs index d67f9d696..539a97b97 100644 --- a/test/unit/Main.hs +++ b/test/unit/Main.hs @@ -45,27 +45,43 @@ import Witch (from) main :: IO () main = do - ms <- runExceptT classicGame0 - case ms of - Left err -> assertFailure (from err) - Right s -> defaultMain (tests s) + defaultMain statelessTests -tests :: AppState -> TestTree -tests s = + -- ms <- runExceptT classicGame0 + -- case ms of + -- Left err -> assertFailure (from err) + -- Right s -> defaultMain (stateDependentTests s) + +-- | Initializing an 'AppState' entails +-- loading challenge scenarios, etc. from +-- disk. We might not want to do this, in +-- case we inject a 'trace' somewhere in +-- the code and want to minimize the noise. +-- +-- So we keep this list separate from the stateless +-- tests so we can easily comment it out. +stateDependentTests :: AppState -> TestTree +stateDependentTests s = testGroup - "Tests" + "Stateful tests" + [ testEval (s ^. gameState) + , testPedagogy (s ^. runtimeState) + , testNotification (s ^. gameState) + ] + +statelessTests :: TestTree +statelessTests = + testGroup + "Stateless tests" [ testLanguagePipeline , testParse , testPrettyConst , testBoolExpr , testCommands , testHighScores - , testEval (s ^. gameState) , testRepl , testRequirements - , testPedagogy (s ^. runtimeState) , testInventory - , testNotification (s ^. gameState) , testOrdering , testOverlay , testMisc diff --git a/test/unit/TestOverlay.hs b/test/unit/TestOverlay.hs index 1481c3f79..952a34e9d 100644 --- a/test/unit/TestOverlay.hs +++ b/test/unit/TestOverlay.hs @@ -9,6 +9,7 @@ module TestOverlay where import Control.Monad (when) import Data.Text (Text) import Swarm.Game.Location +import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Grid import Swarm.Game.Scenario.Topography.Placement import Swarm.Game.Scenario.Topography.Structure @@ -27,7 +28,6 @@ debugRenderGrid = True oneByOneGrid :: [[Int]] oneByOneGrid = [[0]] - -- | Single row with two columns oneByTwoGrid :: [[Int]] oneByTwoGrid = [[5, 6]] @@ -98,17 +98,47 @@ testOverlay = ] , 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)) + [ + + -- testMergedSize + -- "test merged size" + -- (placeUnshifted "baseLayer" (Location 0 0) [[]]) + -- (placeUnshifted "sibling1" (Location (-1) 1) oneByOneGrid) + -- (AreaDimensions 1 1) + + -- , testMergedSize + -- "test merged size" + -- (place (Location 1 (-1)) "sibling1" (Location (-1) 1) oneByOneGrid) + -- (placeUnshifted "sibling2" (Location 0 0) twoByTwoGrid) + -- (AreaDimensions 3 3) + -- , + + mkOverlaySequenceOriginTest + "positive first south of second" + [ placeUnshifted "sibling1" (Location (-1) 1) oneByOneGrid + , placeUnshifted "sibling2" (Location 0 0) twoByTwoGrid + -- [ placeUnshifted "sibling2" (Location 0 0) twoByTwoGrid + -- , placeUnshifted "sibling1" (Location (-1) 1) oneByOneGrid + ] + (Location 1 (-1)) ] ] ] -- * Test construction +testMergedSize :: + String -> + Placed (Maybe Int) -> + Placed (Maybe Int) -> + AreaDimensions -> + TestTree +testMergedSize testLabel (Placed _ ns1) (Placed _ ns2) expectedArea = + testCase testLabel $ do + assertEqual "Merged area is wrong" expectedArea mergedSize + where + a1 = area $ structure ns1 + a2 = area $ structure ns2 + mergedSize = computeMergedArea $ OverlayPair a1 a2 -- | Base layer is at the origin (0, 0). mkOriginTestCase :: @@ -140,7 +170,6 @@ mkOverlaySequenceTest :: TestTree mkOverlaySequenceTest f testLabel overlays expectedBaseLoc = testCase testLabel $ do - when debugRenderGrid $ renderGridResult eitherResultGrid @@ -158,7 +187,6 @@ mkOverlaySequenceTest f testLabel overlays expectedBaseLoc = overlays [] - getGridFromMergedStructure :: MergedStructure c -> PositionedGrid c getGridFromMergedStructure (MergedStructure g _ _) = g @@ -194,6 +222,6 @@ place localOrigin theName placementOffset g = renderGridResult :: Either a (PositionedGrid (Maybe Int)) -> IO () renderGridResult eitherResult = case eitherResult of Right pg -> do - print pg - print $ getRows $ gridContent pg - Left _ -> return () \ No newline at end of file + print pg + print $ getRows $ gridContent pg + Left _ -> return ()