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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
{-# LANGUAGE TemplateHaskell #-}
module Xanthous.Entities.Environment
(
-- * Walls
Wall(..)
-- * Doors
, Door(..)
, open
, closed
, locked
, unlockedDoor
-- * Messages
, GroundMessage(..)
-- * Stairs
, Staircase(..)
) 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.Data.Entities
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
entityAttributes _ = defaultEntityAttributes
& blocksVision .~ True
& blocksObject .~ 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
= str . pure . ($ door ^. open) $ 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
_ -> allsidesDoor
where
horizDoor True = '␣'
horizDoor False = 'ᚔ'
vertDoor True = '['
vertDoor False = 'ǂ'
allsidesDoor True = '+'
allsidesDoor False = '▥'
instance Brain Door where step = brainVia Brainless
instance Entity Door where
entityAttributes door = defaultEntityAttributes
& blocksVision .~ not (door ^. open)
description door | door ^. open = "an open door"
| otherwise = "a closed door"
entityChar _ = "d"
entityCollision door | door ^. open = Nothing
| otherwise = Just Stop
closed :: Lens' Door Bool
closed = open . involuted not
-- | A closed, unlocked door
unlockedDoor :: Door
unlockedDoor = Door
{ _open = False
, _locked = False
}
--------------------------------------------------------------------------------
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
instance Brain GroundMessage where step = brainVia Brainless
instance Entity GroundMessage where
description = const "a message on the ground. Press r. to read it."
entityChar = const "≈"
entityCollision = const Nothing
--------------------------------------------------------------------------------
data Staircase = UpStaircase | DownStaircase
deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary Staircase
deriving (ToJSON, FromJSON)
via WithOptions '[ 'TagSingleConstructors 'True
, 'SumEnc 'ObjWithSingleField
]
Staircase
instance Brain Staircase where step = brainVia Brainless
instance Draw Staircase where
draw UpStaircase = str "<"
draw DownStaircase = str ">"
instance Entity Staircase where
description UpStaircase = "a staircase leading upwards"
description DownStaircase = "a staircase leading downwards"
entityChar UpStaircase = "<"
entityChar DownStaircase = ">"
entityCollision = const Nothing
|
