1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
{-# LANGUAGE TemplateHaskell #-}
module Xanthous.Entities.Environment
(
-- * Walls
Wall(..)
-- * Doors
, Door(..)
, open
, locked
-- * Messages
, GroundMessage(..)
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Test.QuickCheck
import Brick (str)
import Brick.Widgets.Border.Style (unicode)
import Brick.Types (Edges(..))
import Data.Aeson
import Data.Aeson.Generic.DerivingVia
--------------------------------------------------------------------------------
import Xanthous.Entities.Draw.Util
import Xanthous.Data
import Xanthous.Game.State
import Xanthous.Util.QuickCheck
--------------------------------------------------------------------------------
data Wall = Wall
deriving stock (Show, Eq, Ord, Generic, Enum)
deriving anyclass (NFData, CoArbitrary, Function)
instance ToJSON Wall where
toJSON = const $ String "Wall"
instance FromJSON Wall where
parseJSON = withText "Wall" $ \case
"Wall" -> pure Wall
_ -> fail "Invalid Wall: expected Wall"
instance Brain Wall where step = brainVia Brainless
instance Entity Wall where
blocksVision _ = True
description _ = "a wall"
entityChar _ = "┼"
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 neighs
data Door = Door
{ _open :: Bool
, _locked :: Bool
}
deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
deriving Arbitrary via GenericArbitrary Door
makeLenses ''Door
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
horizDoor = '␣'
vertDoor = '['
instance Brain Door where step = brainVia Brainless
instance Entity Door where
blocksVision = not . view open
description _ = "a door"
entityChar _ = "d"
--------------------------------------------------------------------------------
newtype GroundMessage = GroundMessage Text
deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary GroundMessage
deriving (ToJSON, FromJSON)
via WithOptions '[ 'TagSingleConstructors 'True
, 'SumEnc 'ObjWithSingleField
]
GroundMessage
deriving Draw
via DrawStyledCharacter ('Just 'Yellow) 'Nothing "≈"
GroundMessage
deriving Entity
via DeriveEntity 'False "a message on the ground. Press r. to read it."
"≈"
GroundMessage
instance Brain GroundMessage where step = brainVia Brainless
|
