diff --git a/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs b/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs index 768b4beb80..f2385149f8 100644 --- a/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs +++ b/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs @@ -26,7 +26,7 @@ import Linear (negated) import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Navigation.Waypoint import Swarm.Game.Universe -import Swarm.Util (allEqual, binTuples, both, quote) +import Swarm.Util (allEqual, binTuples, both, quote, sequenceTuple) type WaypointMap = M.Map WaypointName (NonEmpty Location) @@ -244,18 +244,11 @@ ensureSpatialConsistency xs = tuplify = both (view subworld) &&& both (view planar) - nest :: - Signed (b, a) -> - (b, Signed a) - nest = \case - Positive x -> fmap Positive x - Negative x -> fmap Negative x - reExtract = \case Positive x -> x Negative x -> negated x - groupedBySubworldPair = binTuples $ map (nest . fmap tuplify) normalizedOrdering + groupedBySubworldPair = binTuples $ map (sequenceTuple . fmap tuplify) normalizedOrdering vectorized = M.map (NE.map (reExtract . fmap (uncurry (.-.)))) groupedBySubworldPair nonUniform = M.filter ((not . allEqual) . NE.toList) vectorized diff --git a/src/Swarm/Util.hs b/src/Swarm/Util.hs index 114d122ccc..bf1d0fdd93 100644 --- a/src/Swarm/Util.hs +++ b/src/Swarm/Util.hs @@ -22,6 +22,7 @@ module Swarm.Util ( findDup, both, allEqual, + sequenceTuple, -- * Directory utilities readFileMay, @@ -193,6 +194,22 @@ both f = bimap f f allEqual :: (Ord a) => [a] -> Bool allEqual = (== 1) . S.size . S.fromList +-- | This function has a lamentable basis. +-- The 'sequenceA' function requires an 'Applicative' instance +-- for the inner functor. However, the 'Applictaive' instance +-- of @(,)@ (the two-element tuple) requires a 'Monoid' instance +-- for the first element! +-- See: https://hackage.haskell.org/package/base-4.18.0.0/docs/src/GHC.Base.html#line-523 +-- +-- The 'sequenceA' operation does not affect the first element +-- of the tuple, so it shouldn't matter whether it has a 'Monoid' instance! +-- To satisfy the compiler, we abuse a list to wrap and then unwrap after a traversal. +sequenceTuple :: + Traversable f => + f (a, b) -> + (a, f b) +sequenceTuple = first head . traverse (first pure) + ------------------------------------------------------------ -- Directory stuff