Skip to content

Commit

Permalink
support structure intrusion
Browse files Browse the repository at this point in the history
  • Loading branch information
kostmo committed Aug 14, 2024
1 parent d370cde commit 06046d5
Show file tree
Hide file tree
Showing 7 changed files with 134 additions and 68 deletions.
Original file line number Diff line number Diff line change
Expand Up @@ -9,10 +9,6 @@ description: |
Additionally, recognition of statically-placed
structures at scenario initialization is also
unaffected by interior entities.
However, any such "contaminating" entities
will prevent the recognition of a structure
when constructed by a robot.
creative: false
objectives:
- teaser: Replace rock
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -5,6 +5,7 @@
module Swarm.Game.Scenario.Topography.Structure.Recognition.Log where

import Data.Aeson
import Data.List.NonEmpty (NonEmpty)
import Data.Int (Int32)
import GHC.Generics (Generic)
import Servant.Docs (ToSample)
Expand All @@ -14,8 +15,10 @@ import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
import Swarm.Game.Universe (Cosmic)
import Swarm.Language.Syntax.Direction (AbsoluteDir)

type StructureRowContent e = [Maybe e]
type WorldRowContent e = [Maybe e]
-- | Type aliases for documentation
type StructureRowContent e = SymbolSequence e

type WorldRowContent e = SymbolSequence e

data OrientedStructure = OrientedStructure
{ oName :: OriginalName
Expand All @@ -27,7 +30,8 @@ distillLabel :: StructureWithGrid b a -> OrientedStructure
distillLabel swg = OrientedStructure (getName $ originalDefinition swg) (rotatedTo swg)

data MatchingRowFrom = MatchingRowFrom
{ rowIdx :: Int32
{ topDownRowIdx :: Int32
-- ^ numbered from the top down
, structure :: OrientedStructure
}
deriving (Generic, ToJSON)
Expand All @@ -45,14 +49,23 @@ data HaystackContext e = HaystackContext

data FoundRowCandidate e = FoundRowCandidate
{ haystackContext :: HaystackContext e
, structureContent :: StructureRowContent e
, rowCandidates :: [MatchingRowFrom]
, soughtContent :: StructureRowContent e
, matchedCandidates :: [MatchingRowFrom]
}
deriving (Functor, Generic, ToJSON)

data EntityKeyedFinder e = EntityKeyedFinder {
searchOffsets :: InspectionOffsets
, candidateStructureRows :: [StructureRowContent e]
, entityMask :: [e]
-- ^ NOTE: HashSet has no Functor instance,
-- so we represent this as a list here.
}
deriving (Functor, Generic, ToJSON)

data ParticipatingEntity e = ParticipatingEntity
{ entity :: e
, searchOffsets :: InspectionOffsets
, entityKeyedFinders :: NonEmpty (EntityKeyedFinder e)
}
deriving (Functor, Generic, ToJSON)

Expand All @@ -63,14 +76,22 @@ data IntactPlacementLog = IntactPlacementLog
}
deriving (Generic, ToJSON)

data VerticalSearch e = VerticalSearch
{ haystackVerticalExtents :: InspectionOffsets
-- ^ vertical offset of haystack relative to the found row
, soughtStructures :: [OrientedStructure]
, verticalHaystack :: [WorldRowContent e]
}
deriving (Functor, Generic, ToJSON)

data SearchLog e
= FoundParticipatingEntity (ParticipatingEntity e)
| StructureRemoved OriginalName
| FoundRowCandidates [FoundRowCandidate e]
| FoundCompleteStructureCandidates [OrientedStructure]
| -- | There may be multiple candidate structures that could be
-- completed by the element that was just placed. This lists all of them.
VerticalSearchSpans [(InspectionOffsets, [OrientedStructure])]
VerticalSearchSpans [VerticalSearch e]
| IntactStaticPlacement [IntactPlacementLog]
deriving (Functor, Generic)

Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -7,6 +7,7 @@ import Data.HashMap.Strict qualified as HM
import Data.HashSet qualified as HS
import Data.Hashable (Hashable)
import Data.Int (Int32)
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NE
import Data.Maybe (catMaybes)
import Data.Semigroup (sconcat)
Expand All @@ -32,10 +33,10 @@ mkOffsets pos xs =
-- rows constitute a complete structure.
mkRowLookup ::
(Hashable a, Eq a) =>
NE.NonEmpty (StructureRow b a) ->
NonEmpty (StructureRow b a) ->
AutomatonInfo a (SymbolSequence a) (StructureWithGrid b a)
mkRowLookup neList =
AutomatonInfo participatingEnts bounds sm
AutomatonInfo participatingEnts bounds sm tuples
where
mkSmTuple = entityGrid &&& id
tuples = NE.toList $ NE.map (mkSmTuple . wholeStructure) neList
Expand All @@ -61,7 +62,7 @@ mkRowLookup neList =
mkEntityLookup ::
(Hashable a, Eq a) =>
[StructureWithGrid b a] ->
HM.HashMap a (AutomatonInfo a (AtomicKeySymbol a) (StructureSearcher b a))
HM.HashMap a (NonEmpty (AutomatonInfo a (AtomicKeySymbol a) (StructureSearcher b a)))
mkEntityLookup grids =
HM.map mkValues rowsByEntityParticipation
where
Expand All @@ -75,15 +76,27 @@ mkEntityLookup grids =
structureRowsNE = NE.map myRow singleRows
sm2D = mkRowLookup structureRowsNE

mkValues neList = AutomatonInfo participatingEnts bounds sm
mkValues neList = NE.fromList $
map (\(mask, tups) -> AutomatonInfo mask bounds sm $ NE.toList tups) tuplesByEntMask
where
participatingEnts =
HS.fromList
(concatMap (catMaybes . fst) tuples)

-- If there are no transparent cells,
-- we don't need a mask.
getMaskSet row =
if Nothing `elem` row
then HS.fromList $ catMaybes row
else mempty

tuplesByEntMask = HM.toList $ binTuplesHM $ map (getMaskSet . fst &&& id) tuples


tuples = HM.toList $ HM.mapWithKey mkSmValue groupedByUniqueRow

groupedByUniqueRow = binTuplesHM $ NE.toList $ NE.map (rowContent . myRow &&& id) neList
groupedByUniqueRow =
binTuplesHM $
NE.toList $
NE.map (rowContent . myRow &&& id) neList

bounds = sconcat $ NE.map expandedOffsets neList
sm = makeStateMachine tuples

Expand Down Expand Up @@ -111,6 +124,7 @@ mkEntityLookup grids =
SingleRowEntityOccurrences r e occurrences $
sconcat $
NE.map deriveEntityOffsets occurrences

unconsolidated =
map swap $
catMaybes $
Expand All @@ -123,7 +137,7 @@ mkEntityLookup grids =
binTuplesHM ::
(Foldable t, Hashable a, Eq a) =>
t (a, b) ->
HM.HashMap a (NE.NonEmpty b)
HM.HashMap a (NonEmpty b)
binTuplesHM = foldr f mempty
where
f = uncurry (HM.insertWith (<>)) . fmap pure
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,7 @@ module Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking (
entityModified,
) where

import Data.Foldable (foldrM)
import Control.Lens ((%~), (&), (.~), (^.))
import Control.Monad (forM, guard)
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
Expand All @@ -18,7 +19,7 @@ import Data.HashSet qualified as HS
import Data.Hashable (Hashable)
import Data.Int (Int32)
import Data.List (sortOn)
import Data.List.NonEmpty qualified as NE
import Data.List.NonEmpty.Extra qualified as NE
import Data.Map qualified as M
import Data.Maybe (listToMaybe)
import Data.Ord (Down (..))
Expand Down Expand Up @@ -66,11 +67,16 @@ entityModified entLoader modification cLoc recognizer =
let oldRecognitionState = r ^. recognitionState
stateRevision <- case HM.lookup newEntity entLookup of
Nothing -> return oldRecognitionState
Just finder -> do
let msg = FoundParticipatingEntity $ ParticipatingEntity newEntity (finder ^. inspectionOffsets)
Just finders -> do
let logFinder f = EntityKeyedFinder
(f ^. inspectionOffsets)
(map fst $ f ^. searchPairs)
(HS.toList $ f ^. participatingEntities)
msg = FoundParticipatingEntity $
ParticipatingEntity newEntity $ NE.map logFinder finders
stateRevision' = oldRecognitionState & recognitionLog %~ (msg :)

registerRowMatches entLoader cLoc finder stateRevision'
foldrM (registerRowMatches entLoader cLoc) stateRevision' finders

return $ r & recognitionState .~ stateRevision

Expand Down Expand Up @@ -107,14 +113,15 @@ candidateEntityAt ::
(Monad s, Hashable a) =>
GenericEntLocator s a ->
FoundRegistry b a ->
-- | participating entities
-- | participating entities whitelist. If empty, all entities are included.
-- NOTE: This is only needed for structures that have transparent cells.
HashSet a ->
Cosmic Location ->
s (Maybe a)
candidateEntityAt entLoader registry participating cLoc = runMaybeT $ do
guard $ M.notMember cLoc $ foundByLocation registry
ent <- MaybeT $ entLoader cLoc
guard $ HS.member ent participating
guard $ null participating || HS.member ent participating
return ent

-- | Excludes entities that are already part of a
Expand All @@ -123,13 +130,13 @@ getWorldRow ::
(Monad s, Hashable a) =>
GenericEntLocator s a ->
FoundRegistry b a ->
-- | participating entities
HashSet a ->
Cosmic Location ->
InspectionOffsets ->
-- | participating entities
HashSet a ->
Int32 ->
s [Maybe a]
getWorldRow entLoader registry participatingEnts cLoc (InspectionOffsets (Min offsetLeft) (Max offsetRight)) yOffset = do
getWorldRow entLoader registry cLoc (InspectionOffsets (Min offsetLeft) (Max offsetRight)) participatingEnts yOffset = do
mapM getCandidate horizontalOffsets
where
getCandidate = candidateEntityAt entLoader registry participatingEnts
Expand All @@ -139,43 +146,40 @@ getWorldRow entLoader registry participatingEnts cLoc (InspectionOffsets (Min of
-- to bottom, but swarm world coordinates increase from bottom to top.
mkLoc x = cLoc `offsetBy` V2 x (negate yOffset)

logRowCandidates :: [Maybe e] -> [Position (StructureSearcher b e)] -> SearchLog e
logRowCandidates entitiesRow candidates =
FoundRowCandidates $ map mkCandidateLogEntry candidates
where
mkCandidateLogEntry c =
FoundRowCandidate
(HaystackContext entitiesRow (HaystackPosition $ pIndex c))
(needleContent $ pVal c)
rowMatchInfo
where
rowMatchInfo :: [MatchingRowFrom]
rowMatchInfo = NE.toList . NE.map (f . myRow) . singleRowItems $ pVal c
where
f x =
MatchingRowFrom (rowIndex x) $ distillLabel . wholeStructure $ x

-- | This is the first (one-dimensional) stage
-- in a two-stage (two-dimensional) search.
--
-- It searches for any structure row that happens to
-- contain the placed entity.
registerRowMatches ::
(Monad s, Hashable a, Eq b) =>
GenericEntLocator s a ->
Cosmic Location ->
AutomatonInfo a (AtomicKeySymbol a) (StructureSearcher b a) ->
RecognitionState b a ->
s (RecognitionState b a)
registerRowMatches entLoader cLoc (AutomatonInfo participatingEnts horizontalOffsets sm) rState = do
let registry = rState ^. foundStructures

entitiesRow <-
getWorldRow
entLoader
registry
participatingEnts
cLoc
horizontalOffsets
0

let candidates = findAll sm entitiesRow

mkCandidateLogEntry c =
FoundRowCandidate
(HaystackContext entitiesRow (HaystackPosition $ pIndex c))
(needleContent $ pVal c)
rowMatchInfo
where
rowMatchInfo :: [MatchingRowFrom]
rowMatchInfo = NE.toList . NE.map (f . myRow) . singleRowItems $ pVal c
where
f x =
MatchingRowFrom (rowIndex x) $ distillLabel . wholeStructure $ x
registerRowMatches entLoader cLoc (AutomatonInfo participatingEnts horizontalOffsets sm _) rState = do
maskChoices <- attemptSearchWithEntityMask participatingEnts

logEntry = FoundRowCandidates $ map mkCandidateLogEntry candidates
let logEntry = uncurry logRowCandidates maskChoices
rState2 = rState & recognitionLog %~ (logEntry :)
candidates = snd maskChoices

candidates2Dpairs <-
forM candidates $
Expand All @@ -186,6 +190,22 @@ registerRowMatches entLoader cLoc (AutomatonInfo participatingEnts horizontalOff

return $
registerStructureMatches (concat candidates2D) rState3
where
registry = rState ^. foundStructures

attemptSearchWithEntityMask entsMask = do
entitiesRow <-
getWorldRow
entLoader
registry
cLoc
horizontalOffsets
entsMask
0

-- All of the eligible structure rows found
-- within this horizontal swath of world cells
return (entitiesRow, findAll sm entitiesRow)

-- | Examines contiguous rows of entities, accounting
-- for the offset of the initially found row.
Expand All @@ -197,10 +217,10 @@ checkVerticalMatch ::
-- | Horizontal search offsets
InspectionOffsets ->
Position (StructureSearcher b a) ->
s ((InspectionOffsets, [OrientedStructure]), [FoundStructure b a])
s (VerticalSearch a, [FoundStructure b a])
checkVerticalMatch entLoader registry cLoc (InspectionOffsets (Min searchOffsetLeft) _) foundRow = do
(x, y) <- getMatches2D entLoader registry cLoc horizontalFoundOffsets $ automaton2D searcherVal
return ((x, rowStructureNames), y)
((x, y), z) <- getMatches2D entLoader registry cLoc horizontalFoundOffsets $ automaton2D searcherVal
return (VerticalSearch x rowStructureNames y, z)
where
searcherVal = pVal foundRow
rowStructureNames = NE.toList . NE.map (distillLabel . wholeStructure . myRow) . singleRowItems $ searcherVal
Expand Down Expand Up @@ -234,18 +254,18 @@ getMatches2D ::
-- | Horizontal found offsets (inclusive indices)
InspectionOffsets ->
AutomatonInfo a (SymbolSequence a) (StructureWithGrid b a) ->
s (InspectionOffsets, [FoundStructure b a])
s ((InspectionOffsets, [[Maybe a]]), [FoundStructure b a])
getMatches2D
entLoader
registry
cLoc
horizontalFoundOffsets@(InspectionOffsets (Min offsetLeft) _)
(AutomatonInfo participatingEnts vRange@(InspectionOffsets (Min offsetTop) (Max offsetBottom)) sm) = do
entityRows <- mapM getRow verticalOffsets
return (vRange, getFoundStructures (offsetTop, offsetLeft) cLoc sm entityRows)
(AutomatonInfo participatingEnts vRange@(InspectionOffsets (Min offsetTop) (Max offsetBottom)) sm _) = do
entityRows <- mapM getRow vertOffsets
return ((vRange, entityRows), getFoundStructures (offsetTop, offsetLeft) cLoc sm entityRows)
where
getRow = getWorldRow entLoader registry participatingEnts cLoc horizontalFoundOffsets
verticalOffsets = [offsetTop .. offsetBottom]
getRow = getWorldRow entLoader registry cLoc horizontalFoundOffsets participatingEnts
vertOffsets = [offsetTop .. offsetBottom]

-- |
-- We only allow an entity to participate in one structure at a time,
Expand Down
Loading

0 comments on commit 06046d5

Please sign in to comment.