support terrain rendering

swarm-game · Nov 18, 2023 · aa10513 · aa10513
1 parent b07b430
commit aa10513
Show file tree

Hide file tree

Showing 4 changed files with 50 additions and 19 deletions.
diff --git a/src/Swarm/Game/Entity/Cosmetic.hs b/src/Swarm/Game/Entity/Cosmetic.hs
@@ -32,3 +32,8 @@ newtype WorldAttr = WorldAttr
   { attrSuffix :: String
   }
   deriving (Eq, Ord, Show)
+
+newtype TerrainAttr = TerrainAttr
+  { terrainAttrSuffix :: String
+  }
+  deriving (Eq, Ord, Show)
diff --git a/src/Swarm/Game/Entity/Specimens.hs b/src/Swarm/Game/Entity/Specimens.hs
@@ -10,6 +10,8 @@ import Data.Map (Map)
 import Data.Map qualified as M
 import Swarm.Game.Entity.Cosmetic
 
+-- * Entities
+
 entity :: (WorldAttr, HiFiColor)
 entity = (WorldAttr "entity", FgOnly whiteRGB)
 
@@ -48,6 +50,29 @@ worldAttributes =
         , ("blue", blueRGB)
         ]
 
+-- * Terrain
+
+dirt :: (TerrainAttr, HiFiColor)
+dirt = (TerrainAttr "dirt", FgOnly $ RGB 165 42 42)
+
+grass :: (TerrainAttr, HiFiColor)
+grass = (TerrainAttr "grass", FgOnly $ RGB 0 32 0) -- dark green
+
+stone :: (TerrainAttr, HiFiColor)
+stone = (TerrainAttr "stone", FgOnly $ RGB 32 32 32)
+
+ice :: (TerrainAttr, HiFiColor)
+ice = (TerrainAttr "ice", BgOnly whiteRGB)
+
+terrainAttributes :: M.Map TerrainAttr HiFiColor
+terrainAttributes =
+  M.fromList
+    [ dirt
+    , grass
+    , stone
+    , ice
+    ]
+
 -- * Named colors
 
 whiteRGB :: RGBColor

diff --git a/src/Swarm/Game/World/Render.hs b/src/Swarm/Game/World/Render.hs
@@ -19,14 +19,16 @@ import Linear (V2 (..))
 import Swarm.Doc.Gen (loadStandaloneScenario)
 import Swarm.Game.Display (Attribute (AWorld), defaultChar, displayAttr)
 import Swarm.Game.Entity.Cosmetic
+import Swarm.Game.Entity.Specimens (terrainAttributes)
 import Swarm.Game.Location
 import Swarm.Game.ResourceLoading (initNameGenerator, readAppData)
-import Swarm.Game.Scenario (Scenario, area, scenarioCosmetics, scenarioWorlds, ul, worldName)
+import Swarm.Game.Scenario (Scenario, area, scenarioCosmetics, scenarioWorlds, worldName)
 import Swarm.Game.Scenario.Status (seedLaunchParams)
 import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..), getAreaDimensions, isEmpty, upperLeftToBottomRight)
 import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.EntityFacade (EntityFacade (..), mkFacade)
 import Swarm.Game.State
+import Swarm.Game.Terrain (getTerrainWord)
 import Swarm.Game.Universe
 import Swarm.Game.World qualified as W
 import Swarm.TUI.Editor.Util (getContentAt, getMapRectangle)
@@ -54,9 +56,13 @@ getDisplayChar = maybe ' ' facadeChar . erasableToMaybe . cellEntity
   facadeChar (EntityFacade _ d) = view defaultChar d
 
 getDisplayColor :: M.Map WorldAttr HiFiColor -> PCell EntityFacade -> PixelRGBA8
-getDisplayColor aMap (Cell _terr cellEnt _) =
-  maybe transparent facadeColor $ erasableToMaybe cellEnt
+getDisplayColor aMap (Cell terr cellEnt _) =
+  maybe terrainFallback facadeColor $ erasableToMaybe cellEnt
  where
+  terrainFallback =
+    maybe transparent mkPixelColor $
+      M.lookup (TerrainAttr $ T.unpack $ getTerrainWord terr) terrainAttributes
+
   transparent = PixelRGBA8 0 0 0 0
   facadeColor (EntityFacade _ d) = maybe transparent mkPixelColor $ case d ^. displayAttr of
     AWorld n -> M.lookup (WorldAttr $ T.unpack n) aMap

diff --git a/src/Swarm/TUI/View/Attribute/Attr.hs b/src/Swarm/TUI/View/Attribute/Attr.hs
@@ -87,7 +87,7 @@ swarmAttrMap =
     $ NE.toList activityMeterAttributes
       <> NE.toList robotMessageAttributes
       <> map (getWorldAttrName *** vtyColor . fromHiFi) (M.toList worldAttributes)
-      <> terrainAttr
+      <> map (getTerrainAttrName *** vtyColor . fromHiFi) (M.toList terrainAttributes)
       <> [ -- Robot attribute
            (robotAttr, fg V.white `V.withStyle` V.bold)
          , -- UI rendering attributes
@@ -115,6 +115,12 @@ swarmAttrMap =
            (defAttr, V.defAttr)
          ]
 
+terrainPrefix :: AttrName
+terrainPrefix = attrName "terrain"
+
+getTerrainAttrName :: TerrainAttr -> AttrName
+getTerrainAttrName (TerrainAttr n) = terrainPrefix <> attrName n
+
 worldPrefix :: AttrName
 worldPrefix = attrName "world"
 
@@ -159,26 +165,15 @@ activityMeterAttributes =
 meterAttributeNames :: NonEmpty AttrName
 meterAttributeNames = NE.map fst activityMeterAttributes
 
-terrainPrefix :: AttrName
-terrainPrefix = attrName "terrain"
-
-terrainAttr :: [(AttrName, V.Attr)]
-terrainAttr =
-  [ (dirtAttr, fg (V.rgbColor @Int 165 42 42))
-  , (grassAttr, fg (V.rgbColor @Int 0 32 0)) -- dark green
-  , (stoneAttr, fg (V.rgbColor @Int 32 32 32))
-  , (iceAttr, bg V.white)
-  ]
-
 -- | The default robot attribute.
 robotAttr :: AttrName
 robotAttr = attrName "robot"
 
 dirtAttr, grassAttr, stoneAttr, iceAttr :: AttrName
-dirtAttr = terrainPrefix <> attrName "dirt"
-grassAttr = terrainPrefix <> attrName "grass"
-stoneAttr = terrainPrefix <> attrName "stone"
-iceAttr = terrainPrefix <> attrName "ice"
+dirtAttr = getTerrainAttrName $ fst dirt
+grassAttr = getTerrainAttrName $ fst grass
+stoneAttr = getTerrainAttrName $ fst stone
+iceAttr = getTerrainAttrName $ fst ice
 
 -- | Some defined attribute names used in the Swarm TUI.
 highlightAttr