diff --git a/docs/image/sublibrary-graph.svg b/docs/image/sublibrary-graph.svg index d68ef25c..c30772ab 100644 --- a/docs/image/sublibrary-graph.svg +++ b/docs/image/sublibrary-graph.svg @@ -4,106 +4,124 @@ - + plan - + swarm - -swarm + +swarm swarm-web - -swarm-web + +swarm-web swarm->swarm-web - - + + swarm-doc - -swarm-doc + +swarm-doc swarm-web->swarm-doc - - + + swarm-tui - -swarm-tui + +swarm-tui swarm-web->swarm-tui - - + + swarm-engine - -swarm-engine + +swarm-engine swarm-doc->swarm-engine - - + + swarm-tui->swarm-engine - - + + swarm-scenario - -swarm-scenario + +swarm-scenario swarm-engine->swarm-scenario - - + + + + + +swarm-topography + +swarm-topography + + + +swarm-scenario->swarm-topography + + - + swarm-lang - -swarm-lang + +swarm-lang - + swarm-scenario->swarm-lang - - + + - + swarm-util - -swarm-util + +swarm-util + + + +swarm-topography->swarm-util + + - + swarm-lang->swarm-util - - + + diff --git a/scripts/test/run-benchmarks.sh b/scripts/test/run-benchmarks.sh index 1a5daba4..9a3b715b 100755 --- a/scripts/test/run-benchmarks.sh +++ b/scripts/test/run-benchmarks.sh @@ -1,7 +1,5 @@ #!/bin/bash -xe +cd $(git rev-parse --show-toplevel) -SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) -cd $SCRIPT_DIR/.. - -STACK_WORK=.stack-work-bench stack bench swarm:benchmark --benchmark-arguments "--color always $@" +cabal bench --benchmark-options "--color always $@" diff --git a/src/swarm-doc/Swarm/Doc/Keyword.hs b/src/swarm-doc/Swarm/Doc/Keyword.hs index a9fc3d08..b0ae1857 100644 --- a/src/swarm-doc/Swarm/Doc/Keyword.hs +++ b/src/swarm-doc/Swarm/Doc/Keyword.hs @@ -19,7 +19,7 @@ module Swarm.Doc.Keyword ( import Data.Text (Text) import Data.Text qualified as T import Swarm.Doc.Util -import Swarm.Language.Syntax qualified as Syntax +import Swarm.Language.Syntax.Direction import Swarm.Util (quote) -- | An enumeration of the editors supported by Swarm (currently, @@ -42,7 +42,7 @@ keywordsCommands e = editorList e $ map constSyntax commands -- | Get formatted list of directions. keywordsDirections :: EditorType -> Text -keywordsDirections e = editorList e $ map Syntax.directionSyntax Syntax.allDirs +keywordsDirections e = editorList e $ map directionSyntax allDirs -- | A list of the names of all the operators in the language. operatorNames :: Text diff --git a/src/swarm-engine/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs b/src/swarm-engine/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs index e1cbeaf0..948b3702 100644 --- a/src/swarm-engine/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs +++ b/src/swarm-engine/Swarm/Game/Scenario/Topography/Structure/Recognition/Tracking.hs @@ -26,11 +26,12 @@ import Data.Set qualified as S import Linear (V2 (..)) import Swarm.Game.Entity import Swarm.Game.Location -import Swarm.Game.Scenario.Topography.Structure qualified as Structure +import Swarm.Game.Scenario (Cell) import Swarm.Game.Scenario.Topography.Structure.Recognition import Swarm.Game.Scenario.Topography.Structure.Recognition.Log import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.Scenario.Topography.Structure.Type qualified as Structure import Swarm.Game.State import Swarm.Game.State.Substate import Swarm.Game.Universe @@ -124,7 +125,7 @@ getWorldRow participatingEnts cLoc (InspectionOffsets (Min offsetLeft) (Max offs registerRowMatches :: (Has (State GameState) sig m) => Cosmic Location -> - AutomatonInfo AtomicKeySymbol StructureSearcher -> + AutomatonInfo EntityName (AtomicKeySymbol Entity) (StructureSearcher Cell EntityName Entity) -> m () registerRowMatches cLoc (AutomatonInfo participatingEnts horizontalOffsets sm) = do entitiesRow <- getWorldRow participatingEnts cLoc horizontalOffsets 0 @@ -150,8 +151,8 @@ checkVerticalMatch :: Cosmic Location -> -- | Horizontal search offsets InspectionOffsets -> - Position StructureSearcher -> - m [FoundStructure] + Position (StructureSearcher Cell EntityName Entity) -> + m [FoundStructure Cell Entity] checkVerticalMatch cLoc (InspectionOffsets (Min searchOffsetLeft) _) foundRow = getMatches2D cLoc horizontalFoundOffsets $ automaton2D $ pVal foundRow where @@ -163,9 +164,9 @@ getFoundStructures :: Hashable keySymb => (Int32, Int32) -> Cosmic Location -> - StateMachine keySymb StructureWithGrid -> + StateMachine keySymb (StructureWithGrid Cell Entity) -> [keySymb] -> - [FoundStructure] + [FoundStructure Cell Entity] getFoundStructures (offsetTop, offsetLeft) cLoc sm entityRows = map mkFound candidates where @@ -181,8 +182,8 @@ getMatches2D :: Cosmic Location -> -- | Horizontal found offsets (inclusive indices) InspectionOffsets -> - AutomatonInfo SymbolSequence StructureWithGrid -> - m [FoundStructure] + AutomatonInfo EntityName (SymbolSequence Entity) (StructureWithGrid Cell Entity) -> + m [FoundStructure Cell Entity] getMatches2D cLoc horizontalFoundOffsets@(InspectionOffsets (Min offsetLeft) _) @@ -199,7 +200,7 @@ getMatches2D -- The largest structure (by area) shall win. registerStructureMatches :: (Has (State GameState) sig m) => - [FoundStructure] -> + [FoundStructure Cell Entity] -> m () registerStructureMatches unrankedCandidates = do discovery . structureRecognition . recognitionLog %= (newMsg :) diff --git a/src/swarm-engine/Swarm/Game/State.hs b/src/swarm-engine/Swarm/Game/State.hs index 2f58c692..5c1f1ce2 100644 --- a/src/swarm-engine/Swarm/Game/State.hs +++ b/src/swarm-engine/Swarm/Game/State.hs @@ -117,11 +117,11 @@ import Swarm.Game.Robot.Concrete import Swarm.Game.Scenario import Swarm.Game.Scenario.Objective import Swarm.Game.Scenario.Status -import Swarm.Game.Scenario.Topography.Structure qualified as Structure import Swarm.Game.Scenario.Topography.Structure.Recognition import Swarm.Game.Scenario.Topography.Structure.Recognition.Log import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.Scenario.Topography.Structure.Type qualified as Structure import Swarm.Game.State.Landscape import Swarm.Game.State.Robot import Swarm.Game.State.Substate @@ -525,7 +525,7 @@ zoomWorld swName n = do -- cell is encountered. ensureStructureIntact :: (Has (State GameState) sig m) => - FoundStructure -> + FoundStructure Cell Entity -> m Bool ensureStructureIntact (FoundStructure (StructureWithGrid _ _ grid) upperLeft) = allM outer $ zip [0 ..] grid @@ -541,7 +541,7 @@ ensureStructureIntact (FoundStructure (StructureWithGrid _ _ grid) upperLeft) = mkRecognizer :: (Has (State GameState) sig m) => StaticStructureInfo -> - m StructureRecognizer + m (StructureRecognizer Cell EntityName Entity) mkRecognizer structInfo@(StaticStructureInfo structDefs _) = do foundIntact <- mapM (sequenceA . (id &&& ensureStructureIntact)) allPlaced let fs = populateStaticFoundStructures . map fst . filter snd $ foundIntact diff --git a/src/swarm-engine/Swarm/Game/State/Substate.hs b/src/swarm-engine/Swarm/Game/State/Substate.hs index ae91d47c..29430188 100644 --- a/src/swarm-engine/Swarm/Game/State/Substate.hs +++ b/src/swarm-engine/Swarm/Game/State/Substate.hs @@ -100,7 +100,7 @@ import Swarm.Game.Recipe ( outRecipeMap, ) import Swarm.Game.Robot -import Swarm.Game.Scenario (GameStateInputs (..)) +import Swarm.Game.Scenario (Cell, GameStateInputs (..)) import Swarm.Game.Scenario.Objective import Swarm.Game.Scenario.Topography.Structure.Recognition import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (emptyFoundStructures) @@ -327,7 +327,7 @@ data Discovery = Discovery , _availableCommands :: Notifications Const , _knownEntities :: S.Set EntityName , _gameAchievements :: Map GameplayAchievement Attainment - , _structureRecognition :: StructureRecognizer + , _structureRecognition :: StructureRecognizer Cell EntityName Entity , _tagMembers :: Map Text (NonEmpty EntityName) } @@ -350,7 +350,7 @@ knownEntities :: Lens' Discovery (S.Set EntityName) gameAchievements :: Lens' Discovery (Map GameplayAchievement Attainment) -- | Recognizer for robot-constructed structures -structureRecognition :: Lens' Discovery StructureRecognizer +structureRecognition :: Lens' Discovery (StructureRecognizer Cell EntityName Entity) -- | Map from tags to entities that possess that tag tagMembers :: Lens' Discovery (Map Text (NonEmpty EntityName)) diff --git a/src/swarm-engine/Swarm/Game/Step/Combustion.hs b/src/swarm-engine/Swarm/Game/Step/Combustion.hs index 313e1744..b601aa90 100644 --- a/src/swarm-engine/Swarm/Game/Step/Combustion.hs +++ b/src/swarm-engine/Swarm/Game/Step/Combustion.hs @@ -44,6 +44,7 @@ import Swarm.Language.Context (empty) import Swarm.Language.Pipeline (ProcessedTerm) import Swarm.Language.Pipeline.QQ (tmQ) import Swarm.Language.Syntax +import Swarm.Language.Syntax.Direction (Direction) import Swarm.Language.Text.Markdown qualified as Markdown import Swarm.Util hiding (both) import System.Clock (TimeSpec) diff --git a/src/swarm-engine/Swarm/Game/Step/Const.hs b/src/swarm-engine/Swarm/Game/Step/Const.hs index 75bb4d66..971c4c57 100644 --- a/src/swarm-engine/Swarm/Game/Step/Const.hs +++ b/src/swarm-engine/Swarm/Game/Step/Const.hs @@ -94,6 +94,7 @@ import Swarm.Language.Pipeline import Swarm.Language.Pretty (prettyText) import Swarm.Language.Requirement qualified as R import Swarm.Language.Syntax +import Swarm.Language.Syntax.Direction import Swarm.Language.Text.Markdown qualified as Markdown import Swarm.Language.Value import Swarm.Log diff --git a/src/swarm-engine/Swarm/Game/Step/Path/Finding.hs b/src/swarm-engine/Swarm/Game/Step/Path/Finding.hs index 3f4e35ff..623c5925 100644 --- a/src/swarm-engine/Swarm/Game/Step/Path/Finding.hs +++ b/src/swarm-engine/Swarm/Game/Step/Path/Finding.hs @@ -48,6 +48,7 @@ import Swarm.Game.Step.Util import Swarm.Game.Step.Util.Inspect import Swarm.Game.Universe import Swarm.Language.Syntax +import Swarm.Language.Syntax.Direction import Swarm.Util (hoistMaybe) -- | Swarm command arguments are converted to idiomatic Haskell diff --git a/src/swarm-engine/Swarm/Game/Step/Util.hs b/src/swarm-engine/Swarm/Game/Step/Util.hs index fb9bb039..73bb447e 100644 --- a/src/swarm-engine/Swarm/Game/Step/Util.hs +++ b/src/swarm-engine/Swarm/Game/Step/Util.hs @@ -42,6 +42,7 @@ import Swarm.Game.World.Modify qualified as WM import Swarm.Language.Capability import Swarm.Language.Requirement qualified as R import Swarm.Language.Syntax +import Swarm.Language.Syntax.Direction (Direction) import Swarm.Util hiding (both) import System.Random (UniformRange, uniformR) import Prelude hiding (Applicative (..), lookup) diff --git a/src/swarm-lang/Swarm/Language/Parser/Lex.hs b/src/swarm-lang/Swarm/Language/Parser/Lex.hs index 19837760..ffec58f0 100644 --- a/src/swarm-lang/Swarm/Language/Parser/Lex.hs +++ b/src/swarm-lang/Swarm/Language/Parser/Lex.hs @@ -56,6 +56,7 @@ import Data.Text (Text) import Data.Text qualified as T import Swarm.Language.Parser.Core import Swarm.Language.Syntax +import Swarm.Language.Syntax.Direction import Swarm.Language.Types (baseTyName) import Swarm.Util (failT, listEnums, squote) import Text.Megaparsec diff --git a/src/swarm-lang/Swarm/Language/Parser/Term.hs b/src/swarm-lang/Swarm/Language/Parser/Term.hs index 92048aac..ee405dea 100644 --- a/src/swarm-lang/Swarm/Language/Parser/Term.hs +++ b/src/swarm-lang/Swarm/Language/Parser/Term.hs @@ -21,6 +21,7 @@ import Swarm.Language.Parser.Lex import Swarm.Language.Parser.Record (parseRecord) import Swarm.Language.Parser.Type import Swarm.Language.Syntax +import Swarm.Language.Syntax.Direction import Swarm.Language.Types import Swarm.Util (failT, findDup) import Text.Megaparsec hiding (runParser) diff --git a/src/swarm-lang/Swarm/Language/Pretty.hs b/src/swarm-lang/Swarm/Language/Pretty.hs index 1e8a8ffa..8d11deac 100644 --- a/src/swarm-lang/Swarm/Language/Pretty.hs +++ b/src/swarm-lang/Swarm/Language/Pretty.hs @@ -32,6 +32,7 @@ import Swarm.Language.Context import Swarm.Language.Kindcheck (KindError (..)) import Swarm.Language.Parser.Util (getLocRange) import Swarm.Language.Syntax +import Swarm.Language.Syntax.Direction import Swarm.Language.Typecheck import Swarm.Language.Types import Swarm.Util (number, showEnum, showLowT, unsnocNE) diff --git a/src/swarm-lang/Swarm/Language/Requirement.hs b/src/swarm-lang/Swarm/Language/Requirement.hs index aa0c5b3d..9dc7973d 100644 --- a/src/swarm-lang/Swarm/Language/Requirement.hs +++ b/src/swarm-lang/Swarm/Language/Requirement.hs @@ -37,6 +37,7 @@ import Swarm.Language.Capability (Capability (..), constCaps) import Swarm.Language.Context (Ctx) import Swarm.Language.Context qualified as Ctx import Swarm.Language.Syntax +import Swarm.Language.Syntax.Direction -- | A /requirement/ is something a robot must have when it is -- built. There are three types: diff --git a/src/swarm-lang/Swarm/Language/Syntax.hs b/src/swarm-lang/Swarm/Language/Syntax.hs index de92a7d2..d83282d0 100644 --- a/src/swarm-lang/Swarm/Language/Syntax.hs +++ b/src/swarm-lang/Swarm/Language/Syntax.hs @@ -5,15 +5,6 @@ -- -- Abstract syntax for terms of the Swarm programming language. module Swarm.Language.Syntax ( - -- * Directions - Direction (..), - AbsoluteDir (..), - RelativeDir (..), - PlanarRelativeDir (..), - directionSyntax, - isCardinal, - allDirs, - -- * Constants Const (..), allConst, @@ -104,7 +95,6 @@ module Swarm.Language.Syntax ( import Swarm.Language.Syntax.AST import Swarm.Language.Syntax.Comments import Swarm.Language.Syntax.Constants -import Swarm.Language.Syntax.Direction import Swarm.Language.Syntax.Loc import Swarm.Language.Syntax.Pattern import Swarm.Language.Syntax.Util diff --git a/src/swarm-lang/Swarm/Language/Value.hs b/src/swarm-lang/Swarm/Language/Value.hs index 17651997..1edb641f 100644 --- a/src/swarm-lang/Swarm/Language/Value.hs +++ b/src/swarm-lang/Swarm/Language/Value.hs @@ -31,6 +31,7 @@ import Swarm.Language.Context import Swarm.Language.Key (KeyCombo, prettyKeyCombo) import Swarm.Language.Pretty (prettyText) import Swarm.Language.Syntax +import Swarm.Language.Syntax.Direction -- | A /value/ is a term that cannot (or does not) take any more -- evaluation steps on its own. diff --git a/src/swarm-scenario/Swarm/Game/Display.hs b/src/swarm-scenario/Swarm/Game/Display.hs index cb96419a..c671cdb2 100644 --- a/src/swarm-scenario/Swarm/Game/Display.hs +++ b/src/swarm-scenario/Swarm/Game/Display.hs @@ -48,7 +48,7 @@ import Data.Text qualified as T import Data.Yaml import GHC.Generics (Generic) import Graphics.Text.Width -import Swarm.Language.Syntax (AbsoluteDir (..), Direction (..)) +import Swarm.Language.Syntax.Direction (AbsoluteDir (..), Direction (..)) import Swarm.Util (maxOn, quote) import Swarm.Util.Lens (makeLensesNoSigs) import Swarm.Util.Yaml (FromJSONE (..), With (runE), getE, liftE, withObjectE) diff --git a/src/swarm-scenario/Swarm/Game/Scenario.hs b/src/swarm-scenario/Swarm/Game/Scenario.hs index 1cf7ddd4..4a73c816 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario.hs @@ -102,6 +102,7 @@ import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly import Swarm.Game.Scenario.Topography.Structure.Overlay import Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (SymmetryAnnotatedGrid (..)) +import Swarm.Game.Scenario.Topography.Structure.Type qualified as Structure import Swarm.Game.Scenario.Topography.WorldDescription import Swarm.Game.Terrain import Swarm.Game.Universe diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs index 22dae502..076eb7bf 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- SPDX-License-Identifier: BSD-3-Clause @@ -11,45 +12,22 @@ module Swarm.Game.Scenario.Topography.Structure where import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap import Data.Maybe (catMaybes) -import Data.Set (Set) import Data.Text (Text) import Data.Text qualified as T import Data.Yaml as Y import Swarm.Game.Land import Swarm.Game.Location -import Swarm.Game.Scenario.RobotLookup +import Swarm.Game.Scenario.RobotLookup (RobotMap) import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.Navigation.Waypoint -import Swarm.Game.Scenario.Topography.Placement import Swarm.Game.Scenario.Topography.Structure.Overlay +import Swarm.Game.Scenario.Topography.Structure.Type import Swarm.Game.Scenario.Topography.WorldPalette -import Swarm.Language.Syntax.Direction (AbsoluteDir) import Swarm.Util (failT, showT) import Swarm.Util.Yaml import Witch (into) -data NamedArea a = NamedArea - { name :: StructureName - , recognize :: Set AbsoluteDir - -- ^ whether this structure should be registered for automatic recognition - -- and which orientations shall be recognized. - -- The supplied direction indicates which cardinal direction the - -- original map's "North" has been re-oriented to. - -- E.g., 'DWest' represents a rotation of 90 degrees counter-clockwise. - , description :: Maybe Text - -- ^ will be UI-facing only if this is a recognizable structure - , structure :: a - } - deriving (Eq, Show, Functor) - -isRecognizable :: NamedArea a -> Bool -isRecognizable = not . null . recognize - -type NamedGrid c = NamedArea (Grid c) - -type NamedStructure c = NamedArea (PStructure c) - type InheritedStructureDefs = [NamedStructure (Maybe Cell)] instance FromJSONE (TerrainEntityMaps, RobotMap) (NamedArea (PStructure (Maybe Cell))) where @@ -61,33 +39,6 @@ instance FromJSONE (TerrainEntityMaps, RobotMap) (NamedArea (PStructure (Maybe C <*> v ..: "structure" -data PStructure c = Structure - { area :: PositionedGrid c - , structures :: [NamedStructure c] - -- ^ structure definitions from parents shall be accessible by children - , placements :: [Placement] - -- ^ earlier placements will be overlaid on top of later placements in the YAML file - , waypoints :: [Waypoint] - } - deriving (Eq, Show) - -data Placed c = Placed Placement (NamedStructure c) - deriving (Show) - --- | For use in registering recognizable pre-placed structures -data LocatedStructure = LocatedStructure - { placedName :: StructureName - , upDirection :: AbsoluteDir - , cornerLoc :: Location - } - deriving (Show) - -instance HasLocation LocatedStructure where - modifyLoc f (LocatedStructure x y originalLoc) = - LocatedStructure x y $ f originalLoc - -data MergedStructure c = MergedStructure (PositionedGrid c) [LocatedStructure] [Originated Waypoint] - instance FromJSONE (TerrainEntityMaps, RobotMap) (PStructure (Maybe Cell)) where parseJSONE = withObjectE "structure definition" $ \v -> do pal <- v ..:? "palette" ..!= WorldPalette mempty diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs index 99e1a84c..e9b2a433 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Precompute.hs @@ -43,6 +43,7 @@ module Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute ( import Control.Arrow ((&&&)) import Control.Lens (view) +import Data.Hashable (Hashable) import Data.Int (Int32) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M @@ -51,28 +52,28 @@ import Data.Semigroup (sconcat) import Data.Set qualified as S import Data.Set qualified as Set import Data.Tuple (swap) -import Swarm.Game.Entity (Entity, entityName) +import Swarm.Game.Entity (Entity, EntityName, entityName) import Swarm.Game.Scenario (StaticStructureInfo (..)) import Swarm.Game.Scenario.Topography.Area (Grid (Grid)) -import Swarm.Game.Scenario.Topography.Cell +import Swarm.Game.Scenario.Topography.Cell (PCell, cellEntity) import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransform) -import Swarm.Game.Scenario.Topography.Structure import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.Scenario.Topography.Structure.Type import Swarm.Game.Universe (Cosmic (..)) import Swarm.Language.Syntax.Direction (AbsoluteDir) import Swarm.Util (binTuples, histogram) import Swarm.Util.Erasable (erasableToMaybe) import Text.AhoCorasick -getEntityGrid :: Grid (Maybe Cell) -> [SymbolSequence] +getEntityGrid :: Grid (Maybe (PCell Entity)) -> [SymbolSequence Entity] getEntityGrid (Grid cells) = map (map ((erasableToMaybe . cellEntity) =<<)) cells -allStructureRows :: [StructureWithGrid] -> [StructureRow] +allStructureRows :: [StructureWithGrid b a] -> [StructureRow b a] allStructureRows = concatMap getRows where - getRows :: StructureWithGrid -> [StructureRow] + getRows :: StructureWithGrid b a -> [StructureRow b a] getRows g = zipWith (StructureRow g) [0 ..] $ entityGrid g mkOffsets :: Foldable f => Int32 -> f a -> InspectionOffsets @@ -85,9 +86,11 @@ mkOffsets pos xs = -- yield a searcher that can determine whether adjacent -- rows constitute a complete structure. mkRowLookup :: - NE.NonEmpty StructureRow -> - AutomatonInfo SymbolSequence StructureWithGrid -mkRowLookup neList = + (Hashable a, Ord en) => + (a -> en) -> + NE.NonEmpty (StructureRow b a) -> + AutomatonInfo en (SymbolSequence a) (StructureWithGrid b a) +mkRowLookup nameFunc neList = AutomatonInfo participatingEnts bounds sm where mkSmTuple = entityGrid &&& id @@ -96,10 +99,10 @@ mkRowLookup neList = -- All of the unique entities across all of the full candidate structures participatingEnts = S.fromList $ - map (view entityName) $ + map nameFunc $ concatMap (concatMap catMaybes . fst) tuples - deriveRowOffsets :: StructureRow -> InspectionOffsets + deriveRowOffsets :: StructureRow b a -> InspectionOffsets deriveRowOffsets (StructureRow (StructureWithGrid _ _ g) rwIdx _) = mkOffsets rwIdx g @@ -113,27 +116,27 @@ mkRowLookup neList = -- underlying world row against all rows within all structures -- (so long as they contain the keyed entity). mkEntityLookup :: - [StructureWithGrid] -> - M.Map Entity (AutomatonInfo AtomicKeySymbol StructureSearcher) -mkEntityLookup grids = + (Hashable a, Ord a, Ord en) => + (a -> en) -> + [StructureWithGrid b a] -> + M.Map a (AutomatonInfo en (AtomicKeySymbol a) (StructureSearcher b en a)) +mkEntityLookup nameFunc grids = M.map mkValues rowsByEntityParticipation where rowsAcrossAllStructures = allStructureRows grids -- The input here are all rows across all structures -- that share the same entity sequence. - mkSmValue :: SymbolSequence -> NE.NonEmpty SingleRowEntityOccurrences -> StructureSearcher mkSmValue ksms singleRows = StructureSearcher sm2D ksms singleRows where structureRowsNE = NE.map myRow singleRows - sm2D = mkRowLookup structureRowsNE + sm2D = mkRowLookup nameFunc structureRowsNE - mkValues :: NE.NonEmpty SingleRowEntityOccurrences -> AutomatonInfo AtomicKeySymbol StructureSearcher mkValues neList = AutomatonInfo participatingEnts bounds sm where participatingEnts = - (S.fromList . map (view entityName)) + (S.fromList . map nameFunc) (concatMap (catMaybes . fst) tuples) tuples = M.toList $ M.mapWithKey mkSmValue groupedByUniqueRow @@ -144,19 +147,18 @@ mkEntityLookup grids = -- The values of this map are guaranteed to contain only one -- entry per row of a given structure. - rowsByEntityParticipation :: M.Map Entity (NE.NonEmpty SingleRowEntityOccurrences) rowsByEntityParticipation = binTuples $ map (myEntity &&& id) $ concatMap explodeRowEntities rowsAcrossAllStructures - deriveEntityOffsets :: PositionWithinRow -> InspectionOffsets + deriveEntityOffsets :: PositionWithinRow b a -> InspectionOffsets deriveEntityOffsets (PositionWithinRow pos r) = mkOffsets pos $ rowContent r -- The members of "rowMembers" are of 'Maybe' type; the 'Nothing's -- are dropped but accounted for when indexing the columns. - explodeRowEntities :: StructureRow -> [SingleRowEntityOccurrences] + explodeRowEntities :: Ord a => StructureRow b a -> [SingleRowEntityOccurrences b a] explodeRowEntities r@(StructureRow _ _ rowMembers) = map f $ M.toList $ binTuples unconsolidated where @@ -171,18 +173,23 @@ mkEntityLookup grids = -- | Create Aho-Corasick matchers that will recognize all of the -- provided structure definitions -mkAutomatons :: [SymmetryAnnotatedGrid (Maybe Cell)] -> RecognizerAutomatons +mkAutomatons :: + [SymmetryAnnotatedGrid (Maybe (PCell Entity))] -> + RecognizerAutomatons (PCell Entity) EntityName Entity mkAutomatons xs = RecognizerAutomatons infos - (mkEntityLookup rotatedGrids) + (mkEntityLookup (view entityName) rotatedGrids) where rotatedGrids = concatMap (extractGrids . namedGrid) xs process g = StructureInfo g (getEntityGrid $ structure $ namedGrid g) . histogram . concatMap catMaybes . getEntityGrid . structure $ namedGrid g infos = M.fromList $ map (name . namedGrid &&& process) xs -extractOrientedGrid :: NamedGrid (Maybe Cell) -> AbsoluteDir -> StructureWithGrid +extractOrientedGrid :: + NamedGrid (Maybe (PCell Entity)) -> + AbsoluteDir -> + StructureWithGrid (PCell Entity) Entity extractOrientedGrid x d = StructureWithGrid x d $ getEntityGrid g' where Grid rows = structure x @@ -191,13 +198,13 @@ extractOrientedGrid x d = StructureWithGrid x d $ getEntityGrid g' -- | At this point, we have already ensured that orientations -- redundant by rotational symmetry have been excluded -- (i.e. at Scenario validation time). -extractGrids :: NamedGrid (Maybe Cell) -> [StructureWithGrid] +extractGrids :: NamedGrid (Maybe (PCell Entity)) -> [StructureWithGrid (PCell Entity) Entity] extractGrids x = map (extractOrientedGrid x) $ Set.toList $ recognize x -- | The output list of 'FoundStructure' records is not yet -- vetted; the 'ensureStructureIntact' function will subsequently -- filter this list. -lookupStaticPlacements :: StaticStructureInfo -> [FoundStructure] +lookupStaticPlacements :: StaticStructureInfo -> [FoundStructure (PCell Entity) Entity] lookupStaticPlacements (StaticStructureInfo structDefs thePlacements) = concatMap f $ M.toList thePlacements where diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs index 9f033dda..9979215d 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs +++ b/src/swarm-scenario/Swarm/Game/Scenario/Topography/WorldDescription.hs @@ -27,13 +27,15 @@ import Swarm.Game.Scenario.Topography.Navigation.Waypoint ( ) import Swarm.Game.Scenario.Topography.Structure ( InheritedStructureDefs, - LocatedStructure, - MergedStructure (MergedStructure), - PStructure (Structure), ) import Swarm.Game.Scenario.Topography.Structure qualified as Structure import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly import Swarm.Game.Scenario.Topography.Structure.Overlay +import Swarm.Game.Scenario.Topography.Structure.Type ( + LocatedStructure, + MergedStructure (MergedStructure), + PStructure (Structure), + ) import Swarm.Game.Scenario.Topography.WorldPalette import Swarm.Game.Universe import Swarm.Game.World.Parse () diff --git a/src/swarm-scenario/Swarm/Game/Location.hs b/src/swarm-topography/Swarm/Game/Location.hs similarity index 98% rename from src/swarm-scenario/Swarm/Game/Location.hs rename to src/swarm-topography/Swarm/Game/Location.hs index 1374cbad..257ec535 100644 --- a/src/swarm-scenario/Swarm/Game/Location.hs +++ b/src/swarm-topography/Swarm/Game/Location.hs @@ -50,7 +50,7 @@ import Data.Map qualified as M import Data.Yaml (FromJSON (parseJSON), ToJSON (toJSON)) import Linear (Additive (..), V2 (..), negated, norm, perp, unangle) import Linear.Affine (Affine (..), Point (..), origin) -import Swarm.Language.Syntax (AbsoluteDir (..), Direction (..), PlanarRelativeDir (..), RelativeDir (..), isCardinal) +import Swarm.Language.Syntax.Direction (AbsoluteDir (..), Direction (..), PlanarRelativeDir (..), RelativeDir (..), isCardinal) import Swarm.Util qualified as Util -- $setup diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Area.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs similarity index 100% rename from src/swarm-scenario/Swarm/Game/Scenario/Topography/Area.hs rename to src/swarm-topography/Swarm/Game/Scenario/Topography/Area.hs diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs similarity index 100% rename from src/swarm-scenario/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs rename to src/swarm-topography/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Placement.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs similarity index 100% rename from src/swarm-scenario/Swarm/Game/Scenario/Topography/Placement.hs rename to src/swarm-topography/Swarm/Game/Scenario/Topography/Placement.hs diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Assembly.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs similarity index 99% rename from src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Assembly.hs rename to src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs index a5864848..ab70be3d 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Assembly.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs @@ -25,8 +25,8 @@ import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Navigation.Waypoint import Swarm.Game.Scenario.Topography.Placement -import Swarm.Game.Scenario.Topography.Structure import Swarm.Game.Scenario.Topography.Structure.Overlay +import Swarm.Game.Scenario.Topography.Structure.Type import Swarm.Language.Syntax.Direction (directionJsonModifier) import Swarm.Util (commaList, quote, showT) diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Overlay.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs similarity index 100% rename from src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Overlay.hs rename to src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs similarity index 64% rename from src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition.hs rename to src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs index 30709a26..c37ddf55 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition.hs @@ -12,11 +12,14 @@ import Swarm.Game.Scenario.Topography.Structure.Recognition.Log import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry import Swarm.Game.Scenario.Topography.Structure.Recognition.Type -data StructureRecognizer = StructureRecognizer - { _automatons :: RecognizerAutomatons - , _foundStructures :: FoundRegistry +-- | +-- The three type parameters, `b`, `en`, and `a`, correspond +-- to 'Cell', 'EntityName', and 'Entity', respectively. +data StructureRecognizer b en a = StructureRecognizer + { _automatons :: RecognizerAutomatons b en a + , _foundStructures :: FoundRegistry b a -- ^ Records the top-left corner of the found structure - , _recognitionLog :: [SearchLog] + , _recognitionLog :: [SearchLog en] } deriving (Generic) diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs similarity index 74% rename from src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs rename to src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs index c7b8d00c..d1c41c2b 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Log.hs @@ -9,14 +9,13 @@ import Data.Int (Int32) import GHC.Generics (Generic) import Servant.Docs (ToSample) import Servant.Docs qualified as SD -import Swarm.Game.Entity (EntityName) import Swarm.Game.Location (Location) import Swarm.Game.Scenario.Topography.Placement (StructureName) import Swarm.Game.Scenario.Topography.Structure.Recognition.Type import Swarm.Game.Universe (Cosmic) -type StructureRowContent = [Maybe EntityName] -type WorldRowContent = [Maybe EntityName] +type StructureRowContent en = [Maybe en] +type WorldRowContent en = [Maybe en] data MatchingRowFrom = MatchingRowFrom { rowIdx :: Int32 @@ -27,21 +26,21 @@ data MatchingRowFrom = MatchingRowFrom newtype HaystackPosition = HaystackPosition Int deriving (Generic, ToJSON) -data HaystackContext = HaystackContext - { worldRow :: WorldRowContent +data HaystackContext en = HaystackContext + { worldRow :: WorldRowContent en , haystackPosition :: HaystackPosition } deriving (Generic, ToJSON) -data FoundRowCandidate = FoundRowCandidate - { haystackContext :: HaystackContext - , structureContent :: StructureRowContent +data FoundRowCandidate en = FoundRowCandidate + { haystackContext :: HaystackContext en + , structureContent :: StructureRowContent en , rowCandidates :: [MatchingRowFrom] } deriving (Generic, ToJSON) -data ParticipatingEntity = ParticipatingEntity - { entity :: EntityName +data ParticipatingEntity en = ParticipatingEntity + { entity :: en , searchOffsets :: InspectionOffsets } deriving (Generic, ToJSON) @@ -53,15 +52,15 @@ data IntactPlacementLog = IntactPlacementLog } deriving (Generic, ToJSON) -data SearchLog - = FoundParticipatingEntity ParticipatingEntity +data SearchLog en + = FoundParticipatingEntity (ParticipatingEntity en) | StructureRemoved StructureName - | FoundRowCandidates [FoundRowCandidate] + | FoundRowCandidates [FoundRowCandidate en] | FoundCompleteStructureCandidates [StructureName] | IntactStaticPlacement [IntactPlacementLog] deriving (Generic) -instance ToJSON SearchLog where +instance (ToJSON en) => ToJSON (SearchLog en) where toJSON = genericToJSON searchLogOptions searchLogOptions :: Options @@ -70,7 +69,7 @@ searchLogOptions = { sumEncoding = ObjectWithSingleField } -instance ToSample SearchLog where +instance ToSample (SearchLog en) where toSamples _ = SD.noSamples data StructureLocation = StructureLocation StructureName (Cosmic Location) diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs similarity index 77% rename from src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs rename to src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs index d1f12cb1..67b26c2d 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Registry.hs @@ -29,24 +29,27 @@ import Data.Map.NonEmpty (NEMap) import Data.Map.NonEmpty qualified as NEM import Swarm.Game.Location (Location) import Swarm.Game.Scenario.Topography.Placement (StructureName) -import Swarm.Game.Scenario.Topography.Structure qualified as Structure import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.Scenario.Topography.Structure.Type qualified as Structure import Swarm.Game.Universe (Cosmic) import Swarm.Util (binTuples, deleteKeys) -- | The authoritative source of which built structures currently exist. -data FoundRegistry = FoundRegistry - { _foundByName :: Map StructureName (NEMap (Cosmic Location) StructureWithGrid) - , _foundByLocation :: Map (Cosmic Location) FoundStructure +-- +-- The two type parameters, `b` and `a`, correspond +-- to 'Cell' and 'Entity', respectively. +data FoundRegistry b a = FoundRegistry + { _foundByName :: Map StructureName (NEMap (Cosmic Location) (StructureWithGrid b a)) + , _foundByLocation :: Map (Cosmic Location) (FoundStructure b a) } -emptyFoundStructures :: FoundRegistry +emptyFoundStructures :: FoundRegistry b a emptyFoundStructures = FoundRegistry mempty mempty -- | We use a 'NEMap' here so that we can use the -- safe-indexing function 'indexWrapNonEmpty' in the implementation -- of the @structure@ command. -foundByName :: FoundRegistry -> Map StructureName (NEMap (Cosmic Location) StructureWithGrid) +foundByName :: FoundRegistry b a -> Map StructureName (NEMap (Cosmic Location) (StructureWithGrid b a)) foundByName = _foundByName -- | This is a worldwide "mask" that prevents members of placed @@ -54,10 +57,10 @@ foundByName = _foundByName -- deletion of structures when their elements are removed from the world. -- -- Each recognized structure instance will have @MxN@ entries in this map. -foundByLocation :: FoundRegistry -> Map (Cosmic Location) FoundStructure +foundByLocation :: FoundRegistry b a -> Map (Cosmic Location) (FoundStructure b a) foundByLocation = _foundByLocation -removeStructure :: FoundStructure -> FoundRegistry -> FoundRegistry +removeStructure :: FoundStructure b a -> FoundRegistry b a -> FoundRegistry b a removeStructure fs (FoundRegistry byName byLoc) = FoundRegistry (M.update tidyDelete structureName byName) @@ -71,7 +74,7 @@ removeStructure fs (FoundRegistry byName byLoc) = -- Swarm.Game.State.removeRobotFromLocationMap tidyDelete = NEM.nonEmptyMap . NEM.delete upperLeft -addFound :: FoundStructure -> FoundRegistry -> FoundRegistry +addFound :: FoundStructure b a -> FoundRegistry b a -> FoundRegistry b a addFound fs@(FoundStructure swg loc) (FoundRegistry byName byLoc) = FoundRegistry (M.insertWith (<>) k (NEM.singleton loc swg) byName) @@ -84,7 +87,7 @@ addFound fs@(FoundStructure swg loc) (FoundRegistry byName byLoc) = -- -- Each of these shall have been re-checked in case -- a subsequent placement occludes them. -populateStaticFoundStructures :: [FoundStructure] -> FoundRegistry +populateStaticFoundStructures :: [FoundStructure b a] -> FoundRegistry b a populateStaticFoundStructures allFound = FoundRegistry byName byLocation where diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs similarity index 97% rename from src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs rename to src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs index 758cd733..d7eee1e0 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Symmetry.hs @@ -12,8 +12,8 @@ import Data.Set qualified as Set import Data.Text qualified as T import Swarm.Game.Scenario.Topography.Area (Grid (Grid)) import Swarm.Game.Scenario.Topography.Placement (Orientation (..), applyOrientationTransform) -import Swarm.Game.Scenario.Topography.Structure qualified as Structure import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (RotationalSymmetry (..), SymmetryAnnotatedGrid (..)) +import Swarm.Game.Scenario.Topography.Structure.Type qualified as Structure import Swarm.Language.Syntax.Direction (AbsoluteDir (DSouth, DWest), getCoordinateOrientation) import Swarm.Util (commaList, failT, histogram, showT) diff --git a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs similarity index 75% rename from src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs rename to src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs index 8cbc6fe9..99607637 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Recognition/Type.hs @@ -31,14 +31,12 @@ import Data.Semigroup (Max, Min) import Data.Set (Set) import GHC.Generics (Generic) import Linear (V2 (..)) -import Swarm.Game.Entity (Entity, EntityName) import Swarm.Game.Location (Location) import Swarm.Game.Scenario.Topography.Area -import Swarm.Game.Scenario.Topography.Cell import Swarm.Game.Scenario.Topography.Placement (StructureName) -import Swarm.Game.Scenario.Topography.Structure (NamedGrid) +import Swarm.Game.Scenario.Topography.Structure.Type (NamedGrid) import Swarm.Game.Universe (Cosmic, offsetBy) -import Swarm.Language.Syntax (AbsoluteDir) +import Swarm.Language.Syntax.Direction (AbsoluteDir) import Text.AhoCorasick (StateMachine) -- | A "needle" consisting of a single cell within @@ -50,7 +48,7 @@ import Text.AhoCorasick (StateMachine) -- @ -- aab -- @ -type AtomicKeySymbol = Maybe Entity +type AtomicKeySymbol a = Maybe a -- | A "needle" consisting row of cells within the haystack -- (a sequence of rows) to be searched. @@ -61,15 +59,15 @@ type AtomicKeySymbol = Maybe Entity -- @ -- aab -- @ -type SymbolSequence = [AtomicKeySymbol] +type SymbolSequence a = [AtomicKeySymbol a] -- | This is returned as a value of the 1-D searcher. -- It contains search automatons customized to the 2-D structures -- that may possibly contain the row found by the 1-D searcher. -data StructureSearcher = StructureSearcher - { automaton2D :: AutomatonInfo SymbolSequence StructureWithGrid - , needleContent :: SymbolSequence - , singleRowItems :: NE.NonEmpty SingleRowEntityOccurrences +data StructureSearcher b en a = StructureSearcher + { automaton2D :: AutomatonInfo en (SymbolSequence a) (StructureWithGrid b a) + , needleContent :: SymbolSequence a + , singleRowItems :: NE.NonEmpty (SingleRowEntityOccurrences b a) } -- | @@ -83,10 +81,10 @@ data StructureSearcher = StructureSearcher -- @ -- -- Its '_position' is @2@. -data PositionWithinRow = PositionWithinRow +data PositionWithinRow b a = PositionWithinRow { _position :: Int32 -- ^ horizontal index of the entity within the row - , structureRow :: StructureRow + , structureRow :: StructureRow b a } -- Represents all of the locations that particular entity @@ -100,10 +98,10 @@ data PositionWithinRow = PositionWithinRow -- @ -- -- this record will contain two entries in its 'entityOccurrences' field. -data SingleRowEntityOccurrences = SingleRowEntityOccurrences - { myRow :: StructureRow - , myEntity :: Entity - , entityOccurrences :: NE.NonEmpty PositionWithinRow +data SingleRowEntityOccurrences b a = SingleRowEntityOccurrences + { myRow :: StructureRow b a + , myEntity :: a + , entityOccurrences :: NE.NonEmpty (PositionWithinRow b a) , expandedOffsets :: InspectionOffsets } @@ -119,19 +117,25 @@ data SingleRowEntityOccurrences = SingleRowEntityOccurrences -- @ -- -- it's 'rowIndex' is @2@. -data StructureRow = StructureRow - { wholeStructure :: StructureWithGrid +-- +-- The two type parameters, `b` and `a`, correspond +-- to 'Cell' and 'Entity', respectively. +data StructureRow b a = StructureRow + { wholeStructure :: StructureWithGrid b a , rowIndex :: Int32 -- ^ vertical index of the row within the structure - , rowContent :: SymbolSequence + , rowContent :: SymbolSequence a } -- | The original definition of a structure, bundled -- with its grid of cells having been extracted for convenience. -data StructureWithGrid = StructureWithGrid - { originalDefinition :: NamedGrid (Maybe Cell) +-- +-- The two type parameters, `b` and `a`, correspond +-- to 'Cell' and 'Entity', respectively. +data StructureWithGrid b a = StructureWithGrid + { originalDefinition :: NamedGrid (Maybe b) , rotatedTo :: AbsoluteDir - , entityGrid :: [SymbolSequence] + , entityGrid :: [SymbolSequence a] } deriving (Eq) @@ -151,10 +155,10 @@ data SymmetryAnnotatedGrid a = SymmetryAnnotatedGrid deriving (Show) -- | Structure definitions with precomputed metadata for consumption by the UI -data StructureInfo = StructureInfo - { annotatedGrid :: SymmetryAnnotatedGrid (Maybe Cell) - , entityProcessedGrid :: [SymbolSequence] - , entityCounts :: Map Entity Int +data StructureInfo b a = StructureInfo + { annotatedGrid :: SymmetryAnnotatedGrid (Maybe b) + , entityProcessedGrid :: [SymbolSequence a] + , entityCounts :: Map a Int } -- | For all of the rows that contain a given entity @@ -187,8 +191,8 @@ instance Semigroup InspectionOffsets where -- | 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 v = AutomatonInfo - { _participatingEntities :: Set EntityName +data AutomatonInfo en k v = AutomatonInfo + { _participatingEntities :: Set en , _inspectionOffsets :: InspectionOffsets , _automaton :: StateMachine k v } @@ -198,11 +202,11 @@ makeLenses ''AutomatonInfo -- | The complete set of data needed to identify applicable -- structures, based on a just-placed entity. -data RecognizerAutomatons = RecognizerAutomatons - { _originalStructureDefinitions :: Map StructureName StructureInfo +data RecognizerAutomatons b en a = RecognizerAutomatons + { _originalStructureDefinitions :: Map StructureName (StructureInfo b a) -- ^ all of the structures that shall participate in automatic recognition. -- This list is used only by the UI and by the 'Floorplan' command. - , _automatonsByEntity :: Map Entity (AutomatonInfo AtomicKeySymbol StructureSearcher) + , _automatonsByEntity :: Map a (AutomatonInfo en (AtomicKeySymbol a) (StructureSearcher b en a)) } deriving (Generic) @@ -210,8 +214,11 @@ makeLenses ''RecognizerAutomatons -- | Final output of the search process. -- These are the elements that are stored in the 'FoundRegistry'. -data FoundStructure = FoundStructure - { structureWithGrid :: StructureWithGrid +-- +-- The two type parameters, `b` and `a`, correspond +-- to 'Cell' and 'Entity', respectively. +data FoundStructure b a = FoundStructure + { structureWithGrid :: StructureWithGrid b a , upperLeftCorner :: Cosmic Location } deriving (Eq) @@ -226,7 +233,7 @@ data FoundStructure = FoundStructure -- Since the natural order of coordinates increases as described, -- we need to invert it with 'Down' so that this ordering is by -- increasing preference. -instance Ord FoundStructure where +instance (Eq b, Eq a) => Ord (FoundStructure b a) where compare = compare `on` (f1 &&& f2) where f1 = computeArea . getAreaDimensions . entityGrid . structureWithGrid @@ -235,7 +242,7 @@ instance Ord FoundStructure where -- | Yields coordinates that are occupied by an entity of a placed structure. -- Cells within the rectangular bounds of the structure that are unoccupied -- are not included. -genOccupiedCoords :: FoundStructure -> [Cosmic Location] +genOccupiedCoords :: FoundStructure b a -> [Cosmic Location] genOccupiedCoords (FoundStructure swg loc) = concatMap catMaybes . zipWith mkRow [0 ..] $ entityGrid swg where diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Type.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Type.hs new file mode 100644 index 00000000..f7a452a7 --- /dev/null +++ b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Type.hs @@ -0,0 +1,63 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Definitions of "structures" for use within a map +-- as well as logic for combining them. +module Swarm.Game.Scenario.Topography.Structure.Type where + +import Data.Set (Set) +import Data.Text (Text) +import Swarm.Game.Location +import Swarm.Game.Scenario.Topography.Area +import Swarm.Game.Scenario.Topography.Navigation.Waypoint +import Swarm.Game.Scenario.Topography.Placement +import Swarm.Game.Scenario.Topography.Structure.Overlay +import Swarm.Language.Syntax.Direction (AbsoluteDir) + +data NamedArea a = NamedArea + { name :: StructureName + , recognize :: Set AbsoluteDir + -- ^ whether this structure should be registered for automatic recognition + -- and which orientations shall be recognized. + -- The supplied direction indicates which cardinal direction the + -- original map's "North" has been re-oriented to. + -- E.g., 'DWest' represents a rotation of 90 degrees counter-clockwise. + , description :: Maybe Text + -- ^ will be UI-facing only if this is a recognizable structure + , structure :: a + } + deriving (Eq, Show, Functor) + +isRecognizable :: NamedArea a -> Bool +isRecognizable = not . null . recognize + +type NamedGrid c = NamedArea (Grid c) + +type NamedStructure c = NamedArea (PStructure c) + +data PStructure c = Structure + { area :: PositionedGrid c + , structures :: [NamedStructure c] + -- ^ structure definitions from parents shall be accessible by children + , placements :: [Placement] + -- ^ earlier placements will be overlaid on top of later placements in the YAML file + , waypoints :: [Waypoint] + } + deriving (Eq, Show) + +data Placed c = Placed Placement (NamedStructure c) + deriving (Show) + +-- | For use in registering recognizable pre-placed structures +data LocatedStructure = LocatedStructure + { placedName :: StructureName + , upDirection :: AbsoluteDir + , cornerLoc :: Location + } + deriving (Show) + +instance HasLocation LocatedStructure where + modifyLoc f (LocatedStructure x y originalLoc) = + LocatedStructure x y $ f originalLoc + +data MergedStructure c = MergedStructure (PositionedGrid c) [LocatedStructure] [Originated Waypoint] diff --git a/src/swarm-scenario/Swarm/Game/Universe.hs b/src/swarm-topography/Swarm/Game/Universe.hs similarity index 100% rename from src/swarm-scenario/Swarm/Game/Universe.hs rename to src/swarm-topography/Swarm/Game/Universe.hs diff --git a/src/swarm-tui/Swarm/TUI/Model/Structure.hs b/src/swarm-tui/Swarm/TUI/Model/Structure.hs index a588465c..14d12fd9 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Structure.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Structure.hs @@ -10,12 +10,14 @@ module Swarm.TUI.Model.Structure where import Brick.Focus import Brick.Widgets.List qualified as BL import Control.Lens (makeLenses) +import Swarm.Game.Entity (Entity) +import Swarm.Game.Scenario (Cell) import Swarm.Game.Scenario.Topography.Structure.Recognition.Type import Swarm.TUI.Model.Name import Swarm.Util (listEnums) data StructureDisplay = StructureDisplay - { _structurePanelListWidget :: BL.List Name StructureInfo + { _structurePanelListWidget :: BL.List Name (StructureInfo Cell Entity) -- ^ required for maintaining the selection/navigation -- state among list items , _structurePanelFocus :: FocusRing Name diff --git a/src/swarm-tui/Swarm/TUI/View/Structure.hs b/src/swarm-tui/Swarm/TUI/View/Structure.hs index 945161fa..26c79e39 100644 --- a/src/swarm-tui/Swarm/TUI/View/Structure.hs +++ b/src/swarm-tui/Swarm/TUI/View/Structure.hs @@ -19,14 +19,15 @@ import Data.Map.Strict qualified as M import Data.Set qualified as Set import Data.Text qualified as T import Data.Vector qualified as V -import Swarm.Game.Entity (entityDisplay) +import Swarm.Game.Entity (Entity, entityDisplay) +import Swarm.Game.Scenario (Cell) import Swarm.Game.Scenario.Topography.Area import Swarm.Game.Scenario.Topography.Placement -import Swarm.Game.Scenario.Topography.Structure qualified as Structure import Swarm.Game.Scenario.Topography.Structure.Recognition (foundStructures) import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute (getEntityGrid) import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry (foundByName) import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.Scenario.Topography.Structure.Type qualified as Structure import Swarm.Game.State import Swarm.Game.State.Substate import Swarm.Language.Syntax.Direction (directionJsonModifier) @@ -39,7 +40,7 @@ import Swarm.Util (commaList) -- | Render a two-pane widget with structure selection on the left -- and single-structure details on the right. -structureWidget :: GameState -> StructureInfo -> Widget n +structureWidget :: GameState -> StructureInfo Cell Entity -> Widget n structureWidget gs s = vBox [ hBox @@ -121,7 +122,7 @@ structureWidget gs s = cells = getEntityGrid $ Structure.structure d renderOneCell = maybe (txt " ") (renderDisplay . view entityDisplay) -makeListWidget :: [StructureInfo] -> BL.List Name StructureInfo +makeListWidget :: [StructureInfo Cell Entity] -> BL.List Name (StructureInfo Cell Entity) makeListWidget structureDefinitions = BL.listMoveTo 0 $ BL.list (StructureWidgets StructuresList) (V.fromList structureDefinitions) 1 @@ -163,7 +164,7 @@ renderStructuresDisplay gs structureDisplay = drawSidebarListItem :: Bool -> - StructureInfo -> + StructureInfo Cell Entity -> Widget Name drawSidebarListItem _isSelected (StructureInfo annotated _ _) = txt . getStructureName . Structure.name $ namedGrid annotated diff --git a/src/swarm-lang/Swarm/Language/Syntax/Direction.hs b/src/swarm-util/Swarm/Language/Syntax/Direction.hs similarity index 100% rename from src/swarm-lang/Swarm/Language/Syntax/Direction.hs rename to src/swarm-util/Swarm/Language/Syntax/Direction.hs diff --git a/src/swarm-web/Swarm/Web.hs b/src/swarm-web/Swarm/Web.hs index 6b0f70ad..5f79c51b 100644 --- a/src/swarm-web/Swarm/Web.hs +++ b/src/swarm-web/Swarm/Web.hs @@ -64,6 +64,7 @@ import Servant.Docs (ToCapture) import Servant.Docs qualified as SD import Servant.Docs.Internal qualified as SD (renderCurlBasePath) import Swarm.Doc.Command +import Swarm.Game.Entity (EntityName) import Swarm.Game.Robot import Swarm.Game.Scenario.Objective import Swarm.Game.Scenario.Objective.Graph @@ -104,7 +105,7 @@ type SwarmAPI = :<|> "goals" :> "graph" :> Get '[JSON] (Maybe GraphInfo) :<|> "goals" :> "uigoal" :> Get '[JSON] GoalTracking :<|> "goals" :> Get '[JSON] WinCondition - :<|> "recognize" :> "log" :> Get '[JSON] [SearchLog] + :<|> "recognize" :> "log" :> Get '[JSON] [SearchLog EntityName] :<|> "recognize" :> "found" :> Get '[JSON] [StructureLocation] :<|> "code" :> "render" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text :<|> "code" :> "run" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text @@ -210,7 +211,7 @@ goalsHandler appStateRef = do appState <- liftIO (readIORef appStateRef) return $ appState ^. gameState . winCondition -recogLogHandler :: ReadableIORef AppState -> Handler [SearchLog] +recogLogHandler :: ReadableIORef AppState -> Handler [SearchLog EntityName] recogLogHandler appStateRef = do appState <- liftIO (readIORef appStateRef) return $ appState ^. gameState . discovery . structureRecognition . recognitionLog diff --git a/swarm.cabal b/swarm.cabal index 52ab0e27..f8c5435f 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -152,7 +152,6 @@ library swarm-lang Swarm.Language.Syntax.CommandMetadata Swarm.Language.Syntax.Comments Swarm.Language.Syntax.Constants - Swarm.Language.Syntax.Direction Swarm.Language.Syntax.Loc Swarm.Language.Syntax.Pattern Swarm.Language.Syntax.Util @@ -201,6 +200,50 @@ library swarm-lang -- See discussion in #415 StrictData +library swarm-topography + import: stan-config, common, ghc2021-extensions + visibility: public + -- cabal-gild: discover src/swarm-topography + exposed-modules: + Swarm.Game.Location + Swarm.Game.Scenario.Topography.Area + Swarm.Game.Scenario.Topography.Navigation.Waypoint + Swarm.Game.Scenario.Topography.Placement + Swarm.Game.Scenario.Topography.Structure.Assembly + Swarm.Game.Scenario.Topography.Structure.Overlay + Swarm.Game.Scenario.Topography.Structure.Recognition + Swarm.Game.Scenario.Topography.Structure.Recognition.Log + Swarm.Game.Scenario.Topography.Structure.Recognition.Registry + Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry + Swarm.Game.Scenario.Topography.Structure.Recognition.Type + Swarm.Game.Scenario.Topography.Structure.Type + Swarm.Game.Universe + + other-modules: Paths_swarm + autogen-modules: Paths_swarm + build-depends: + AhoCorasick >=0.0.4 && <0.0.5, + aeson >=2.2 && <2.3, + base >=4.14 && <4.20, + containers >=0.6.2 && <0.8, + extra >=1.7 && <1.8, + lens, + linear >=1.21.6 && <1.24, + nonempty-containers >=0.3.4 && <0.3.5, + servant-docs >=0.12 && <0.14, + text >=1.2.4 && <2.2, + yaml >=0.11 && <0.11.12.0, + + build-depends: + swarm:swarm-util + + hs-source-dirs: src/swarm-topography + default-language: Haskell2010 + default-extensions: + -- Avoid unexpected unevaluated thunk buildup + -- See discussion in #415 + StrictData + library swarm-scenario import: stan-config, common, ghc2021-extensions visibility: public @@ -216,7 +259,6 @@ library swarm-scenario Swarm.Game.Failure Swarm.Game.Ingredients Swarm.Game.Land - Swarm.Game.Location Swarm.Game.Recipe Swarm.Game.ResourceLoading Swarm.Game.Robot @@ -228,28 +270,17 @@ library swarm-scenario Swarm.Game.Scenario.Objective.Validation Swarm.Game.Scenario.RobotLookup Swarm.Game.Scenario.Style - Swarm.Game.Scenario.Topography.Area Swarm.Game.Scenario.Topography.Cell Swarm.Game.Scenario.Topography.Center Swarm.Game.Scenario.Topography.EntityFacade Swarm.Game.Scenario.Topography.Navigation.Portal - Swarm.Game.Scenario.Topography.Navigation.Waypoint - Swarm.Game.Scenario.Topography.Placement Swarm.Game.Scenario.Topography.Structure - Swarm.Game.Scenario.Topography.Structure.Assembly - Swarm.Game.Scenario.Topography.Structure.Overlay - Swarm.Game.Scenario.Topography.Structure.Recognition - Swarm.Game.Scenario.Topography.Structure.Recognition.Log Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute - Swarm.Game.Scenario.Topography.Structure.Recognition.Registry - Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry - Swarm.Game.Scenario.Topography.Structure.Recognition.Type Swarm.Game.Scenario.Topography.WorldDescription Swarm.Game.Scenario.Topography.WorldPalette Swarm.Game.State.Config Swarm.Game.State.Landscape Swarm.Game.Terrain - Swarm.Game.Universe Swarm.Game.World Swarm.Game.World.Abstract Swarm.Game.World.Compile @@ -289,7 +320,6 @@ library swarm-scenario linear >=1.21.6 && <1.24, megaparsec >=9.6.1 && <9.7, murmur3 >=1.0.4 && <1.1, - nonempty-containers >=0.3.4 && <0.3.5, palette >=0.3 && <0.4, parser-combinators >=1.2 && <1.4, prettyprinter >=1.7.0 && <1.8, @@ -305,6 +335,7 @@ library swarm-scenario build-depends: swarm:swarm-lang, + swarm:swarm-topography, swarm:swarm-util, hs-source-dirs: src/swarm-scenario @@ -405,6 +436,7 @@ library swarm-engine build-depends: swarm:swarm-lang, swarm:swarm-scenario, + swarm:swarm-topography, swarm:swarm-util, hs-source-dirs: src/swarm-engine @@ -449,6 +481,7 @@ library swarm-web swarm:swarm-engine, swarm:swarm-lang, swarm:swarm-scenario, + swarm:swarm-topography, swarm:swarm-tui, swarm:swarm-util, @@ -520,6 +553,7 @@ library swarm-util exposed-modules: Control.Carrier.Accum.FixedStrict Data.BoolExpr.Simplify + Swarm.Language.Syntax.Direction Swarm.Util Swarm.Util.Effect Swarm.Util.Erasable @@ -545,6 +579,7 @@ library swarm-util extra >=1.7 && <1.8, filepath >=1.4 && <1.5, fused-effects >=1.1.1.1 && <1.2, + hashable >=1.3.4 && <1.5, lens >=4.19 && <5.4, minimorph >=0.3 && <0.4, mtl >=2.2.2 && <2.4, @@ -699,6 +734,7 @@ library swarm-tui swarm:swarm-engine, swarm:swarm-lang, swarm:swarm-scenario, + swarm:swarm-topography, swarm:swarm-util, hs-source-dirs: src/swarm-tui @@ -745,7 +781,10 @@ executable swarm-scene build-depends: base, optparse-applicative >=0.16 && <0.19, + + build-depends: swarm:swarm-scenario, + swarm:swarm-topography, hs-source-dirs: app/scene default-language: Haskell2010 @@ -836,6 +875,7 @@ test-suite swarm-unit swarm:swarm-engine, swarm:swarm-lang, swarm:swarm-scenario, + swarm:swarm-topography, swarm:swarm-tui, swarm:swarm-util, @@ -907,12 +947,15 @@ benchmark benchmark extra, lens, mtl, + tasty-bench >=0.3.1 && <0.4, + text, + + build-depends: swarm:swarm-engine, swarm:swarm-lang, swarm:swarm-scenario, + swarm:swarm-topography, swarm:swarm-util, - tasty-bench >=0.3.1 && <0.4, - text, default-language: Haskell2010 ghc-options: diff --git a/test/unit/TestCommand.hs b/test/unit/TestCommand.hs index 4ba30ba8..400e29fe 100644 --- a/test/unit/TestCommand.hs +++ b/test/unit/TestCommand.hs @@ -12,7 +12,7 @@ import Data.Text (Text) import Graphics.Vty.Input.Events qualified as V import Swarm.Game.Location import Swarm.Language.Key -import Swarm.Language.Syntax +import Swarm.Language.Syntax.Direction import Test.QuickCheck qualified as QC import Test.Tasty import Test.Tasty.HUnit