Add draw priority

Rather than blindly taking one entity from the list when we have
multiple entities on the same tile, add a `drawPriority` method to the
Draw typeclass which allows individual entities to request to be drawn
on top - this avoids the "noodles floating over your head" bug we saw
before.

5 files changed, 30 insertions, 6 deletions

diff --git a/src/Xanthous/Entities.hs b/src/Xanthous/Entities.hs
index 93c4813cc4..ccd3ae42bf 100644
--- a/src/Xanthous/Entities.hs
+++ b/src/Xanthous/Entities.hs
@@ -10,6 +10,7 @@ module Xanthous.Entities
   , DrawCharacter(..)
   , DrawStyledCharacter(..)
   , DrawRawChar(..)
+  , DrawRawCharPriority(..)
   , Entity(..)
   , SomeEntity(..)
   , downcastEntity
@@ -97,6 +98,21 @@ instance
   ) => Draw (DrawRawChar rawField a) where
   draw (DrawRawChar e) = draw $ e ^. field @rawField . char
 
+newtype DrawRawCharPriority
+  (rawField :: Symbol)
+  (priority :: Nat)
+  (a :: Type)
+  = DrawRawCharPriority a
+
+instance
+  forall rawField priority a raw.
+  ( HasField rawField a a raw raw
+  , KnownNat priority
+  , HasChar raw EntityChar
+  ) => Draw (DrawRawCharPriority rawField priority a) where
+  draw (DrawRawCharPriority e) = draw $ e ^. field @rawField . char
+  drawPriority = const . fromIntegral $ natVal @priority Proxy
+
 --------------------------------------------------------------------------------
 
 data EntityChar = EntityChar
diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs
index 7d2d22c998..e3cbb2c038 100644
--- a/src/Xanthous/Entities/Character.hs
+++ b/src/Xanthous/Entities/Character.hs
@@ -50,6 +50,7 @@ instance Draw Character where
     where
       rloc = Location (negate scrollOffset, negate scrollOffset)
       rreg = (2 * scrollOffset, 2 * scrollOffset)
+  drawPriority = const maxBound -- Character should always be on top, for now
 
 -- the character does not (yet) have a mind of its own
 instance Brain Character where step = brainVia Brainless
diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs
index 6ea6f93e42..4ad751a582 100644
--- a/src/Xanthous/Entities/Creature.hs
+++ b/src/Xanthous/Entities/Creature.hs
@@ -35,7 +35,7 @@ import           Data.Aeson.Generic.DerivingVia
 import           Data.Aeson (ToJSON, FromJSON)
 --------------------------------------------------------------------------------
 import           Xanthous.Entities.RawTypes hiding (Creature, description)
-import           Xanthous.Entities (Draw(..), DrawRawChar(..))
+import           Xanthous.Entities (Draw(..), DrawRawCharPriority(..))
 import           Xanthous.Data
 --------------------------------------------------------------------------------
 
@@ -83,7 +83,7 @@ data Creature = Creature
   }
   deriving stock (Eq, Show, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
-  deriving Draw via DrawRawChar "_creatureType" Creature
+  deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature
   deriving (ToJSON, FromJSON)
        via WithOptions '[ FieldLabelModifier '[Drop 1] ]
                        Creature
diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index 24c177513e..b7d7a76956 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/src/Xanthous/Game/Draw.hs
@@ -4,12 +4,12 @@ module Xanthous.Game.Draw
   ) where
 --------------------------------------------------------------------------------
 import           Xanthous.Prelude
-import           Brick hiding (loc)
+import           Brick hiding (loc, on)
 import           Brick.Widgets.Border
 import           Brick.Widgets.Border.Style
 import           Brick.Widgets.Edit
 --------------------------------------------------------------------------------
-import           Xanthous.Data (Position'(..), type Position, x, y, loc)
+import           Xanthous.Data
 import           Xanthous.Data.EntityMap (EntityMap, atPosition)
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Entities
@@ -68,7 +68,10 @@ drawEntities canRenderPos allEnts
       | canRenderPos pos
       = let neighbors = EntityMap.neighbors pos allEnts
         in maybe (str " ") (drawWithNeighbors neighbors)
-           $ allEnts ^? atPosition pos . folded
+           $ maximumByOf
+             (atPosition pos . folded)
+             (compare `on` drawPriority)
+             allEnts
       | otherwise = str " "
 
 drawMap :: GameState -> Widget Name
diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs
index c437f640c0..e3df5c60de 100644
--- a/src/Xanthous/Game/State.hs
+++ b/src/Xanthous/Game/State.hs
@@ -58,7 +58,6 @@ import           Brick (EventM, Widget)
 --------------------------------------------------------------------------------
 import           Xanthous.Data.EntityMap (EntityMap, EntityID)
 import           Xanthous.Data
-                 (Positioned(..), type Position, Neighbors, Ticks(..))
 import           Xanthous.Orphans ()
 import           Xanthous.Game.Prompt
 import           Xanthous.Resource
@@ -143,6 +142,10 @@ class Draw a where
   draw :: a -> Widget n
   draw = drawWithNeighbors $ pure mempty
 
+  -- | higher priority gets drawn on top
+  drawPriority :: a -> Word
+  drawPriority = const minBound
+
 instance Draw a => Draw (Positioned a) where
   drawWithNeighbors ns (Positioned _ a) = drawWithNeighbors ns a
   draw (Positioned _ a) = draw a
@@ -185,6 +188,7 @@ instance Eq SomeEntity where
 
 instance Draw SomeEntity where
   drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
+  drawPriority (SomeEntity ent) = drawPriority ent
 
 instance Brain SomeEntity where
   step ticks (Positioned pos (SomeEntity ent)) =