Implement boundary rendering

data/scenarios/Testing/00-ORDER.txt

@@ -36,6 +36,7 @@ Achievements
 1218-stride-command.yaml
 1234-push-command.yaml
 1256-halt-command.yaml
+1271-wall-boundaries.yaml
 1262-display-device-commands.yaml
 1295-density-command.yaml
 1138-structures

data/scenarios/Testing/1271-wall-boundaries.yaml

@@ -0,0 +1,96 @@
+version: 1
+name: Wall boundary display
+creative: false
+description: |
+  Demonstrate rendering of contiguous boundaries.
+
+  Only adjacent with the 'boundary' property
+  will be rendered with box border glyphs.
+attrs:
+  - name: purpleWall
+    fg: '#ff00ff'
+  - name: cyanWall
+    fg: '#00ffff'
+objectives:
+  - goal:
+      - Place all fences
+    condition: |
+      as base {
+        hasFence <- has "fence";
+        return $ not hasFence;
+      }
+solution: |
+  def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;
+
+  doN 4 (
+    doN 6 (place "fence"; move);
+    turn left;
+  );
+
+  doN 2 move;
+  turn left;
+
+  doN 2 (
+    doN 2 move;
+    place "fence";
+  );
+  turn right;
+  move;
+  turn right;
+  move;
+  place "fence";
+  move;
+  place "fence";
+  move;
+robots:
+  - name: base
+    dir: east
+    display:
+      attr: robot
+    devices:
+      - branch predictor
+      - comparator
+      - compass
+      - dictionary
+      - grabber
+      - logger
+      - treads
+      - antenna
+      - ADT calculator
+    inventory:
+      - [28, fence]
+entities:
+  - name: wall
+    display:
+      char: 'x'
+      attr: purpleWall
+    description:
+      - A wall
+    properties: [known, boundary]
+  - name: fence
+    display:
+      char: 'F'
+      attr: cyanWall
+    description:
+      - A fence
+    properties: [known, boundary]
+known: [boulder]
+world:
+  default: [blank]
+  palette:
+    'Ω': [grass, null, base]
+    '.': [grass]
+    '#': [grass, wall]
+    '@': [grass, boulder]
+  upperleft: [0, 0]
+  map: |
+    Ω.........
+    ....#.....
+    ..####..##
+    ..#.##....
+    ..#..#..#.
+    ..####..#.
+    ..........
+    ...@@@....
+    ...@.@....
+    ...@@@....

src/swarm-scenario/Swarm/Game/Display.hs

@@ -22,6 +22,7 @@ module Swarm.Game.Display (
   defaultChar,
   orientationMap,
   curOrientation,
+  boundaryOverride,
   displayAttr,
   displayPriority,
   invisible,
@@ -31,15 +32,20 @@ module Swarm.Game.Display (
   displayChar,
   hidden,
 
+  -- ** Neighbor-based boundary rendering
+  getBoundaryDisplay,
+
   -- ** Construction
   defaultTerrainDisplay,
   defaultEntityDisplay,
   defaultRobotDisplay,
 ) where
 
+import Control.Applicative ((<|>))
 import Control.Lens hiding (Const, from, (.=))
 import Control.Monad (when)
 import Data.Hashable (Hashable)
+import Data.List.Extra (enumerate)
 import Data.Map (Map)
 import Data.Map qualified as M
 import Data.Maybe (fromMaybe, isJust)
@@ -49,7 +55,7 @@ import Data.Yaml
 import GHC.Generics (Generic)
 import Graphics.Text.Width
 import Swarm.Language.Syntax.Direction (AbsoluteDir (..), Direction (..))
-import Swarm.Util (maxOn, quote)
+import Swarm.Util (applyWhen, maxOn, quote)
 import Swarm.Util.Lens (makeLensesNoSigs)
 import Swarm.Util.Yaml (FromJSONE (..), With (runE), getE, liftE, withObjectE)
 
@@ -89,6 +95,7 @@ data Display = Display
   { _defaultChar :: Char
   , _orientationMap :: Map AbsoluteDir Char
   , _curOrientation :: Maybe Direction
+  , _boundaryOverride :: Maybe Char
   , _displayAttr :: Attribute
   , _displayPriority :: Priority
   , _invisible :: Bool
@@ -117,6 +124,9 @@ orientationMap :: Lens' Display (Map AbsoluteDir Char)
 --   know which character to use from the orientation map.
 curOrientation :: Lens' Display (Maybe Direction)
 
+-- | The display character to substitute when neighbor boundaries are present
+boundaryOverride :: Lens' Display (Maybe Char)
+
 -- | The attribute to use for display.
 displayAttr :: Lens' Display Attribute
 
@@ -146,6 +156,7 @@ instance FromJSONE Display Display where
 
     liftE $ do
       let _defaultChar = c
+          _boundaryOverride = Nothing
       _orientationMap <- v .:? "orientationMap" .!= dOM
       _curOrientation <- v .:? "curOrientation" .!= (defD ^. curOrientation)
       _displayAttr <- (v .:? "attr") .!= (defD ^. displayAttr)
@@ -179,9 +190,11 @@ instance ToJSON Display where
 
 -- | Look up the character that should be used for a display.
 displayChar :: Display -> Char
-displayChar disp = fromMaybe (disp ^. defaultChar) $ do
-  DAbsolute d <- disp ^. curOrientation
-  M.lookup d (disp ^. orientationMap)
+displayChar disp =
+  fromMaybe (disp ^. defaultChar) $
+    disp ^. boundaryOverride <|> do
+      DAbsolute d <- disp ^. curOrientation
+      M.lookup d (disp ^. orientationMap)
 
 -- | Modify a display to use a @?@ character for entities that are
 --   hidden/unknown.
@@ -204,6 +217,7 @@ defaultEntityDisplay c =
     { _defaultChar = c
     , _orientationMap = M.empty
     , _curOrientation = Nothing
+    , _boundaryOverride = Nothing
     , _displayAttr = AEntity
     , _displayPriority = 1
     , _invisible = False
@@ -227,6 +241,7 @@ defaultRobotDisplay =
           , (DSouth, 'v')
           , (DNorth, '^')
           ]
+    , _boundaryOverride = Nothing
     , _curOrientation = Nothing
     , _displayAttr = ARobot
     , _displayPriority = 10
@@ -236,3 +251,61 @@ defaultRobotDisplay =
 
 instance Monoid Display where
   mempty = defaultEntityDisplay ' ' & invisible .~ True
+
+-- * Boundary rendering
+
+-- | This type is isomorphic to 'Bool' but
+-- is more compact for readability of the
+-- 'glyphForNeighbors' cases.
+data Presence
+  = -- | present
+    X
+  | -- | absent
+    O
+
+emptyNeighbors :: Neighbors Presence
+emptyNeighbors = Neighbors O O O O
+
+data Neighbors a = Neighbors
+  { e :: a
+  , w :: a
+  , n :: a
+  , s :: a
+  }
+
+computeNeighborPresence :: (AbsoluteDir -> Bool) -> Neighbors Presence
+computeNeighborPresence checkPresence =
+  foldr assignPresence emptyNeighbors enumerate
+ where
+  assignPresence d = applyWhen (checkPresence d) $ setNeighbor d X
+
+setNeighbor :: AbsoluteDir -> a -> Neighbors a -> Neighbors a
+setNeighbor DNorth x y = y {n = x}
+setNeighbor DSouth x y = y {s = x}
+setNeighbor DEast x y = y {e = x}
+setNeighbor DWest x y = y {w = x}
+
+-- | For a center cell that itself is a boundary,
+-- determine a glyph override for rendering, given certain
+-- neighbor combinations.
+glyphForNeighbors :: Neighbors Presence -> Maybe Char
+glyphForNeighbors = \case
+  Neighbors {e = O, w = O, n = O, s = O} -> Nothing
+  Neighbors {e = X, w = X, n = O, s = O} -> Just '─'
+  Neighbors {e = X, w = O, n = O, s = O} -> Just '╶'
+  Neighbors {e = O, w = X, n = O, s = O} -> Just '╴'
+  Neighbors {e = O, w = O, n = X, s = X} -> Just '│'
+  Neighbors {e = O, w = O, n = O, s = X} -> Just '╷'
+  Neighbors {e = O, w = O, n = X, s = O} -> Just '╵'
+  Neighbors {e = X, w = X, n = X, s = X} -> Just '┼'
+  Neighbors {e = O, w = X, n = O, s = X} -> Just '┐'
+  Neighbors {e = X, w = O, n = O, s = X} -> Just '┌'
+  Neighbors {e = O, w = X, n = X, s = O} -> Just '┘'
+  Neighbors {e = X, w = O, n = X, s = O} -> Just '└'
+  Neighbors {e = O, w = X, n = X, s = X} -> Just '┤'
+  Neighbors {e = X, w = O, n = X, s = X} -> Just '├'
+  Neighbors {e = X, w = X, n = X, s = O} -> Just '┴'
+  Neighbors {e = X, w = X, n = O, s = X} -> Just '┬'
+
+getBoundaryDisplay :: (AbsoluteDir -> Bool) -> Maybe Char
+getBoundaryDisplay = glyphForNeighbors . computeNeighborPresence

src/swarm-scenario/Swarm/Game/Entity.hs

@@ -157,6 +157,8 @@ data EntityProperty
     Pushable
   | -- | Obstructs the view of robots that attempt to "scout"
     Opaque
+  | -- | Is automatically rendered as a contiguous border
+    Boundary
   | -- | Regrows from a seed after it is harvested.
     Growable
   | -- | Can burn when ignited (either via 'Swarm.Language.Syntax.Ignite' or by

src/swarm-tui/Swarm/TUI/View.hs

@@ -1105,6 +1105,7 @@ displayProperties = displayList . mapMaybe showProperty
   showProperty Liquid = Just "liquid"
   showProperty Unwalkable = Just "blocking"
   showProperty Opaque = Just "opaque"
+  showProperty Boundary = Just "boundary"
   -- Most things are pickable so we don't show that.
   showProperty Pickable = Nothing
   -- 'Known' is just a technical detail of how we handle some entities

src/swarm-tui/Swarm/TUI/View/CellDisplay.hs

@@ -23,14 +23,17 @@ import Linear.Affine ((.-.))
 import Swarm.Game.Display (
   Attribute (AEntity),
   Display,
+  boundaryOverride,
   defaultEntityDisplay,
   displayAttr,
   displayChar,
   displayPriority,
+  getBoundaryDisplay,
   hidden,
  )
 import Swarm.Game.Entity
 import Swarm.Game.Land
+import Swarm.Game.Location (Point (..), toHeading)
 import Swarm.Game.Robot
 import Swarm.Game.Scenario.Topography.EntityFacade
 import Swarm.Game.Scenario.Topography.Structure.Recognition (foundStructures, recognitionState)
@@ -44,13 +47,15 @@ import Swarm.Game.Tick (TickNumber (..))
 import Swarm.Game.Universe
 import Swarm.Game.World qualified as W
 import Swarm.Game.World.Coords
+import Swarm.Language.Syntax.Direction (AbsoluteDir (..))
 import Swarm.TUI.Editor.Masking
 import Swarm.TUI.Editor.Model
 import Swarm.TUI.Editor.Util qualified as EU
 import Swarm.TUI.Model.Name
 import Swarm.TUI.Model.UI.Gameplay
 import Swarm.TUI.View.Attribute.Attr
 import Swarm.Util (applyWhen)
+import Swarm.Util.Content (getContentAt)
 import Witch (from)
 import Witch.Encoding qualified as Encoding
 
@@ -140,9 +145,20 @@ displayEntityCell ::
   Cosmic Coords ->
   [Display]
 displayEntityCell worldEditor ri coords =
-  maybeToList $ displayForEntity <$> maybeEntity
+  maybeToList $ assignBoundaryOverride . displayForEntity <$> maybeEntityPaint
  where
-  (_, maybeEntity) = EU.getEditorContentAt (terrMap ri) worldEditor (multiworldInfo ri) coords
+  maybeEntityPaint = getEntPaintAtCoord coords
+
+  getEntPaintAtCoord = snd . EU.getEditorContentAt (terrMap ri) worldEditor (multiworldInfo ri)
+  coordHasBoundary = maybe False (`hasProperty` Boundary) . snd . getContentAt (terrMap ri) (multiworldInfo ri)
+
+  assignBoundaryOverride = applyWhen (coordHasBoundary coords) (boundaryOverride .~ getBoundaryDisplay checkPresence)
+   where
+    checkPresence :: AbsoluteDir -> Bool
+    checkPresence d = coordHasBoundary offsettedCoord
+     where
+      offsettedCoord = (`addTuple` xy) <$> coords
+      Coords xy = locToCoords $ P $ toHeading d
 
   displayForEntity :: EntityPaint -> Display
   displayForEntity e = (if isKnownFunc ri e then id else hidden) $ getDisplay e

test/integration/Main.hs

@@ -377,6 +377,7 @@ testScenarioSolutions rs ui key =
         , testSolution Default "Testing/1533-sow-seed-maturation"
         , testSolution Default "Testing/2085-toplevel-mask"
         , testSolution Default "Testing/2086-structure-palette"
+        , testSolution Default "Testing/1271-wall-boundaries"
         , testGroup
             -- Note that the description of the classic world in
             -- data/worlds/classic.yaml (automatically tested to some