wip chunk combinations

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs

@@ -69,8 +69,16 @@ data RowMismatchReason e
     EmptyIntersection
   deriving (Functor, Generic, ToJSON)
 
+data WrongRecurrenceCountExplanation = WrongRecurrenceCountExplanation
+  { foundCount :: Int
+  , foundMembers :: NonEmpty Int
+  , expectedCount :: Int
+  , expectedMembers :: NonEmpty Int
+  }
+  deriving (Generic, ToJSON)
+
 data ChunkMismatchReason
-  = WrongNumberOfRecurrences Int Int
+  = WrongNumberOfRecurrences WrongRecurrenceCountExplanation
   | Misalignment (NonEmpty Int)
   deriving (Generic, ToJSON)
 

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs

@@ -163,14 +163,101 @@ determineFoundChunksOffset ::
 determineFoundChunksOffset (FoundAndExpectedChunkPositions found expected) = do
   unless (length found == length expected) $
     Left $
-      WrongNumberOfRecurrences (length found) (length expected)
+      WrongNumberOfRecurrences $
+        WrongRecurrenceCountExplanation
+          (length found)
+          found
+          (length expected)
+          expected
   unless (allEqual $ NE.toList differences) $
     Left $
       Misalignment differences
   return $ NE.head differences
  where
   differences = NE.zipWith subtract expected found
 
+-- | This runs once per non-overlapping subset of found chunks
+checkChunksCombination ::
+  (Monad m, Hashable a, Eq b) =>
+  (Cosmic Location -> m (Maybe a)) ->
+  Cosmic Location ->
+  RecognitionState b a ->
+  InspectionOffsets ->
+  NE.NonEmpty (RowChunkMatchingReference b a) ->
+  [Position (NE.NonEmpty a)] ->
+  WriterT [SearchLog a] m (RecognitionState b a)
+checkChunksCombination
+  entLoader
+  cLoc
+  rState
+  horizontalOffsets
+  pwMaps
+  candidatesChunked = do
+    tell . pure . FoundPiecewiseChunks . map swap $ HM.toList foundRowChunksLookup
+
+    let (candidateFailures, candidateExpected) =
+          partitionEithers $
+            map subsetChecker $
+              NE.toList pwMaps
+
+    tell . pure . ChunkFailures $ candidateFailures
+
+    tell . pure . ChunksMatchingExpected $
+      map (modifyChunkedRowMatch $ fmap $ getName . originalDefinition . wholeStructure) candidateExpected
+
+    let structurePositionsToCheck = map mkFoundStructure candidateExpected
+    intactStructures <- filterM validateIntactness2d structurePositionsToCheck
+
+    registerStructureMatches intactStructures rState
+   where
+    foundRowChunksLookup = binTuplesHM $ map (pVal &&& pIndex) candidatesChunked
+
+    mkFoundStructure x =
+      FoundStructure
+        (wholeStructure $ chunkStructure $ foundChunkRow x)
+        (cLoc `offsetBy` structurePositionOffset (foundChunkRow x))
+
+    validateIntactness2d fs = do
+      intactnesss <- lift $ ensureStructureIntact entLoader fs
+      tell . pure . ChunkIntactnessVerification $
+        IntactPlacementLog
+          intactnesss
+          (getName . originalDefinition . structureWithGrid $ fs)
+          (upperLeftCorner fs)
+      return intactnesss
+
+    subsetChecker (RowChunkMatchingReference r chunkPositionMap) =
+      left (ChunkMatchFailureReason $ getName . originalDefinition . wholeStructure $ r) $ do
+        let isKeysSubset = referenceChunksKeys `HS.isSubsetOf` foundChunksKeys
+        unless isKeysSubset . Left $
+          NoKeysSubset $
+            (FoundChunkComparison `on` HS.toList) foundChunksKeys referenceChunksKeys
+
+        let theIntersection =
+              HM.intersectionWith
+                FoundAndExpectedChunkPositions
+                foundRowChunksLookup
+                chunkPositionMap
+
+        nonEmptyPairs <-
+          maybeToEither EmptyIntersection $
+            NE.nonEmpty $
+              HM.toList theIntersection
+
+        rowOffset <- left ChunkMismatchReason $ determineFoundRowOffset nonEmptyPairs
+
+        let horizontalStructurePosition = fromIntegral rowOffset + getMin (startOffset horizontalOffsets)
+
+        return $
+          ChunkedRowMatch
+            (map swap $ HM.toList theIntersection)
+            (FoundRowFromChunk rowOffset (rowIndex r) (V2 horizontalStructurePosition (rowIndex r)) r)
+     where
+      foundChunksKeys = HM.keysSet foundRowChunksLookup
+      referenceChunksKeys = HM.keysSet chunkPositionMap
+
+    modifyChunkedRowMatch f (ChunkedRowMatch x y) = ChunkedRowMatch x (f y)
+
 -- | This is the first (one-dimensional) stage
 -- in a two-stage (two-dimensional) search.
 --
@@ -200,69 +287,20 @@ registerRowMatches entLoader cLoc (AutomatonNewInfo horizontalOffsets _ pwMatche
   tell . pure . ExpectedChunks $ NE.map (HM.keys . confirmationMap) pwMaps
 
   let candidatesChunked = findAll pwSM entitiesRow
-      foundRowChunksLookup = binTuplesHM $ map (pVal &&& pIndex) candidatesChunked
 
-  tell . pure . FoundPiecewiseChunks . map swap $ HM.toList foundRowChunksLookup
+  -- TODO: Find all combinations of non-overlapping chunks,
+  -- then run 'checkChunksCombination' for each combination.
 
-  let (candidateFailures, candidateExpected) =
-        partitionEithers $
-          map (subsetChecker foundRowChunksLookup) $
-            NE.toList pwMaps
-
-  tell . pure . ChunkFailures $ candidateFailures
-
-  tell . pure . ChunksMatchingExpected $
-    map (modifyChunkedRowMatch $ fmap $ getName . originalDefinition . wholeStructure) candidateExpected
-
-  let structurePositionsToCheck = map mkFoundStructure candidateExpected
-  intactStructures <- filterM validateIntactness2d structurePositionsToCheck
-
-  registerStructureMatches intactStructures rState
+  checkChunksCombination
+    entLoader
+    cLoc
+    rState
+    horizontalOffsets
+    pwMaps
+    candidatesChunked
  where
   registry = rState ^. foundStructures
 
-  mkFoundStructure x =
-    FoundStructure
-      (wholeStructure $ chunkStructure $ foundChunkRow x)
-      (cLoc `offsetBy` structurePositionOffset (foundChunkRow x))
-
-  validateIntactness2d fs = do
-    intactnesss <- lift $ ensureStructureIntact entLoader fs
-    tell . pure . ChunkIntactnessVerification $
-      IntactPlacementLog
-        intactnesss
-        (getName . originalDefinition . structureWithGrid $ fs)
-        (upperLeftCorner fs)
-    return intactnesss
-
-  subsetChecker foundRowChunksLookup (RowChunkMatchingReference r chunkPositionMap) =
-    left (ChunkMatchFailureReason $ getName . originalDefinition . wholeStructure $ r) $ do
-      let isKeysSubset = referenceChunksKeys `HS.isSubsetOf` foundChunksKeys
-      unless isKeysSubset . Left $
-        NoKeysSubset $
-          (FoundChunkComparison `on` HS.toList) foundChunksKeys referenceChunksKeys
-
-      let theIntersection =
-            HM.intersectionWith
-              FoundAndExpectedChunkPositions
-              foundRowChunksLookup
-              chunkPositionMap
-
-      nonEmptyPairs <- maybeToEither EmptyIntersection $ NE.nonEmpty $ HM.toList theIntersection
-      rowOffset <- left ChunkMismatchReason $ determineFoundRowOffset nonEmptyPairs
-
-      let horizontalStructurePosition = fromIntegral rowOffset + getMin (startOffset horizontalOffsets)
-
-      return $
-        ChunkedRowMatch
-          (map swap $ HM.toList theIntersection)
-          (FoundRowFromChunk rowOffset (rowIndex r) (V2 horizontalStructurePosition (rowIndex r)) r)
-   where
-    foundChunksKeys = HM.keysSet foundRowChunksLookup
-    referenceChunksKeys = HM.keysSet chunkPositionMap
-
-  modifyChunkedRowMatch f (ChunkedRowMatch x y) = ChunkedRowMatch x (f y)
-
 -- |
 -- We only allow an entity to participate in one structure at a time,
 -- so multiple matches require a tie-breaker.