Add doors and an open command

Add a Door entity and an Open command, which necessitated supporting the
direction prompt. Currently nothing actually puts doors on the map,
which puts a slight damper on actually testing this out.

1 files changed, 41 insertions, 3 deletions

diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs
index 90fa05315a57..d9275266b0f4 100644
--- a/src/Xanthous/Entities/Environment.hs
+++ b/src/Xanthous/Entities/Environment.hs
@@ -1,13 +1,19 @@
+{-# LANGUAGE TemplateHaskell #-}
 module Xanthous.Entities.Environment
   ( Wall(..)
+  , Door(..)
+  , open
+  , locked
   ) where
 --------------------------------------------------------------------------------
 import Xanthous.Prelude
 import Test.QuickCheck
+import Test.QuickCheck.Arbitrary.Generic
 import Brick (str)
 import Brick.Widgets.Border.Style (unicode)
+import Brick.Types (Edges(..))
 --------------------------------------------------------------------------------
-import Xanthous.Entities (Draw(..), entityIs, Entity(..))
+import Xanthous.Entities (Draw(..), entityIs, Entity(..), SomeEntity)
 import Xanthous.Entities.Draw.Util
 import Xanthous.Data
 --------------------------------------------------------------------------------
@@ -22,8 +28,40 @@ instance Entity Wall where
 instance Arbitrary Wall where
   arbitrary = pure Wall
 
+wallEdges :: (MonoFoldable mono, Element mono ~ SomeEntity)
+          => Neighbors mono -> Edges Bool
+wallEdges neighs = any (entityIs @Wall) <$> edges neighs
+
 instance Draw Wall where
   drawWithNeighbors neighs _wall =
-    str . pure . borderFromEdges unicode $ wallEdges
+    str . pure . borderFromEdges unicode $ wallEdges neighs
+
+data Door = Door
+  { _open   :: Bool
+  , _locked :: Bool
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+makeLenses ''Door
+
+instance Arbitrary Door where
+  arbitrary = genericArbitrary
+
+instance Draw Door where
+  drawWithNeighbors neighs door
+    | door ^. open
+    = str . pure $ case wallEdges neighs of
+        Edges True  False  False False -> vertDoor
+        Edges False True   False False -> vertDoor
+        Edges True  True   False False -> vertDoor
+        Edges False False  True  False -> horizDoor
+        Edges False False  False True  -> horizDoor
+        Edges False False  True  True  -> horizDoor
+        _                              -> '+'
+    | otherwise    = str "\\"
     where
-      wallEdges = any (entityIs @Wall) <$> edges neighs
+      horizDoor = '␣'
+      vertDoor = '['
+
+instance Entity Door where
+  blocksVision = not . view open