Structure browser

.hlint.yaml

@@ -31,7 +31,7 @@
   - {name: Prelude.tail, within: []}
   - {name: Prelude.!!, within: [Swarm.Util.indexWrapNonEmpty, TestEval]}
   - {name: undefined, within: [Swarm.Language.Key, TestUtil]}
-  - {name: fromJust, within: []}
+  - {name: fromJust, within: [Text.AhoCorasick]}
 # - {name: Data.Map.!, within: []} # TODO: #1494
 # - {name: error, within: []} # TODO: #1494
 

data/scenarios/Testing/00-ORDER.txt

@@ -49,3 +49,4 @@ Achievements
 1430-built-robot-ownership.yaml
 1536-custom-unwalkable-entities.yaml
 1535-ping
+1575-structure-recognizer

data/scenarios/Testing/1575-structure-recognizer/00-ORDER.txt

@@ -0,0 +1 @@
+1575-browse-structures.yaml

data/scenarios/Testing/1575-structure-recognizer/1575-browse-structures.yaml

@@ -0,0 +1,119 @@
+version: 1
+name: Subworld shared structures
+description: |
+  Traverse floors of the tower
+creative: true
+robots:
+  - name: base
+    dir: [1, 0]
+    devices:
+      - ADT calculator
+      - branch predictor
+      - comparator
+      - compass
+      - dictionary
+      - GPS receiver
+      - grabber
+      - lambda
+      - lodestone
+      - logger
+      - strange loop
+      - treads
+    inventory:
+      - [50, flower]
+      - [50, log]
+      - [50, rock]
+      - [50, copper pipe]
+      - [50, iron gear]
+      - [50, quartz]
+      - [50, gold]
+      - [50, silver]
+      - [50, mithril]
+      - [50, cotton]
+solution: |
+   move;
+   place "quartz";
+   move;
+   place "quartz";
+   move;
+   place "mithril";
+structures:
+  - name: donut
+    structure:
+      palette:
+        '.': [stone]
+        '@': [dirt, rock]
+      map: |
+        .@@@.
+        @@@@@
+        @@.@@
+        @@@@@
+        .@@@.
+  - name: diamond
+    structure:
+      mask: '.'
+      palette:
+        'x': [stone, flower]
+      map: |
+        ...x...
+        ..xxx..
+        .xxxxx.
+        xxxxxxx
+        .xxxxx.
+        ..xxx..
+        ...x...
+  - name: contraption
+    structure:
+      mask: '.'
+      palette:
+        'r': [stone, log]
+        'I': [stone, rock]
+        'l': [stone, copper pipe]
+        'g': [stone, iron gear]
+      map: |
+       rllllr
+       lIIIIl
+       lIIIgg
+       rlllgg
+  - name: precious
+    structure:
+      mask: '.'
+      palette:
+        'q': [stone, quartz]
+        'g': [stone, gold]
+        's': [stone, silver]
+        'm': [stone, mithril]
+      map: |
+       qgs
+       gsq
+       qqm
+  - name: smallish
+    structure:
+      mask: '.'
+      palette:
+        'q': [stone, quartz]
+        'm': [stone, mithril]
+        'c': [stone, cotton]
+      map: |
+       qqm
+       cqq
+known: [flower, log, rock, copper pipe, iron plate]
+world:
+  name: root
+  dsl: |
+    {blank}
+  palette:
+    '.': [grass]
+    'q': [grass, quartz]
+    'g': [grass, gold]
+    's': [grass, silver]
+    'm': [grass, mithril]
+    'c': [grass, cotton]
+    'B': [grass, null, base]
+  upperleft: [0, 0]
+  map: |
+    .qgs.
+    .gsq.
+    B....
+    .cqq.
+    .....

src/Swarm/Game/Scenario.hs

@@ -35,6 +35,7 @@ module Swarm.Game.Scenario (
   scenarioKnown,
   scenarioWorlds,
   scenarioNavigation,
+  scenarioStructures,
   scenarioRobots,
   scenarioObjectives,
   scenarioSolution,
@@ -108,6 +109,7 @@ data Scenario = Scenario
   , _scenarioKnown :: [Text]
   , _scenarioWorlds :: NonEmpty WorldDescription
   , _scenarioNavigation :: Navigation (M.Map SubworldName) Location
+  , _scenarioStructures :: Structure.InheritedStructureDefs
   , _scenarioRobots :: [TRobot]
   , _scenarioObjectives :: [Objective]
   , _scenarioSolution :: Maybe ProcessedTerm
@@ -186,6 +188,7 @@ instance FromJSONE (EntityMap, WorldMap) Scenario where
         <*> pure known
         <*> pure allWorlds
         <*> pure mergedNavigation
+        <*> pure rootLevelSharedStructures
         <*> pure rs
         <*> (liftE (v .:? "objectives" .!= []) >>= validateObjectives)
         <*> liftE (v .:? "solution")
@@ -237,6 +240,10 @@ scenarioWorlds :: Lens' Scenario (NonEmpty WorldDescription)
 -- | Waypoints and inter-world portals
 scenarioNavigation :: Lens' Scenario (Navigation (M.Map SubworldName) Location)
 
+-- | Structure templates that may be auto-recognized when constructed
+-- by a robot
+scenarioStructures :: Lens' Scenario Structure.InheritedStructureDefs
+
 -- | The starting robots for the scenario.  Note this should
 --   include the base.
 scenarioRobots :: Lens' Scenario [TRobot]

src/Swarm/Game/Scenario/Topography/Structure.hs

@@ -35,9 +35,9 @@ data NamedStructure c = NamedStructure
   }
   deriving (Eq, Show)
 
-type InheritedStructureDefs = [NamedStructure (Maybe (PCell Entity))]
+type InheritedStructureDefs = [NamedStructure (Maybe Cell)]
 
-instance FromJSONE (EntityMap, RobotMap) (NamedStructure (Maybe (PCell Entity))) where
+instance FromJSONE (EntityMap, RobotMap) (NamedStructure (Maybe Cell)) where
   parseJSONE = withObjectE "named structure" $ \v -> do
     NamedStructure
       <$> liftE (v .: "name")
@@ -114,7 +114,7 @@ mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStruct
   g placement@(Placement sName _ _) =
     sequenceA (placement, M.lookup sName structureMap)
 
-instance FromJSONE (EntityMap, RobotMap) (PStructure (Maybe (PCell Entity))) where
+instance FromJSONE (EntityMap, RobotMap) (PStructure (Maybe Cell)) where
   parseJSONE = withObjectE "structure definition" $ \v -> do
     pal <- v ..:? "palette" ..!= WorldPalette mempty
     localStructureDefs <- v ..:? "structures" ..!= []

src/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs

@@ -0,0 +1,172 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- Structure recognizer: precomputation
+module Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute where
+
+import Control.Lens hiding (from, (<.>))
+import Data.Hashable (Hashable)
+import Data.Int (Int32)
+import Data.List.NonEmpty qualified as NE
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Maybe (catMaybes)
+import Data.Semigroup (sconcat)
+import Data.Tuple (swap)
+import GHC.Generics (Generic)
+import Swarm.Game.Entity (Entity)
+import Swarm.Game.Scenario.Topography.Cell
+import Swarm.Game.Scenario.Topography.Structure
+import Swarm.Util (binTuples, histogram)
+import Swarm.Util.Erasable (erasableToMaybe)
+import Text.AhoCorasick
+
+type AtomicKeySymbol = Maybe Entity
+
+data StructureRow = StructureRow
+  { wholeStructure :: StructureWithGrid
+  , rowIndex :: Int32
+  , rowContent :: [AtomicKeySymbol]
+  }
+
+data StructureWithGrid = StructureWithGrid
+  { originalDefinition :: NamedStructure (Maybe Cell)
+  , entityGrid :: [[AtomicKeySymbol]]
+  }
+
+data StructureInfo = StructureInfo
+  { withGrid :: StructureWithGrid
+  , entityCounts :: Map Entity Int
+  }
+
+-- | For all of the rows that contain a given entity
+-- (and are recognized by a single automaton),
+-- compute the left-most and right-most position
+-- within the row that the given entity may occur.
+--
+-- This determines how far to the left and to the right
+-- our search of the world cells needs to begin and
+-- end, respectively.
+--
+-- The 'Semigroup' instance always grows in extent, taking the minimum
+-- of the leftward offsets and the maximum of the rightward offsets.
+data InspectionOffsets = InspectionOffsets
+  { startOffset :: Int32
+  -- ^ Always non-positive (i.e. either zero or negative).
+  -- For the first-level search, this extends to the left.
+  -- For the second-level search, this extends upward.
+  , endOffset :: Int32
+  -- ^ Always non-negative.
+  -- For the first-level search, this extends to the right.
+  -- For the second-level search, this extends downward.
+  }
+  deriving (Show)
+
+instance Semigroup InspectionOffsets where
+  InspectionOffsets l1 r1 <> InspectionOffsets l2 r2 =
+    InspectionOffsets (min l1 l2) (max r1 r2)
+
+-- | Each automaton shall be initialized to recognize
+-- a certain subset of structure rows, that may either
+-- all be within one structure, or span multiple structures.
+data AutomatonInfo k = AutomatonInfo
+  { _inspectionOffsets :: InspectionOffsets
+  , _automaton :: StateMachine k StructureRow
+  }
+  deriving (Generic)
+
+makeLenses ''AutomatonInfo
+
+-- | The complete set of data needed to identify applicable
+-- structures, based on a just-placed entity.
+data RecognizerAutomatons = RecognizerAutomatons
+  { _definitions :: [StructureInfo]
+  , _automatonsByEntity :: Map Entity (AutomatonInfo AtomicKeySymbol)
+  , _automatonsByRow :: Map [AtomicKeySymbol] (AutomatonInfo [AtomicKeySymbol])
+  }
+  deriving (Generic)
+
+makeLenses ''RecognizerAutomatons
+
+getEntityGrid :: NamedStructure (Maybe Cell) -> [[AtomicKeySymbol]]
+getEntityGrid = map (map ((erasableToMaybe . cellEntity) =<<)) . area . structure
+
+allStructureRows :: [StructureWithGrid] -> [StructureRow]
+allStructureRows =
+  concatMap getRows
+ where
+  getRows :: StructureWithGrid -> [StructureRow]
+  getRows g = zipWith (StructureRow g) [0 ..] $ entityGrid g
+
+data RowPosition = RowPosition
+  { position :: Int32
+  , structureRow :: StructureRow
+  }
+
+mkOffsets :: Foldable f => Int32 -> f a -> InspectionOffsets
+mkOffsets pos xs =
+  InspectionOffsets (negate pos) $
+    fromIntegral (length xs) - 1 - pos
+
+mkGenericLookup ::
+  (Foldable t, Ord k, Hashable keySymb) =>
+  [StructureRow] ->
+  (a -> InspectionOffsets) ->
+  (a -> ([keySymb], StructureRow)) ->
+  ([StructureRow] -> t (k, a)) ->
+  Map k (AutomatonInfo keySymb)
+mkGenericLookup gs f mkSmTuple preprocessAllRows =
+  M.map mkValues structuresByRow
+ where
+  mkValues neList = AutomatonInfo bounds sm
+   where
+    bounds = sconcat $ NE.map f neList
+    sm = makeStateMachine $ NE.toList $ NE.map mkSmTuple neList
+
+  structuresByRow = binTuples $ preprocessAllRows gs
+
+mkRowLookup :: [StructureRow] -> Map [AtomicKeySymbol] (AutomatonInfo [AtomicKeySymbol])
+mkRowLookup gs =
+  mkGenericLookup gs deriveRowOffsets mkSmTuple preprocessAllRows
+ where
+  mkSmTuple x = (entityGrid $ wholeStructure x, x)
+  preprocessAllRows = map (\r@(StructureRow _ _ content) -> (content, r))
+
+  deriveRowOffsets :: StructureRow -> InspectionOffsets
+  deriveRowOffsets (StructureRow (StructureWithGrid _ g) rwIdx _) =
+    mkOffsets rwIdx g
+
+-- | Make the first-phase lookup map, keyed by 'Entity',
+-- along with automatons whose key symbols are "Maybe Entity".
+mkEntityLookup :: [StructureRow] -> Map Entity (AutomatonInfo AtomicKeySymbol)
+mkEntityLookup gs =
+  mkGenericLookup gs deriveEntityOffsets mkSmTuple preprocessAllRows
+ where
+  mkSmTuple = (\x -> (rowContent x, x)) . structureRow
+
+  deriveEntityOffsets :: RowPosition -> InspectionOffsets
+  deriveEntityOffsets (RowPosition pos r) =
+    mkOffsets pos $ rowContent r
+
+  preprocessAllRows = concatMap f
+   where
+    f :: StructureRow -> [(Entity, RowPosition)]
+    f r@(StructureRow _ _ content) =
+      map swap $
+        catMaybes $
+          zipWith (\idx -> fmap (RowPosition idx r,)) [0 :: Int32 ..] content
+
+mkAutomatons :: InheritedStructureDefs -> RecognizerAutomatons
+mkAutomatons xs =
+  RecognizerAutomatons
+    infos
+    (mkEntityLookup rowsAcrossAllStructures)
+    (mkRowLookup rowsAcrossAllStructures)
+ where
+  infos = map process grids
+  grids = map (\x -> StructureWithGrid x $ getEntityGrid x) xs
+  rowsAcrossAllStructures = allStructureRows grids
+
+  process g = StructureInfo g . histogram . concatMap catMaybes $ entityGrid g