From b98116be4a9ef13c12b9e6457f35f78c765c5a2c Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 22 Sep 2024 00:17:49 -0700 Subject: [PATCH 1/3] 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 () From 3d3fe5265a72405d186f076a5477853ba57a4ddb Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 22 Sep 2024 15:59:06 -0700 Subject: [PATCH 2/3] wip experimental --- .../Game/Scenario/Topography/Structure/Assembly.hs | 14 ++++++++++++-- .../Game/Scenario/Topography/Structure/Overlay.hs | 2 +- 2 files changed, 13 insertions(+), 3 deletions(-) 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 0755c00a5..84e566e98 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs @@ -13,6 +13,7 @@ module Swarm.Game.Scenario.Topography.Structure.Assembly ( ) where +import Debug.Trace (trace) import Control.Arrow (left, (&&&)) import Control.Monad (when) import Data.Coerce @@ -122,14 +123,23 @@ overlayGridExpanded -- The 'childAdjustedOrigin' is the sum of origin adjustments -- to completely assemble some substructure. (PositionedGrid childAdjustedOrigin overlayArea) = - baseGrid <> positionedOverlay + trace (unwords [ + "Merging base grid at position" + , show $ gridPosition baseGrid + , "with overlay grid at position" + , show $ gridPosition positionedOverlay + ]) result where + result = baseGrid <> positionedOverlay + reorientedOverlayCells = applyOrientationTransform orientation overlayArea -- placementAdjustedByOrigin = (gridPosition baseGrid .+^ asVector yamlPlacementOffset) .-^ asVector childAdjustedOrigin + placementAdjustedByOrigin = yamlPlacementOffset + -- FIXME This experiment gives incorrect results -- (examine "simultaneous-north-and-west-offset.yaml"): - placementAdjustedByOrigin = yamlPlacementOffset .-^ asVector childAdjustedOrigin + -- placementAdjustedByOrigin = yamlPlacementOffset .-^ asVector childAdjustedOrigin positionedOverlay = PositionedGrid placementAdjustedByOrigin reorientedOverlayCells 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 a3d3aa281..2bc27bf62 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs @@ -84,7 +84,7 @@ zipGridRows :: zipGridRows dims (OverlayPair paddedBaseRows paddedOverlayRows) = mkGrid $ (pad2D paddedBaseRows . pad2D paddedOverlayRows) blankGrid where - -- Right-bias; that is, take the last non-empty value + -- Right-biased; that is, takes the last non-empty value pad2D = zipPadded $ zipPadded $ flip (<|>) blankGrid = getRows $ fillGrid dims empty From 94c85cd0fef9f5f1fb361d6aec7f6670d76f83ae Mon Sep 17 00:00:00 2001 From: "Restyled.io" Date: Sun, 22 Sep 2024 22:59:14 +0000 Subject: [PATCH 3/3] Restyled by fourmolu --- .../Scenario/Topography/Structure/Assembly.hs | 17 +++++++----- .../Scenario/Topography/Structure/Overlay.hs | 2 +- test/unit/Main.hs | 8 +++--- test/unit/TestOverlay.hs | 26 +++++++++---------- 4 files changed, 27 insertions(+), 26 deletions(-) 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 84e566e98..eee275202 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs @@ -13,7 +13,6 @@ module Swarm.Game.Scenario.Topography.Structure.Assembly ( ) where -import Debug.Trace (trace) import Control.Arrow (left, (&&&)) import Control.Monad (when) import Data.Coerce @@ -23,6 +22,7 @@ import Data.Map qualified as M import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T +import Debug.Trace (trace) import Linear.Affine import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Area @@ -123,12 +123,15 @@ overlayGridExpanded -- The 'childAdjustedOrigin' is the sum of origin adjustments -- to completely assemble some substructure. (PositionedGrid childAdjustedOrigin overlayArea) = - trace (unwords [ - "Merging base grid at position" - , show $ gridPosition baseGrid - , "with overlay grid at position" - , show $ gridPosition positionedOverlay - ]) result + trace + ( unwords + [ "Merging base grid at position" + , show $ gridPosition baseGrid + , "with overlay grid at position" + , show $ gridPosition positionedOverlay + ] + ) + result where result = baseGrid <> positionedOverlay 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 2bc27bf62..338d41ce8 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs @@ -12,11 +12,11 @@ module Swarm.Game.Scenario.Topography.Structure.Overlay ( OverlayPair (..), ) where -import Debug.Trace (trace) import Control.Applicative import Data.Function (on) import Data.Int (Int32) import Data.Tuple (swap) +import Debug.Trace (trace) import Linear hiding (trace) import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Area diff --git a/test/unit/Main.hs b/test/unit/Main.hs index 539a97b97..e03caccb6 100644 --- a/test/unit/Main.hs +++ b/test/unit/Main.hs @@ -47,10 +47,10 @@ main :: IO () main = do defaultMain statelessTests - -- ms <- runExceptT classicGame0 - -- case ms of - -- Left err -> assertFailure (from err) - -- Right s -> defaultMain (stateDependentTests 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 diff --git a/test/unit/TestOverlay.hs b/test/unit/TestOverlay.hs index 952a34e9d..1ab19012a 100644 --- a/test/unit/TestOverlay.hs +++ b/test/unit/TestOverlay.hs @@ -98,29 +98,27 @@ testOverlay = ] , testGroup "Northwesterly offset of first sibling" - [ - - -- testMergedSize + [ -- 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)) + -- , + + 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)) ] ] ]